diff options
249 files changed, 7625 insertions, 3341 deletions
diff --git a/.github/CODEOWNERS b/.github/CODEOWNERS index f802040a1d..06a733be45 100644 --- a/.github/CODEOWNERS +++ b/.github/CODEOWNERS @@ -240,8 +240,7 @@ azure-pipelines.yml @coq/ci-maintainers /theories/QArith/ @herbelin -/theories/Reals/ @silene -# Secondary maintainer @ppedrot +/theories/Reals/ @coq/reals-library-maintainers /theories/Relations/ @mattam82 # Secondary maintainer @ppedrot diff --git a/.gitignore b/.gitignore index 4e02e7617c..23e305892e 100644 --- a/.gitignore +++ b/.gitignore @@ -150,6 +150,8 @@ kernel/byterun/coq_jumptbl.h kernel/genOpcodeFiles.exe kernel/copcodes.ml kernel/uint63.ml +ide/default.bindings +ide/default_bindings_src.exe ide/index_urls.txt .lia.cache .nia.cache diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 309044a1e9..2066dce13a 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -10,7 +10,7 @@ stages: variables: # Format: $IMAGE-V$DATE [Cache is not used as of today but kept here # for reference] - CACHEKEY: "bionic_coq-V2019-03-11-V1" + CACHEKEY: "bionic_coq-V2019-03-12-V1" IMAGE: "$CI_REGISTRY_IMAGE:$CACHEKEY" # By default, jobs run in the base switch; override to select another switch OPAM_SWITCH: "base" @@ -253,6 +253,9 @@ build:base+async: COQ_EXTRA_CONF: "-native-compiler yes -coqide opt" COQUSERFLAGS: "-async-proofs on" allow_failure: true # See https://github.com/coq/coq/issues/9658 + only: + variables: + - $UNRELIABLE =~ /enabled/ build:quick: extends: .build-template @@ -260,6 +263,9 @@ build:quick: COQ_EXTRA_CONF: "-native-compiler no" QUICK: "1" allow_failure: true # See https://github.com/coq/coq/issues/9637 + only: + variables: + - $UNRELIABLE =~ /enabled/ windows64: extends: .windows-template @@ -314,6 +320,7 @@ pkg:opam: dependencies: [] # We don't need to download build artifacts before_script: [] # We don't want to use the shared 'before_script' script: + - cat /proc/{cpu,mem}info || true # Use current worktree as tmpdir to allow exporting artifacts in case of failure - export TMPDIR=$PWD # We build an expression rather than a direct URL to not be dependent on @@ -351,7 +358,8 @@ pkg:nix:deploy:channel: script: - echo "$CACHIX_DEPLOYMENT_KEY" | tr -d '\r' | ssh-add - > /dev/null - git fetch --unshallow - - git push git@github.com:coq/coq-on-cachix "${CI_COMMIT_REF_NAME}" + - git branch -v + - git push git@github.com:coq/coq-on-cachix "${CI_COMMIT_SHA}":"${CI_COMMIT_REF_NAME}" pkg:nix: extends: .nix-template @@ -457,7 +465,9 @@ test-suite:edge+trunk+make: - eval $(opam env) - opam repo add ocaml-beta https://github.com/ocaml/ocaml-beta-repository.git - opam update - - opam install ocaml-variants=4.09.0+trunk num + - opam install ocaml-variants=4.09.0+trunk + - opam pin add -n ocamlfind --dev + - opam install num - eval $(opam env) # We avoid problems with warnings: - ./configure -profile devel -warn-error no @@ -481,9 +491,10 @@ test-suite:edge+trunk+dune: - eval $(opam env) - opam repo add ocaml-beta https://github.com/ocaml/ocaml-beta-repository.git - opam update - - opam install ocaml-variants=4.09.0+trunk num + - opam install ocaml-variants=4.09.0+trunk + - opam pin add -n ocamlfind --dev - opam pin add dune --dev # ounit lablgtk conf-gtksourceview - - opam install dune + - opam install dune num - eval $(opam env) # We use the release profile to avoid problems with warnings - make -f Makefile.dune trunk @@ -505,7 +516,11 @@ test-suite:base+async: dependencies: - build:base variables: - COQFLAGS: "-async-proofs on" + COQFLAGS: "-async-proofs on -async-proofs-cache force" + allow_failure: true + only: + variables: + - $UNRELIABLE =~ /enabled/ validate:base: extends: .validate-template @@ -531,6 +546,9 @@ validate:quick: extends: .validate-template dependencies: - build:quick + only: + variables: + - $UNRELIABLE =~ /enabled/ # Libraries are by convention the projects that depend on Coq # but not on its ML API diff --git a/CHANGES.md b/CHANGES.md index 3e50a13e9e..bf4244bdf9 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -17,6 +17,8 @@ OCaml and dependencies Coqide +- CoqIDE now depends on gtk+3 and lablgtk3, rather than gtk+2 and lablgtk2. + - CoqIDE now properly sets the module name for a given file based on its path, see -topfile change entry for more details. @@ -48,6 +50,13 @@ Kernel - Added primitive integers +- Unfolding heuristic in termination checking made more complete. + In particular Coq is now more aggressive in unfolding constants + when it looks for a iota redex. Performance regression may occur + in Fixpoint declarations without an explicit {struct} annotation, + since guessing the decreasing argument can now be more expensive. + (PR #9602) + Notations - New command `Declare Scope` to explicitly declare a scope name @@ -140,6 +149,16 @@ Vernacular commands - `Hypotheses` and `Variables` can now take implicit binders inside sections. +- Removed deprecated option `Automatic Coercions Import`. + +- The `Show Script` command has been deprecated. + +- Option `Refine Instance Mode` has been deprecated and will be removed in + the next version. + +- `Coercion` does not warn ambiguous paths which are obviously convertible with + existing ones. + Tools - The `-native-compiler` flag of `coqc` and `coqtop` now takes an argument which can have three values: @@ -154,6 +173,16 @@ Tools - A new `-bytecode-compiler` flag for `coqc` and `coqtop` controls whether conversion can use the VM. The default value is `yes`. +- CoqIDE now supports input for Unicode characters. For example, typing + "\alpha" then the "Shift+Space" will insert the greek letter alpha. + In fact, typing the prefix string "\a" is sufficient. + A larger number of default bindings are provided, following the latex + naming convention. Bindings can be customized, either globally, or on a + per-project basis, with the requirement is that keys must begin with a + backslash and contain no space character. Bindings may be assigned custom + priorities, so that prefixes resolve to the most convenient bindings. + The documentation pages for CoqIDE provides further details. + Standard Library - Added lemmas about monotonicity of `N.double` and `N.succ_double`, and about @@ -229,6 +258,12 @@ SSReflect - `=> {x..} /H` -> `=> /v {x..H}` - `rewrite {x..} H` -> `rewrite E {x..H}` +Diffs + +- Some error messages that show problems with a pair of non-matching values will now + highlight the differences. + + Changes from 8.8.2 to 8.9+beta1 =============================== @@ -43,8 +43,8 @@ WHAT DO YOU NEED ? - a C compiler - - for CoqIDE, the lablgtk development files (version >= 2.18.5), - and the GTK 2.x libraries including gtksourceview2. + - for CoqIDE, the lablgtk development files (version >= 3.0.0), + and the GTK 3.x libraries including gtksourceview3. Note that num and lablgtk should be properly registered with findlib/ocamlfind as Coq's makefile will use it to locate the @@ -263,6 +263,7 @@ clean-ide: rm -f ide/input_method_lexer.ml rm -f ide/highlight.ml ide/config_lexer.ml ide/config_parser.mli ide/config_parser.ml rm -f ide/utf8_convert.ml + rm -f ide/default.bindings rm -rf $(COQIDEAPP) mlgclean: diff --git a/Makefile.doc b/Makefile.doc index 912738cd00..e89a20393c 100644 --- a/Makefile.doc +++ b/Makefile.doc @@ -31,7 +31,13 @@ DVIPS:=dvips HTMLSTYLE:=coqremote # Sphinx-related variables +OSNAME:=$(shell uname -o) +ifeq ($(OSNAME),Cygwin) +WIN_CURDIR:=$(shell cygpath -w $(CURDIR)) +SPHINXENV:=COQBIN="$(CURDIR)/bin/" COQLIB="$(WIN_CURDIR)" +else SPHINXENV:=COQBIN="$(CURDIR)/bin/" COQLIB="$(CURDIR)" +endif SPHINXOPTS= -j4 SPHINXWARNERROR ?= 1 ifeq ($(SPHINXWARNERROR),1) @@ -209,10 +215,11 @@ install-doc-printable: install-doc-sphinx: $(MKDIR) $(FULLDOCDIR)/sphinx - (for f in `cd doc/sphinx/_build; find . -type f`; do \ - $(MKDIR) $$(dirname $(FULLDOCDIR)/sphinx/$$f);\ - $(INSTALLLIB) doc/sphinx/_build/$$f $(FULLDOCDIR)/sphinx/$$f;\ - done) + (for d in html latex; do \ + for f in `cd doc/sphinx/_build/$$d && find . -type f`; do \ + $(MKDIR) $$(dirname $(FULLDOCDIR)/sphinx/$$d/$$f);\ + $(INSTALLLIB) doc/sphinx/_build/$$d/$$f $(FULLDOCDIR)/sphinx/$$d/$$f;\ + done; done) # For emacs: # Local Variables: diff --git a/Makefile.dune b/Makefile.dune index 4609c563d9..ebf74978a9 100644 --- a/Makefile.dune +++ b/Makefile.dune @@ -42,8 +42,10 @@ help: @echo " - help: show this message" # We need to bootstrap with a dummy coq.plugins.ltac so install targets do work. -voboot: +plugins/ltac/dune: @echo "(library (name ltac_plugin) (public_name coq.plugins.ltac) (modules_without_implementation extraargs extratactics))" > plugins/ltac/dune + +voboot: plugins/ltac/dune dune build $(DUNEOPT) @vodeps dune exec ./tools/coq_dune.exe $(BUILD_CONTEXT)/.vfiles.d diff --git a/Makefile.ide b/Makefile.ide index db1cc3746d..908f5f6648 100644 --- a/Makefile.ide +++ b/Makefile.ide @@ -17,7 +17,6 @@ ## Coqide-related variables set by ./configure in config/Makefile -#COQIDEINCLUDES : something like -I +lablgtk2 #HASCOQIDE : opt / byte / no #IDEFLAGS : some extra cma, for instance #IDEOPTCDEPS : on windows, ide/ide_win32_stubs.o ide/coq_icon.o @@ -41,7 +40,11 @@ COQIDEINAPP:=$(COQIDEAPP)/Contents/MacOS/coqide IDESRCDIRS:= $(CORESRCDIRS) ide ide/protocol -COQIDEFLAGS=$(addprefix -I , $(IDESRCDIRS)) $(COQIDEINCLUDES) +ifeq ($(HASCOQIDE),no) +COQIDEFLAGS=$(addprefix -I , $(IDESRCDIRS)) +else +COQIDEFLAGS=$(addprefix -I , $(IDESRCDIRS)) -package lablgtk3-sourceview3 +endif IDEDEPS:=config/config.cma clib/clib.cma lib/lib.cma ide/protocol/ideprotocol.cma IDECMA:=ide/ide.cma @@ -52,21 +55,25 @@ IDETOPBYTE=bin/coqidetop.byte$(EXE) LINKIDE:=$(IDEDEPS) $(IDECDEPS) $(IDECMA) ide/coqide_os_specific.cmo ide/coqide_main.mli ide/coqide_main.ml LINKIDEOPT:=$(IDEOPTCDEPS) $(patsubst %.cma,%.cmxa,$(IDEDEPS:.cmo=.cmx)) $(IDECMA:.cma=.cmxa) ide/coqide_os_specific.cmx ide/coqide_main.mli ide/coqide_main.ml -IDEFILES=$(wildcard ide/*.lang) ide/coq_style.xml ide/coq.png ide/MacOS/default_accel_map +IDEBINDINGS:=ide/default.bindings +IDEBINDINGSSRC:=ide/default_bindings_src.ml +IDEBINDINGSEXE:=ide/default_bindings_src.exe + +IDEFILES=$(wildcard ide/*.lang) ide/coq_style.xml ide/coq.png ide/MacOS/default_accel_map $(IDEBINDINGS) ## GTK for Coqide MacOS bundle -GTKSHARE=$(shell pkg-config --variable=prefix gtk+-2.0)/share -GTKBIN=$(shell pkg-config --variable=prefix gtk+-2.0)/bin -GTKLIBS=$(shell pkg-config --variable=libdir gtk+-2.0) -PIXBUFBIN=$(shell pkg-config --variable=prefix gdk-pixbuf-2.0)/bin -SOURCEVIEWSHARE=$(shell pkg-config --variable=prefix gtksourceview-2.0)/share +GTKSHARE=$(shell pkg-config --variable=prefix gtk+-3.0)/share +GTKBIN=$(shell pkg-config --variable=prefix gtk+-3.0)/bin +GTKLIBS=$(shell pkg-config --variable=libdir gtk+-3.0) +PIXBUFBIN=$(shell pkg-config --variable=prefix gdk-pixbuf-3.0)/bin +SOURCEVIEWSHARE=$(shell pkg-config --variable=prefix gtksourceview-3.0)/share ########################################################################### # CoqIde special targets ########################################################################### -.PHONY: coqide coqide-opt coqide-byte coqide-files coqide-binaries +.PHONY: coqide coqide-opt coqide-byte coqide-bindings coqide-files coqide-binaries .PHONY: ide-toploop ide-byteloop ide-optloop # target to build CoqIde (native version) and the stuff needed to lauch it @@ -98,7 +105,7 @@ ifeq ($(HASCOQIDE),opt) $(COQIDE): $(LINKIDEOPT) $(SHOW)'OCAMLOPT -o $@' $(HIDE)$(OCAMLOPT) $(COQIDEFLAGS) $(OPTFLAGS) -o $@ \ - -linkpkg -package str,unix,dynlink,threads,lablgtk2.sourceview2 $(IDEFLAGS:.cma=.cmxa) $^ + -linkpkg -package str,unix,dynlink,threads,lablgtk3-sourceview3 -linkall $(IDEFLAGS:.cma=.cmxa) $^ $(STRIP_HIDE) $@ else $(COQIDE): $(COQIDEBYTE) @@ -108,7 +115,7 @@ endif $(COQIDEBYTE): $(LINKIDE) $(SHOW)'OCAMLC -o $@' $(HIDE)$(OCAMLC) $(COQIDEFLAGS) $(BYTEFLAGS) -o $@ \ - -linkpkg -package str,unix,dynlink,threads,lablgtk2.sourceview2 $(IDEFLAGS) $(IDECDEPSFLAGS) $^ + -linkpkg -package str,unix,dynlink,threads,lablgtk3-sourceview3 $(IDEFLAGS) $(IDECDEPSFLAGS) $^ ide/coqide_os_specific.ml: ide/coqide_$(IDEINT).ml.in config/Makefile @rm -f $@ @@ -128,7 +135,7 @@ ide/%.cmx: ide/%.ml $(HIDE)$(OCAMLOPT) $(COQIDEFLAGS) $(OPTFLAGS) -c $< # We need to compile this file without -safe-string due mess with -# lablgtk API. Other option is to require lablgtk >= 2.8.16 +# lablgtk API. Other option is to require lablgtk >= 3.0.0 ide/ideutils.cmo: ide/ideutils.ml $(SHOW)'OCAMLC $<' $(HIDE)$(filter-out -safe-string,$(OCAMLC)) $(COQIDEFLAGS) $(BYTEFLAGS) -c $< @@ -159,6 +166,15 @@ $(IDETOPBYTE): ide/idetop.ml $(LINKCMO) $(LIBCOQRUN) $(IDETOPCMA) $(SYSMOD) \ $(LINKCMO) $(IDETOPCMA) $(BYTEFLAGS) $< -o $@ +coqide-bindings: $(IDEBINDINGS) + +$(IDEBINDINGSEXE): $(IDEBINDINGSSRC) + $(OCAMLC) $< -o $@ + +$(IDEBINDINGS): $(IDEBINDINGSEXE) + $< $@ + + #################### ## Install targets #################### @@ -205,7 +221,7 @@ endif install-ide-files: #Please update $(COQIDEAPP)/Contents/Resources/ at the same time $(MKDIR) $(FULLDATADIR) - $(INSTALLLIB) ide/coq.png ide/*.lang ide/coq_style.xml $(FULLDATADIR) + $(INSTALLLIB) ide/coq.png ide/*.lang ide/coq_style.xml $(IDEBINDINGS) $(FULLDATADIR) $(MKDIR) $(FULLCONFIGDIR) if [ $(IDEINT) = QUARTZ ] ; then $(INSTALLLIB) ide/mac_default_accel_map $(FULLCONFIGDIR)/coqide.keys ; fi @@ -228,12 +244,12 @@ $(COQIDEAPP)/Contents: $(COQIDEINAPP): ide/macos_prehook.cmx $(LINKIDEOPT) | $(COQIDEAPP)/Contents $(SHOW)'OCAMLOPT -o $@' $(HIDE)$(OCAMLOPT) $(COQIDEFLAGS) $(OPTFLAGS) -o $@ \ - -linkpkg -package str,unix,dynlink,threads,lablgtk2.sourceview2 $(IDEFLAGS:.cma=.cmxa) $^ + -linkpkg -package str,unix,dynlink,threads,lablgtk3.sourceview3 $(IDEFLAGS:.cma=.cmxa) $^ $(STRIP_HIDE) $@ $(COQIDEAPP)/Contents/Resources/share: $(COQIDEAPP)/Contents $(MKDIR) $@/coq/ - $(INSTALLLIB) ide/coq.png ide/*.lang ide/coq_style.xml $@/coq/ + $(INSTALLLIB) ide/coq.png ide/*.lang ide/coq_style.xml $(IDEBINDINGS) $@/coq/ $(MKDIR) $@/gtksourceview-2.0/{language-specs,styles} $(INSTALLLIB) "$(SOURCEVIEWSHARE)/"gtksourceview-2.0/language-specs/{def.lang,language2.rng} $@/gtksourceview-2.0/language-specs/ $(INSTALLLIB) "$(SOURCEVIEWSHARE)/"gtksourceview-2.0/styles/{styles.rng,classic.xml} $@/gtksourceview-2.0/styles/ diff --git a/clib/unicode.ml b/clib/unicode.ml index 1e45c0d250..a122e2c46a 100644 --- a/clib/unicode.ml +++ b/clib/unicode.ml @@ -86,6 +86,7 @@ let classify = Unicodetable.ll; (* Letter, lowercase. *) Unicodetable.lt; (* Letter, titlecase. *) Unicodetable.lo; (* Letter, others. *) + Unicodetable.lm; (* Letter, modifier. *) ]; mk_lookup_table_from_unicode_tables_for IdentPart [ diff --git a/configure.ml b/configure.ml index 8b6fccb5e3..5b99851f83 100644 --- a/configure.ml +++ b/configure.ml @@ -150,7 +150,11 @@ let numeric_prefix_list s = let max = String.length s in let i = ref 0 in while !i < max && isnum s.[!i] do incr i done; - string_split '.' (String.sub s 0 !i) + match string_split '.' (String.sub s 0 !i) with + | [v] -> [v;"0";"0"] + | [v1;v2] -> [v1;v2;"0"] + | [v1;v2;""] -> [v1;v2;"0"] (* e.g. because it ends with ".beta" *) + | v -> v (** Combined existence and directory tests *) @@ -226,7 +230,6 @@ type preferences = { docdir : string option; coqdocdir : string option; ocamlfindcmd : string option; - lablgtkdir : string option; arch : string option; natdynlink : bool; coqide : ide option; @@ -263,7 +266,6 @@ let default = { docdir = None; coqdocdir = None; ocamlfindcmd = None; - lablgtkdir = None; arch = None; natdynlink = true; coqide = None; @@ -368,8 +370,6 @@ let args_options = Arg.align [ "<dir> Where to install Coqdoc style files"; "-ocamlfind", arg_string_option (fun p ocamlfindcmd -> { p with ocamlfindcmd }), "<dir> Specifies the ocamlfind command to use"; - "-lablgtkdir", arg_string_option (fun p lablgtkdir -> { p with lablgtkdir }), - "<dir> Specifies the path to the Lablgtk library"; "-flambda-opts", arg_string_list ' ' (fun p flambda_flags -> { p with flambda_flags }), "<flags> Specifies additional flags to be passed to the flambda optimizing compiler"; "-arch", arg_string_option (fun p arch -> { p with arch }), @@ -697,75 +697,31 @@ let check_for_numlib () = let numlib = check_for_numlib () -(** * lablgtk2 and CoqIDE *) +(** * lablgtk3 and CoqIDE *) -type source = Manual | OCamlFind | Stdlib - -let get_source = function -| Manual -> "manually provided" -| OCamlFind -> "via ocamlfind" -| Stdlib -> "in OCaml library" - -(** Is some location a suitable LablGtk2 installation ? *) - -let check_lablgtkdir ?(fatal=false) src dir = - let yell msg = if fatal then die msg else (warn "%s" msg; false) in - let msg = get_source src in - if not (dir_exists dir) then - yell (sprintf "No such directory '%s' (%s)." dir msg) - else if not (Sys.file_exists (dir/"gSourceView2.cmi")) then - yell (sprintf "Incomplete LablGtk2 (%s): no %s/gSourceView2.cmi." msg dir) - else if not (Sys.file_exists (dir/"glib.mli")) then - yell (sprintf "Incomplete LablGtk2 (%s): no %s/glib.mli." msg dir) - else true - -(** Detect and/or verify the Lablgtk2 location *) +(** Detect and/or verify the Lablgtk3 location *) let get_lablgtkdir () = - match !prefs.lablgtkdir with - | Some dir -> - let msg = Manual in - if check_lablgtkdir ~fatal:true msg dir then dir, msg - else "", msg - | None -> - let msg = OCamlFind in - let d1,_ = tryrun camlexec.find ["query";"lablgtk2.sourceview2"] in - if d1 <> "" && check_lablgtkdir msg d1 then d1, msg - else - (* In debian wheezy, ocamlfind knows only of lablgtk2 *) - let d2,_ = tryrun camlexec.find ["query";"lablgtk2"] in - if d2 <> "" && d2 <> d1 && check_lablgtkdir msg d2 then d2, msg - else - let msg = Stdlib in - let d3 = camllib^"/lablgtk2" in - if check_lablgtkdir msg d3 then d3, msg - else "", msg + tryrun camlexec.find ["query";"lablgtk3-sourceview3"] (** Detect and/or verify the Lablgtk2 version *) -let check_lablgtk_version src dir = match src with -| Manual | Stdlib -> - warn "Could not check the version of lablgtk2.\nMake sure your version is at least 2.18.3."; - (true, "an unknown version") -| OCamlFind -> - let v, _ = tryrun camlexec.find ["query"; "-format"; "%v"; "lablgtk2"] in - try - let vi = List.map s2i (numeric_prefix_list v) in - if vi < [2; 16; 0] then +let check_lablgtk_version () = + let v, _ = tryrun camlexec.find ["query"; "-format"; "%v"; "lablgtk3"] in + (true, v) + +(* ejgallego: we wait to do version checks until an official release is out *) +(* try + let vi = numeric_prefix_list v in + (* Temporary hack *) + if vi = ["3";"0";"beta3"] then (false, v) else + let vi = List.map s2i vi in + if vi < [3; 0; 0] then (false, v) - else if vi < [2; 18; 3] then - begin - (* Version 2.18.3 is known to report incorrectly as 2.18.0, and Launchpad packages report as version 2.16.0 due to a misconfigured META file; see https://bugs.launchpad.net/ubuntu/+source/lablgtk2/+bug/1577236 *) - warn "Your installed lablgtk reports as %s.\n\ -It is possible that the installed version is actually more recent\n\ -but reports an incorrect version. If the installed version is\n\ -actually more recent than 2.18.3, that's fine; if it is not,\n -CoqIDE will compile but may be very unstable." v; - (true, "an unknown version") - end else (true, v) with _ -> (false, v) +*) let pr_ide = function No -> "no" | Byte -> "only bytecode" | Opt -> "native" @@ -788,19 +744,19 @@ let lablgtkdir = ref "" let check_coqide () = if !prefs.coqide = Some No then set_ide No "CoqIde manually disabled"; let dir, via = get_lablgtkdir () in - if dir = "" then set_ide No "LablGtk2 not found"; - let (ok, version) = check_lablgtk_version via dir in - let found = sprintf "LablGtk2 found (%s, %s)" (get_source via) version in - if not ok then set_ide No (found^", but too old (required >= 2.18.3, found " ^ version ^ ")"); - (* We're now sure to produce at least one kind of coqide *) - lablgtkdir := shorten_camllib dir; - if !prefs.coqide = Some Byte then set_ide Byte (found^", bytecode requested"); - if best_compiler<>"opt" then set_ide Byte (found^", but no native compiler"); - if not (Sys.file_exists (dir/"gtkThread.cmx")) then - set_ide Byte (found^", but no native LablGtk2"); - if not (Sys.file_exists (camllib/"threads"/"threads.cmxa")) then - set_ide Byte (found^", but no native threads"); - set_ide Opt (found^", with native threads") + if dir = "" + then set_ide No "LablGtk3 not found" + else + let (ok, version) = check_lablgtk_version () in + let found = sprintf "LablGtk3 found (%s)" version in + if not ok then set_ide No (found^", but too old (required >= 3.0, found " ^ version ^ ")"); + (* We're now sure to produce at least one kind of coqide *) + lablgtkdir := shorten_camllib dir; + if !prefs.coqide = Some Byte then set_ide Byte (found^", bytecode requested"); + if best_compiler <> "opt" then set_ide Byte (found^", but no native compiler"); + if not (Sys.file_exists (camllib/"threads"/"threads.cmxa")) then + set_ide Byte (found^", but no native threads"); + set_ide Opt (found^", with native threads") let coqide = try check_coqide () @@ -808,19 +764,16 @@ let coqide = (** System-specific CoqIde flags *) -let lablgtkincludes = ref "" let idearchflags = ref "" let idearchfile = ref "" let idecdepsflags = ref "" let idearchdef = ref "X11" let coqide_flags () = - if !lablgtkdir <> "" then lablgtkincludes := sprintf "-I %S" !lablgtkdir; match coqide, arch with | "opt", "Darwin" when !prefs.macintegration -> let osxdir,_ = tryrun camlexec.find ["query";"lablgtkosx"] in if osxdir <> "" then begin - lablgtkincludes := sprintf "%s -I %S" !lablgtkincludes osxdir; idearchflags := "lablgtkosx.cma"; idearchdef := "QUARTZ" end @@ -1011,7 +964,7 @@ let print_summary () = if best_compiler = "opt" then pr " Native dynamic link support : %B\n" hasnatdynlink; if coqide <> "no" then - pr " Lablgtk2 library in : %s\n" (esc !lablgtkdir); + pr " Lablgtk3 library in : %s\n" (esc !lablgtkdir); if !idearchdef = "QUARTZ" then pr " Mac OS integration is on\n"; pr " CoqIde : %s\n" coqide; @@ -1203,7 +1156,6 @@ let write_makefile f = pr "# Unix systems and no profiling: strip\n"; pr "STRIP=%s\n\n" strip; pr "# LablGTK\n"; - pr "COQIDEINCLUDES=%s\n\n" !lablgtkincludes; pr "# CoqIde (no/byte/opt)\n"; pr "HASCOQIDE=%s\n" coqide; pr "IDEFLAGS=%s\n" !idearchflags; diff --git a/coqide.opam b/coqide.opam index 314943a881..c82fa72564 100644 --- a/coqide.opam +++ b/coqide.opam @@ -17,10 +17,10 @@ dev-repo: "git+https://github.com/coq/coq.git" license: "LGPL-2.1" depends: [ - "dune" { build & >= "1.4.0" } + "dune" { build & >= "1.4.0" } "coqide-server" - "conf-gtksourceview" - "lablgtk" { >= "2.18.5" } + "lablgtk3" { >= "3.0.beta5" } + "lablgtk3-sourceview3" { >= "3.0.beta5" } ] build-env: [ diff --git a/coqpp/coqpp_ast.mli b/coqpp/coqpp_ast.mli index 8e10ec49ce..81109887ba 100644 --- a/coqpp/coqpp_ast.mli +++ b/coqpp/coqpp_ast.mli @@ -103,6 +103,7 @@ type classification = type vernac_rule = { vernac_atts : (string * string) list option; + vernac_state: string option; vernac_toks : ext_token list; vernac_class : code option; vernac_depr : bool; diff --git a/coqpp/coqpp_lex.mll b/coqpp/coqpp_lex.mll index c38755943a..81ba8ad98c 100644 --- a/coqpp/coqpp_lex.mll +++ b/coqpp/coqpp_lex.mll @@ -130,6 +130,7 @@ rule extend = parse | space { extend lexbuf } | '\"' { string lexbuf } | '\n' { newline lexbuf; extend lexbuf } +| "![" { BANGBRACKET } | "#[" { HASHBRACKET } | '[' { LBRACKET } | ']' { RBRACKET } diff --git a/coqpp/coqpp_main.ml b/coqpp/coqpp_main.ml index cc76c44651..90158c3aa3 100644 --- a/coqpp/coqpp_main.ml +++ b/coqpp/coqpp_main.ml @@ -347,9 +347,18 @@ let print_atts_right fmt = function let nota = match atts with [_] -> "" | _ -> "Attributes.Notations." in fprintf fmt "(Attributes.parse %s%a atts)" nota aux atts +let print_body_wrapper fmt r = + match r.vernac_state with + | Some "proof" -> + fprintf fmt "let proof = (%a) ~pstate:st.Vernacstate.proof in { st with Vernacstate.proof }" print_code r.vernac_body + | None -> + fprintf fmt "let () = %a in st" print_code r.vernac_body + | Some x -> + fatal ("unsupported state specifier: " ^ x) + let print_body_fun fmt r = - fprintf fmt "let coqpp_body %a%a ~st = let () = %a in st in " - print_binders r.vernac_toks print_atts_left r.vernac_atts print_code r.vernac_body + fprintf fmt "let coqpp_body %a%a ~st = @[%a@] in " + print_binders r.vernac_toks print_atts_left r.vernac_atts print_body_wrapper r let print_body fmt r = fprintf fmt "@[(%afun %a~atts@ ~st@ -> coqpp_body %a%a ~st)@]" @@ -493,7 +502,7 @@ let print_ast fmt arg = let pr fmt () = fprintf fmt "Vernacextend.vernac_argument_extend ~name:%a @[{@\n\ Vernacextend.arg_parsing = %a;@\n\ - Vernacextend.arg_printer = %a;@\n}@]" + Vernacextend.arg_printer = fun env sigma -> %a;@\n}@]" print_string name print_rules (name, arg.vernacargext_rules) print_printer arg.vernacargext_printer in @@ -579,7 +588,7 @@ let print_ast fmt arg = Tacentries.arg_intern = @[%a@];@\n\ Tacentries.arg_subst = @[%a@];@\n\ Tacentries.arg_interp = @[%a@];@\n\ - Tacentries.arg_printer = @[((%a), (%a), (%a))@];@\n}@]" + Tacentries.arg_printer = @[((fun env sigma -> %a), (fun env sigma -> %a), (fun env sigma -> %a))@];@\n}@]" print_string name VernacArgumentExt.print_rules (name, arg.argext_rules) pr_tag arg.argext_type diff --git a/coqpp/coqpp_parse.mly b/coqpp/coqpp_parse.mly index abe52ab46b..43ba990f6a 100644 --- a/coqpp/coqpp_parse.mly +++ b/coqpp/coqpp_parse.mly @@ -65,7 +65,7 @@ let parse_user_entry s sep = %token VERNAC TACTIC GRAMMAR EXTEND END DECLARE PLUGIN DEPRECATED ARGUMENT %token RAW_PRINTED GLOB_PRINTED %token COMMAND CLASSIFIED PRINTED TYPED INTERPRETED GLOBALIZED SUBSTITUTED BY AS -%token HASHBRACKET LBRACKET RBRACKET PIPE ARROW FUN COMMA EQUAL STAR +%token BANGBRACKET HASHBRACKET LBRACKET RBRACKET PIPE ARROW FUN COMMA EQUAL STAR %token LPAREN RPAREN COLON SEMICOLON %token GLOBAL FIRST LAST BEFORE AFTER LEVEL LEFTA RIGHTA NONA %token EOF @@ -209,13 +209,14 @@ vernac_rules: ; vernac_rule: -| PIPE vernac_attributes_opt LBRACKET ext_tokens RBRACKET rule_deprecation rule_classifier ARROW CODE +| PIPE vernac_attributes_opt vernac_state_opt LBRACKET ext_tokens RBRACKET rule_deprecation rule_classifier ARROW CODE { { vernac_atts = $2; - vernac_toks = $4; - vernac_depr = $6; - vernac_class= $7; - vernac_body = $9; + vernac_state= $3; + vernac_toks = $5; + vernac_depr = $7; + vernac_class= $8; + vernac_body = $10; } } ; @@ -235,6 +236,14 @@ vernac_attribute: | qualid_or_ident { ($1, $1) } ; +vernac_state_opt: +| { None } +| BANGBRACKET vernac_state RBRACKET { Some $2 } +; + +vernac_state: +| qualid_or_ident { $1 } + rule_deprecation: | { false } | DEPRECATED { true } diff --git a/default.nix b/default.nix index 3290f5dee8..1e2cb3625d 100644 --- a/default.nix +++ b/default.nix @@ -21,11 +21,7 @@ # Once the build is finished, you will find, in the current directory, # a symlink to where Coq was installed. -{ pkgs ? - (import (fetchTarball { - url = "https://github.com/NixOS/nixpkgs/archive/11cf7d6e1ffd5fbc09a51b76d668ad0858a772ed.tar.gz"; - sha256 = "0zcg4mgfdk3ryiqj1j5iv5bljjvsgi6q6j9z1vkq383c4g4clc72"; - }) {}) +{ pkgs ? import ./dev/nixpkgs.nix {} , ocamlPackages ? pkgs.ocamlPackages , buildIde ? true , buildDoc ? true @@ -49,7 +45,10 @@ stdenv.mkDerivation rec { dune ] ++ (with ocamlPackages; [ ocaml findlib num ]) - ++ optional buildIde ocamlPackages.lablgtk + ++ optionals buildIde [ + ocamlPackages.lablgtk3-sourceview3 + glib gnome3.defaultIconTheme wrapGAppsHook + ] ++ optionals buildDoc [ # Sphinx doc dependencies pkgconfig (python3.withPackages @@ -83,6 +82,8 @@ stdenv.mkDerivation rec { prefixKey = "-prefix "; + enableParallelBuilding = true; + buildFlags = [ "world" "byte" ] ++ optional buildDoc "doc-html"; installTargets = diff --git a/dev/build/windows/MakeCoq_MinGW.bat b/dev/build/windows/MakeCoq_MinGW.bat index c8cfcf60c8..c3f3a97ff5 100755 --- a/dev/build/windows/MakeCoq_MinGW.bat +++ b/dev/build/windows/MakeCoq_MinGW.bat @@ -331,7 +331,7 @@ IF "%CYGWIN_QUIET%" == "Y" ( )
IF "%GTK_FROM_SOURCES%"=="N" (
- SET CYGWIN_OPT= %CYGWIN_OPT% -P mingw64-%ARCH%-gtk2.0,mingw64-%ARCH%-gtksourceview2.0
+ SET CYGWIN_OPT= %CYGWIN_OPT% -P mingw64-%ARCH%-gtk3,mingw64-%ARCH%-gtksourceview3.0
)
REM Cygwin setup sets proper ACLs (permissions) for folders it CREATES.
diff --git a/dev/build/windows/makecoq_mingw.sh b/dev/build/windows/makecoq_mingw.sh index 43f44a80b4..4c5bd29236 100755 --- a/dev/build/windows/makecoq_mingw.sh +++ b/dev/build/windows/makecoq_mingw.sh @@ -742,7 +742,7 @@ function make_fontconfig { ##### ICONV ##### function make_libiconv { - build_conf_make_inst http://ftp.gnu.org/pub/gnu/libiconv libiconv-1.14 tar.gz true + build_conf_make_inst http://ftp.gnu.org/pub/gnu/libiconv libiconv-1.15 tar.gz true } ##### UNISTRING ##### @@ -816,7 +816,9 @@ function make_glib { make_gettext make_libffi make_libpcre + build_conf_make_inst http://ftp.gnome.org/pub/gnome/sources/glib/2.57 glib-2.57.1 tar.xz true + } ##### ATK ##### @@ -824,7 +826,7 @@ function make_glib { function make_atk { make_gettext make_glib - build_conf_make_inst http://ftp.gnome.org/pub/gnome/sources/atk/2.29 atk-2.29.1 tar.xz true + build_conf_make_inst http://ftp.gnome.org/pub/gnome/sources/atk/2.30 atk-2.30.0 tar.xz true } ##### PIXBUF ##### @@ -837,7 +839,7 @@ function make_gdk-pixbuf { # CONFIGURE PARAMETERS # --with-included-loaders=yes statically links the image file format handlers # This avoids "Cannot open pixbuf loader module file '/usr/x86_64-w64-mingw32/sys-root/mingw/lib/gdk-pixbuf-2.0/2.10.0/loaders.cache': No such file or directory" - build_conf_make_inst http://ftp.gnome.org/pub/GNOME/sources/gdk-pixbuf/2.36 gdk-pixbuf-2.36.12 tar.xz true --with-included-loaders=yes + build_conf_make_inst http://ftp.gnome.org/pub/GNOME/sources/gdk-pixbuf/2.38 gdk-pixbuf-2.38.0 tar.xz true --with-included-loaders=yes } ##### CAIRO ##### @@ -848,7 +850,7 @@ function make_cairo { make_glib make_pixman make_fontconfig - build_conf_make_inst http://cairographics.org/releases rcairo-1.15.13 tar.xz true + build_conf_make_inst http://cairographics.org/releases rcairo-1.16.2 tar.xz true } ##### PANGO ##### @@ -857,37 +859,23 @@ function make_pango { make_cairo make_glib make_fontconfig - build_conf_make_inst http://ftp.gnome.org/pub/GNOME/sources/pango/1.42 pango-1.42.1 tar.xz true + build_conf_make_inst http://ftp.gnome.org/pub/GNOME/sources/pango/1.42 pango-1.42.4 tar.xz true } -##### GTK2 ##### +##### GTK3 ##### -function patch_gtk2 { - rm gtk/gtk.def -} +function make_gtk3 { -function make_gtk2 { - # Cygwin packet dependencies: gtk-update-icon-cache if [ "$GTK_FROM_SOURCES" == "Y" ]; then - make_glib - make_atk - make_pango - make_gdk-pixbuf - make_cairo - build_conf_make_inst http://ftp.gnome.org/pub/gnome/sources/gtk+/2.24 gtk+-2.24.32 tar.xz patch_gtk2 - fi -} - -##### GTK3 ##### -function make_gtk3 { - make_glib - make_atk - make_pango - make_gdk-pixbuf - make_cairo - make_libepoxy - build_conf_make_inst http://ftp.gnome.org/pub/gnome/sources/gtk+/3.22 gtk+-3.22.30 tar.xz true + make_glib + make_atk + make_pango + make_gdk-pixbuf + make_cairo + make_libepoxy + build_conf_make_inst http://ftp.gnome.org/pub/gnome/sources/gtk+/3.24 gtk+-3.24.5 tar.xz true + fi # make all incl. tests and examples runs through fine # make install fails with issue with @@ -918,17 +906,17 @@ function make_libxml2 { fi } -##### GTK-SOURCEVIEW2 ##### +##### GTK-SOURCEVIEW3 ##### -function make_gtk_sourceview2 { +function make_gtk_sourceview3 { # Cygwin packet dependencies: intltool # gtksourceview-2.11.2 requires GTK2 # gtksourceview-2.91.9 requires GTK3 # => We use gtksourceview-2.11.2 which seems to be the newest GTK2 based one if [ "$GTK_FROM_SOURCES" == "Y" ]; then - make_gtk2 + make_gtk3 make_libxml2 - build_conf_make_inst https://download.gnome.org/sources/gtksourceview/2.11 gtksourceview-2.11.2 tar.bz2 true + build_conf_make_inst https://download.gnome.org/sources/gtksourceview/3.24 gtksourceview-3.24.9 tar.bz2 true fi } @@ -977,7 +965,7 @@ function get_flex_dll_link_bin { # Build flexdll and flexlink from sources after building OCaml function make_flex_dll_link { - if build_prep https://github.com/alainfrisch/flexdll/releases/download/0.37/ flexdll-bin-0.37 zip ; then + if build_prep https://github.com/alainfrisch/flexdll/archive 0.37 tar.gz 1 flexdll-0.37 ; then if [ "$TARGET_ARCH" == "i686-w64-mingw32" ]; then # shellcheck disable=SC2086 log1 make $MAKE_OPT build_mingw flexlink.exe @@ -1014,11 +1002,21 @@ function make_ln { fi } +##### ARCH-pkg-config replacement ##### + +# cygwin replaced ARCH-pkg-config with a shell script, which doesn't work e.g. for dune on Windows. +# This builds a binary replacement for the shell script and puts it into the bin_special folder. +# There is no global installation since it is module specific what pkg-config is needed under what name. + +function make_arch_pkg_config { + gcc -DARCH="$TARGET_ARCH" -o bin_special/pkg-config.exe $PATCHES/pkg-config.c +} + ##### OCAML ##### function make_ocaml { get_flex_dll_link_bin - if build_prep https://github.com/ocaml/ocaml/archive 4.07.0 tar.gz 1 ocaml-4.07.0 ; then + if build_prep https://github.com/ocaml/ocaml/archive 4.07.1 tar.gz 1 ocaml-4.07.1 ; then # See README.win32.adoc cp config/m-nt.h byterun/caml/m.h cp config/s-nt.h byterun/caml/s.h @@ -1073,7 +1071,6 @@ function make_ocaml { function make_ocaml_tools { make_findlib - # make_camlp5 } ##### OCAML EXTRA LIBRARIES ##### @@ -1082,7 +1079,6 @@ function make_ocaml_libs { make_num make_findlib make_lablgtk - # make_stdint } ##### Ocaml num library ##### @@ -1130,6 +1126,20 @@ function make_findlib { fi } +##### Dune build system ##### + +function make_dune { + make_ocaml + + if build_prep https://github.com/ocaml/dune/archive/ 1.6.3 tar.gz 1 dune-1.6.3 ; then + + log2 make release + log2 make install + + build_post + fi +} + ##### MENHIR Ocaml Parser Generator ##### function make_menhir { @@ -1144,108 +1154,44 @@ function make_menhir { fi } -##### CAMLP4 Ocaml Preprocessor ##### - -function make_camlp4 { - # OCaml up to 4.01 includes camlp4, from 4.02 it isn't included - # Check if command camlp4 exists, if not build camlp4 - if ! command camlp4 ; then - make_ocaml - make_findlib - if build_prep https://github.com/ocaml/camlp4/archive 4.06+2 tar.gz 1 camlp4-4.06+2 ; then - # See https://github.com/ocaml/camlp4/issues/41#issuecomment-112018910 - logn configure ./configure - # Note: camlp4 doesn't support -j 8, so don't pass MAKE_OPT - log2 make all - log2 make install - log2 make clean - build_post - fi - fi -} - -##### CAMLP5 Ocaml Preprocessor ##### - -function make_camlp5 { - make_ocaml - make_findlib - - if build_prep https://github.com/camlp5/camlp5/archive rel706 tar.gz 1 camlp5-rel706; then - logn configure ./configure - # Somehow my virus scanner has the boot.new/SAVED directory locked after the move for a second => repeat until success - sed -i 's/mv boot.new boot/until mv boot.new boot; do sleep 1; done/' Makefile - # shellcheck disable=SC2086 - log1 make world.opt $MAKE_OPT - log2 make install - # For some reason gramlib.a is not copied, but it is required by Coq - cp lib/gramlib.a "$PREFIXOCAML/libocaml/camlp5/" - # For some reason META is not copied, but it is required by coq_makefile - log2 make -C etc META - mkdir -p "$PREFIXOCAML/libocaml/site-lib/camlp5/" - cp etc/META "$PREFIXOCAML/libocaml/site-lib/camlp5/" - log2 make clean - build_post - fi -} - ##### LABLGTK Ocaml GTK binding ##### # Note: when rebuilding lablgtk by deleting the .finished file, # also delete <root>\usr\x86_64-w64-mingw32\sys-root\mingw\lib\site-lib # Otherwise make install fails -function make_lablgtk { - make_ocaml - make_findlib - # make_camlp4 # required by lablgtk-2.18.3 and lablgtk-2.18.5 - make_gtk2 - make_gtk_sourceview2 - if build_prep https://forge.ocamlcore.org/frs/download.php/1726 lablgtk-2.18.6 tar.gz 1 ; then - # configure should be fixed to search for $TARGET_ARCH-pkg-config.exe - cp "/bin/$TARGET_ARCH-pkg-config" bin_special/pkg-config - logn configure ./configure --build="$BUILD" --host="$HOST" --target="$TARGET" --prefix="$PREFIXOCAML" - - # lablgtk shows occasional errors with -j, so don't pass $MAKE_OPT - - # lablgtk binary needs to be stripped - otherwise flexdll goes wild - # Fix version 1: explicit strip after failed build - this randomly fails in CI - # See https://sympa.inria.fr/sympa/arc/caml-list/2015-10/msg00204.html - # logn make-world-pre make world || true - # $TARGET_ARCH-strip.exe --strip-unneeded src/dlllablgtk2.dll - - # Fix version 2: Strip by passing linker argument rather than explicit call to strip - # See https://github.com/alainfrisch/flexdll/issues/6 - # Argument to ocamlmklib: -ldopt "-link -Wl,-s" - # -ldopt is the okamlmklib linker prefix option - # -link is the flexlink linker prefix option - # -Wl, is the gcc (linker driver) linker prefix option - # -s is the gnu linker option for stripping symbols - # These changes are included in dev/build/windows/patches_coq/lablgtk-2.18.3.patch - - log2 make world - - # lablgtk does not escape FINDLIBDIR path, which can contain backslashes - sed -i "s|^FINDLIBDIR=.*|FINDLIBDIR=$PREFIXOCAML/libocaml/site-lib|" config.make +function make_ocaml_cairo2 { + if build_prep https://github.com/Chris00/ocaml-cairo/archive 0.6 tar.gz 1 ocaml_cairo2-0.6; then + make_arch_pkg_config - log2 make install - log2 make clean + log2 dune build cairo2.install + log2 dune install cairo2 + log2 dune clean build_post + fi } -##### Ocaml Stdint ##### - -function make_stdint { +function make_lablgtk { make_ocaml make_findlib - if build_prep https://github.com/andrenth/ocaml-stdint/archive 0.3.0 tar.gz 1 Stdint-0.3.0; then - # Note: the setup gets the proper install path from ocamlfind, but for whatever reason it wants - # to create an empty folder in some folder which defaults to C:\Program Files. - # The --preifx overrides this. Id didn't see any files created in /tmp/extra. - log_1_3 ocaml setup.ml -configure --prefix /tmp/extra - log_1_3 ocaml setup.ml -build - log_1_3 ocaml setup.ml -install - log_1_3 ocaml setup.ml -clean + make_dune + make_gtk3 + make_gtk_sourceview3 + make_ocaml_cairo2 + + if build_prep https://github.com/garrigue/lablgtk/archive 3.0.beta5 tar.gz 1 lablgtk-3.0.beta5 ; then + make_arch_pkg_config + + # lablgtk3 includes more packages that are not relevant for Coq, + # such as gtkspell + log2 dune build -p lablgtk3 + log2 dune install lablgtk3 + + log2 dune build -p lablgtk3-sourceview3 + log2 dune install lablgtk3-sourceview3 + + log2 dune clean build_post fi } @@ -1270,42 +1216,44 @@ function copy_coq_dlls { # Select all missing DLLs from the module list, right click "copy filenames" # Delay loaded DLLs from Windows can be ignored (hour-glass icon at begin of line) # Do this recursively until there are no further missing DLLs (File close + reopen) - # For running this quickly, just do "cd coq-<ver> ; call copy_coq_dlls ; cd .." at the end of this script. + # For running this quickly, just do "cd coq-<ver> ; copy_coq_dlls ; cd .." at the end of this script. # Do the same for coqc and ocamlc (usually doesn't result in additional files) - copy_coq_dll LIBATK-1.0-0.DLL copy_coq_dll LIBCAIRO-2.DLL - copy_coq_dll LIBEXPAT-1.DLL - copy_coq_dll LIBFFI-6.DLL copy_coq_dll LIBFONTCONFIG-1.DLL copy_coq_dll LIBFREETYPE-6.DLL - copy_coq_dll LIBGDK-WIN32-2.0-0.DLL + copy_coq_dll LIBGDK-3-0.DLL copy_coq_dll LIBGDK_PIXBUF-2.0-0.DLL - copy_coq_dll LIBGIO-2.0-0.DLL copy_coq_dll LIBGLIB-2.0-0.DLL - copy_coq_dll LIBGMODULE-2.0-0.DLL copy_coq_dll LIBGOBJECT-2.0-0.DLL - copy_coq_dll LIBGTK-WIN32-2.0-0.DLL - copy_coq_dll LIBINTL-8.DLL + copy_coq_dll LIBGTK-3-0.DLL + copy_coq_dll LIBGTKSOURCEVIEW-3.0-1.DLL copy_coq_dll LIBPANGO-1.0-0.DLL + copy_coq_dll LIBATK-1.0-0.DLL + copy_coq_dll LIBBZ2-1.DLL + copy_coq_dll LIBCAIRO-GOBJECT-2.DLL + copy_coq_dll LIBEPOXY-0.DLL + copy_coq_dll LIBEXPAT-1.DLL + copy_coq_dll LIBFFI-6.DLL + copy_coq_dll LIBGIO-2.0-0.DLL + copy_coq_dll LIBGMODULE-2.0-0.DLL + copy_coq_dll LIBINTL-8.DLL copy_coq_dll LIBPANGOCAIRO-1.0-0.DLL copy_coq_dll LIBPANGOWIN32-1.0-0.DLL - copy_coq_dll libpcre-1.dll + copy_coq_dll LIBPCRE-1.DLL copy_coq_dll LIBPIXMAN-1-0.DLL copy_coq_dll LIBPNG16-16.DLL copy_coq_dll LIBXML2-2.DLL copy_coq_dll ZLIB1.DLL + copy_coq_dll ICONV.DLL + copy_coq_dll LIBLZMA-5.DLL + copy_coq_dll LIBPANGOFT2-1.0-0.DLL + copy_coq_dll LIBHARFBUZZ-0.DLL # Depends on if GTK is built from sources if [ "$GTK_FROM_SOURCES" == "Y" ]; then - copy_coq_dll libiconv-2.dll - else - copy_coq_dll ICONV.DLL - copy_coq_dll LIBBZ2-1.DLL - copy_coq_dll LIBGTKSOURCEVIEW-2.0-0.DLL - copy_coq_dll LIBHARFBUZZ-0.DLL - copy_coq_dll LIBLZMA-5.DLL - copy_coq_dll LIBPANGOFT2-1.0-0.DLL + echo "Building GTK from sources is currently not supported" + exit 1 fi; # Architecture dependent files @@ -1335,14 +1283,14 @@ function copy_coq_objects { # Copy required GTK config and suport files -function copq_coq_gtk { - echo 'gtk-theme-name = "MS-Windows"' > "$PREFIX/etc/gtk-2.0/gtkrc" - echo 'gtk-fallback-icon-theme = "Tango"' >> "$PREFIX/etc/gtk-2.0/gtkrc" +function copy_coq_gtk { + echo 'gtk-theme-name = "Default"' > "$PREFIX/etc/gtk-3.0/gtkrc" + echo 'gtk-fallback-icon-theme = "Tango"' >> "$PREFIX/etc/gtk-3.0/gtkrc" if [ "$INSTALLMODE" == "absolute" ] || [ "$INSTALLMODE" == "relocatable" ]; then - install_glob "$PREFIX/etc/gtk-2.0" '*' "$PREFIXCOQ/gtk-2.0" - install_glob "$PREFIX/share/gtksourceview-2.0/language-specs" '*' "$PREFIXCOQ/share/gtksourceview-2.0/language-specs" - install_glob "$PREFIX/share/gtksourceview-2.0/styles" '*' "$PREFIXCOQ/share/gtksourceview-2.0/styles" + install_glob "$PREFIX/etc/gtk-3.0" '*' "$PREFIXCOQ/gtk-3.0" + install_glob "$PREFIX/share/gtksourceview-3.0/language-specs" '*' "$PREFIXCOQ/share/gtksourceview-3.0/language-specs" + install_glob "$PREFIX/share/gtksourceview-3.0/styles" '*' "$PREFIXCOQ/share/gtksourceview-3.0/styles" install_rec "$PREFIX/share/themes" '*' "$PREFIXCOQ/share/themes" # This below item look like a bug in make install @@ -1351,10 +1299,7 @@ function copq_coq_gtk { else COQSHARE="$PREFIXCOQ/share/" fi - if [[ ! $COQ_VERSION == 8.4* ]] ; then - mv "$COQSHARE"*.lang "$PREFIXCOQ/share/gtksourceview-2.0/language-specs" - mv "$COQSHARE"*.xml "$PREFIXCOQ/share/gtksourceview-2.0/styles" - fi + mkdir -p "$PREFIXCOQ/ide" mv "$COQSHARE"*.png "$PREFIXCOQ/ide" rmdir "$PREFIXCOQ/share/coq" || true @@ -1383,7 +1328,6 @@ function make_coq { make_ocaml make_num make_findlib - # make_camlp5 make_lablgtk if case $COQ_VERSION in @@ -1437,11 +1381,12 @@ function make_coq { log2 make install log1 copy_coq_dlls + log1 copy_coq_gtk + if [ "$INSTALLOCAML" == "Y" ]; then copy_coq_objects fi - log1 copq_coq_gtk log1 copy_coq_license # make clean seems to be broken for 8.5pl2 diff --git a/dev/build/windows/patches_coq/VST.patch b/dev/build/windows/patches_coq/VST.patch index 2c8c46373f..2c8c46373f 100755..100644 --- a/dev/build/windows/patches_coq/VST.patch +++ b/dev/build/windows/patches_coq/VST.patch diff --git a/dev/build/windows/patches_coq/flexdll-0.37.patch b/dev/build/windows/patches_coq/flexdll-0.37.patch new file mode 100644 index 0000000000..82806f9ea4 --- /dev/null +++ b/dev/build/windows/patches_coq/flexdll-0.37.patch @@ -0,0 +1,19 @@ +diff/patch file created on Tue, Feb 19, 2019 9:41:26 PM with: +difftar-folder.sh tarballs/flexdll-0.37.tar.gz flexdll-0.37 1 +TARFILE= tarballs/flexdll-0.37.tar.gz +FOLDER= flexdll-0.37 +TARSTRIP= 1 +TARPREFIX= flexdll-0.37/ +ORIGFOLDER= flexdll-0.37.orig +--- flexdll-0.37.orig/cmdline.ml 2017-10-25 10:40:46.000000000 +0200 ++++ flexdll-0.37/cmdline.ml 2019-02-19 21:41:18.157024900 +0100 +@@ -248,6 +248,9 @@ + String.sub s 0 2 :: String.sub s 2 (String.length s - 2) :: tr rest + | s :: rest when String.length s >= 5 && String.sub s 0 5 = "/link" -> + "-link" :: String.sub s 5 (String.length s - 5) :: tr rest ++ (* Convert gcc linker option prefix -Wl, to flexlink linker prefix -link *) ++ | s :: rest when String.length s >= 6 && String.sub s 0 5 = "-Wl,-" -> ++ "-link" :: String.sub s 4 (String.length s - 4) :: tr rest + | "-arg" :: x :: rest -> + tr (Array.to_list (Arg.read_arg x)) @ rest + | "-arg0" :: x :: rest -> diff --git a/dev/build/windows/patches_coq/gtksourceview-2.11.2.patch b/dev/build/windows/patches_coq/gtksourceview-2.11.2.patch deleted file mode 100644 index 73a098d12a..0000000000 --- a/dev/build/windows/patches_coq/gtksourceview-2.11.2.patch +++ /dev/null @@ -1,213 +0,0 @@ -diff -c -r gtksourceview-2.11.2.orig/gtksourceview/gtksourceiter.c gtksourceview-2.11.2.patched/gtksourceview/gtksourceiter.c -*** gtksourceview-2.11.2.orig/gtksourceview/gtksourceiter.c 2010-05-30 12:24:14.000000000 +0200 ---- gtksourceview-2.11.2.patched/gtksourceview/gtksourceiter.c 2015-10-27 14:58:54.422888400 +0100 -*************** -*** 80,86 **** - /* If string contains prefix, check that prefix is not followed - * by a unicode mark symbol, e.g. that trailing 'a' in prefix - * is not part of two-char a-with-hat symbol in string. */ -! return type != G_UNICODE_COMBINING_MARK && - type != G_UNICODE_ENCLOSING_MARK && - type != G_UNICODE_NON_SPACING_MARK; - } ---- 80,86 ---- - /* If string contains prefix, check that prefix is not followed - * by a unicode mark symbol, e.g. that trailing 'a' in prefix - * is not part of two-char a-with-hat symbol in string. */ -! return type != G_UNICODE_SPACING_MARK && - type != G_UNICODE_ENCLOSING_MARK && - type != G_UNICODE_NON_SPACING_MARK; - } -diff -c -r gtksourceview-2.11.2.orig/gtksourceview/gtksourcelanguagemanager.c gtksourceview-2.11.2.patched/gtksourceview/gtksourcelanguagemanager.c -*** gtksourceview-2.11.2.orig/gtksourceview/gtksourcelanguagemanager.c 2010-05-30 12:24:14.000000000 +0200 ---- gtksourceview-2.11.2.patched/gtksourceview/gtksourcelanguagemanager.c 2015-10-27 14:55:30.294477600 +0100 -*************** -*** 274,280 **** - * containg a list of language files directories. - * The array is owned by @lm and must not be modified. - */ -! G_CONST_RETURN gchar* G_CONST_RETURN * - gtk_source_language_manager_get_search_path (GtkSourceLanguageManager *lm) - { - g_return_val_if_fail (GTK_IS_SOURCE_LANGUAGE_MANAGER (lm), NULL); ---- 274,280 ---- - * containg a list of language files directories. - * The array is owned by @lm and must not be modified. - */ -! const gchar* const * - gtk_source_language_manager_get_search_path (GtkSourceLanguageManager *lm) - { - g_return_val_if_fail (GTK_IS_SOURCE_LANGUAGE_MANAGER (lm), NULL); -*************** -*** 392,398 **** - * available languages or %NULL if no language is available. The array - * is owned by @lm and must not be modified. - */ -! G_CONST_RETURN gchar* G_CONST_RETURN * - gtk_source_language_manager_get_language_ids (GtkSourceLanguageManager *lm) - { - g_return_val_if_fail (GTK_IS_SOURCE_LANGUAGE_MANAGER (lm), NULL); ---- 392,398 ---- - * available languages or %NULL if no language is available. The array - * is owned by @lm and must not be modified. - */ -! const gchar* const * - gtk_source_language_manager_get_language_ids (GtkSourceLanguageManager *lm) - { - g_return_val_if_fail (GTK_IS_SOURCE_LANGUAGE_MANAGER (lm), NULL); -diff -c -r gtksourceview-2.11.2.orig/gtksourceview/gtksourcelanguagemanager.h gtksourceview-2.11.2.patched/gtksourceview/gtksourcelanguagemanager.h -*** gtksourceview-2.11.2.orig/gtksourceview/gtksourcelanguagemanager.h 2009-11-15 00:41:33.000000000 +0100 ---- gtksourceview-2.11.2.patched/gtksourceview/gtksourcelanguagemanager.h 2015-10-27 14:55:30.518500000 +0100 -*************** -*** 62,74 **** - - GtkSourceLanguageManager *gtk_source_language_manager_get_default (void); - -! G_CONST_RETURN gchar* G_CONST_RETURN * - gtk_source_language_manager_get_search_path (GtkSourceLanguageManager *lm); - - void gtk_source_language_manager_set_search_path (GtkSourceLanguageManager *lm, - gchar **dirs); - -! G_CONST_RETURN gchar* G_CONST_RETURN * - gtk_source_language_manager_get_language_ids (GtkSourceLanguageManager *lm); - - GtkSourceLanguage *gtk_source_language_manager_get_language (GtkSourceLanguageManager *lm, ---- 62,74 ---- - - GtkSourceLanguageManager *gtk_source_language_manager_get_default (void); - -! const gchar* const * - gtk_source_language_manager_get_search_path (GtkSourceLanguageManager *lm); - - void gtk_source_language_manager_set_search_path (GtkSourceLanguageManager *lm, - gchar **dirs); - -! const gchar* const * - gtk_source_language_manager_get_language_ids (GtkSourceLanguageManager *lm); - - GtkSourceLanguage *gtk_source_language_manager_get_language (GtkSourceLanguageManager *lm, -diff -c -r gtksourceview-2.11.2.orig/gtksourceview/gtksourcestylescheme.c gtksourceview-2.11.2.patched/gtksourceview/gtksourcestylescheme.c -*** gtksourceview-2.11.2.orig/gtksourceview/gtksourcestylescheme.c 2010-05-30 12:24:14.000000000 +0200 ---- gtksourceview-2.11.2.patched/gtksourceview/gtksourcestylescheme.c 2015-10-27 14:55:30.545502700 +0100 -*************** -*** 310,316 **** - * - * Since: 2.0 - */ -! G_CONST_RETURN gchar* G_CONST_RETURN * - gtk_source_style_scheme_get_authors (GtkSourceStyleScheme *scheme) - { - g_return_val_if_fail (GTK_IS_SOURCE_STYLE_SCHEME (scheme), NULL); ---- 310,316 ---- - * - * Since: 2.0 - */ -! const gchar* const * - gtk_source_style_scheme_get_authors (GtkSourceStyleScheme *scheme) - { - g_return_val_if_fail (GTK_IS_SOURCE_STYLE_SCHEME (scheme), NULL); -*************** -*** 318,324 **** - if (scheme->priv->authors == NULL) - return NULL; - -! return (G_CONST_RETURN gchar* G_CONST_RETURN *)scheme->priv->authors->pdata; - } - - /** ---- 318,324 ---- - if (scheme->priv->authors == NULL) - return NULL; - -! return (const gchar* const *)scheme->priv->authors->pdata; - } - - /** -diff -c -r gtksourceview-2.11.2.orig/gtksourceview/gtksourcestylescheme.h gtksourceview-2.11.2.patched/gtksourceview/gtksourcestylescheme.h -*** gtksourceview-2.11.2.orig/gtksourceview/gtksourcestylescheme.h 2010-03-29 15:02:56.000000000 +0200 ---- gtksourceview-2.11.2.patched/gtksourceview/gtksourcestylescheme.h 2015-10-27 14:55:30.565504700 +0100 -*************** -*** 61,67 **** - const gchar *gtk_source_style_scheme_get_name (GtkSourceStyleScheme *scheme); - const gchar *gtk_source_style_scheme_get_description(GtkSourceStyleScheme *scheme); - -! G_CONST_RETURN gchar* G_CONST_RETURN * - gtk_source_style_scheme_get_authors (GtkSourceStyleScheme *scheme); - - const gchar *gtk_source_style_scheme_get_filename (GtkSourceStyleScheme *scheme); ---- 61,67 ---- - const gchar *gtk_source_style_scheme_get_name (GtkSourceStyleScheme *scheme); - const gchar *gtk_source_style_scheme_get_description(GtkSourceStyleScheme *scheme); - -! const gchar* const * - gtk_source_style_scheme_get_authors (GtkSourceStyleScheme *scheme); - - const gchar *gtk_source_style_scheme_get_filename (GtkSourceStyleScheme *scheme); -diff -c -r gtksourceview-2.11.2.orig/gtksourceview/gtksourcestyleschememanager.c gtksourceview-2.11.2.patched/gtksourceview/gtksourcestyleschememanager.c -*** gtksourceview-2.11.2.orig/gtksourceview/gtksourcestyleschememanager.c 2010-05-30 12:24:14.000000000 +0200 ---- gtksourceview-2.11.2.patched/gtksourceview/gtksourcestyleschememanager.c 2015-10-27 14:55:30.583506500 +0100 -*************** -*** 515,521 **** - * of string containing the search path. - * The array is owned by the @manager and must not be modified. - */ -! G_CONST_RETURN gchar* G_CONST_RETURN * - gtk_source_style_scheme_manager_get_search_path (GtkSourceStyleSchemeManager *manager) - { - g_return_val_if_fail (GTK_IS_SOURCE_STYLE_SCHEME_MANAGER (manager), NULL); ---- 515,521 ---- - * of string containing the search path. - * The array is owned by the @manager and must not be modified. - */ -! const gchar* const * - gtk_source_style_scheme_manager_get_search_path (GtkSourceStyleSchemeManager *manager) - { - g_return_val_if_fail (GTK_IS_SOURCE_STYLE_SCHEME_MANAGER (manager), NULL); -*************** -*** 554,560 **** - * of string containing the ids of the available style schemes or %NULL if no - * style scheme is available. The array is owned by the @manager and must not be modified. - */ -! G_CONST_RETURN gchar* G_CONST_RETURN * - gtk_source_style_scheme_manager_get_scheme_ids (GtkSourceStyleSchemeManager *manager) - { - g_return_val_if_fail (GTK_IS_SOURCE_STYLE_SCHEME_MANAGER (manager), NULL); ---- 554,560 ---- - * of string containing the ids of the available style schemes or %NULL if no - * style scheme is available. The array is owned by the @manager and must not be modified. - */ -! const gchar* const * - gtk_source_style_scheme_manager_get_scheme_ids (GtkSourceStyleSchemeManager *manager) - { - g_return_val_if_fail (GTK_IS_SOURCE_STYLE_SCHEME_MANAGER (manager), NULL); -diff -c -r gtksourceview-2.11.2.orig/gtksourceview/gtksourcestyleschememanager.h gtksourceview-2.11.2.patched/gtksourceview/gtksourcestyleschememanager.h -*** gtksourceview-2.11.2.orig/gtksourceview/gtksourcestyleschememanager.h 2009-11-15 00:41:33.000000000 +0100 ---- gtksourceview-2.11.2.patched/gtksourceview/gtksourcestyleschememanager.h 2015-10-27 14:56:24.498897500 +0100 -*************** -*** 73,84 **** - void gtk_source_style_scheme_manager_prepend_search_path (GtkSourceStyleSchemeManager *manager, - const gchar *path); - -! G_CONST_RETURN gchar* G_CONST_RETURN * - gtk_source_style_scheme_manager_get_search_path (GtkSourceStyleSchemeManager *manager); - - void gtk_source_style_scheme_manager_force_rescan (GtkSourceStyleSchemeManager *manager); - -! G_CONST_RETURN gchar* G_CONST_RETURN * - gtk_source_style_scheme_manager_get_scheme_ids (GtkSourceStyleSchemeManager *manager); - - GtkSourceStyleScheme *gtk_source_style_scheme_manager_get_scheme (GtkSourceStyleSchemeManager *manager, ---- 73,84 ---- - void gtk_source_style_scheme_manager_prepend_search_path (GtkSourceStyleSchemeManager *manager, - const gchar *path); - -! const gchar* const * - gtk_source_style_scheme_manager_get_search_path (GtkSourceStyleSchemeManager *manager); - - void gtk_source_style_scheme_manager_force_rescan (GtkSourceStyleSchemeManager *manager); - -! const gchar* const * - gtk_source_style_scheme_manager_get_scheme_ids (GtkSourceStyleSchemeManager *manager); - - GtkSourceStyleScheme *gtk_source_style_scheme_manager_get_scheme (GtkSourceStyleSchemeManager *manager, diff --git a/dev/build/windows/patches_coq/lablgtk-2.18.6.patch b/dev/build/windows/patches_coq/lablgtk-3.0.beta5.patch index 23c303135d..1c6a038da9 100644 --- a/dev/build/windows/patches_coq/lablgtk-2.18.6.patch +++ b/dev/build/windows/patches_coq/lablgtk-3.0.beta5.patch @@ -1,33 +1,12 @@ -diff/patch file created on Wed, Apr 25, 2018 11:08:05 AM with: -difftar-folder.sh ../coq-msoegtrop/dev/build/windows/source_cache/lablgtk-2.18.3.tar.gz lablgtk-2.18.3 1 -TARFILE= ../coq-msoegtrop/dev/build/windows/source_cache/lablgtk-2.18.3.tar.gz -FOLDER= lablgtk-2.18.3 +diff/patch file created on Wed, Feb 20, 2019 11:29:48 AM with: +difftar-folder.sh tarballs/lablgtk-3.0.beta4.tar.gz lablgtk-3.0.beta4 1 +TARFILE= tarballs/lablgtk-3.0.beta4.tar.gz +FOLDER= lablgtk-3.0.beta4 TARSTRIP= 1 -TARPREFIX= lablgtk-2.18.3/ -ORIGFOLDER= lablgtk-2.18.3.orig ---- lablgtk-2.18.3.orig/configure 2014-10-29 08:51:05.000000000 +0100 -+++ lablgtk-2.18.3/configure 2018-04-25 10:58:54.454501600 +0200 -@@ -2667,7 +2667,7 @@ - fi - - --if test "`$OCAMLFIND printconf stdlib`" != "`$CAMLC -where`"; then -+if test "`$OCAMLFIND printconf stdlib | tr '\\' '/'`" != "`$CAMLC -where | tr '\\' '/'`"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Ignoring ocamlfind" >&5 - $as_echo "$as_me: WARNING: Ignoring ocamlfind" >&2;} - OCAMLFIND=no ---- lablgtk-2.18.3.orig/src/glib.mli 2014-10-29 08:51:06.000000000 +0100 -+++ lablgtk-2.18.3/src/glib.mli 2018-04-25 10:58:54.493555500 +0200 -@@ -75,6 +75,7 @@ - type condition = [ `ERR | `HUP | `IN | `NVAL | `OUT | `PRI] - type id - val channel_of_descr : Unix.file_descr -> channel -+ val channel_of_descr_socket : Unix.file_descr -> channel - val add_watch : - cond:condition list -> callback:(condition list -> bool) -> ?prio:int -> channel -> id - val remove : id -> unit ---- lablgtk-2.18.3.orig/src/glib.ml 2014-10-29 08:51:06.000000000 +0100 -+++ lablgtk-2.18.3/src/glib.ml 2018-04-25 10:58:54.479543500 +0200 +TARPREFIX= lablgtk-3.0.beta4/ +ORIGFOLDER= lablgtk-3.0.beta4.orig +--- lablgtk-3.0.beta4.orig/src/glib.ml 2019-02-11 07:08:17.000000000 +0100 ++++ lablgtk-3.0.beta4/src/glib.ml 2019-02-20 11:28:28.439137100 +0100 @@ -72,6 +72,8 @@ type id external channel_of_descr : Unix.file_descr -> channel @@ -37,22 +16,18 @@ ORIGFOLDER= lablgtk-2.18.3.orig external remove : id -> unit = "ml_g_source_remove" external add_watch : cond:condition list -> callback:(condition list -> bool) -> ?prio:int -> channel -> id ---- lablgtk-2.18.3.orig/src/Makefile 2014-10-29 08:51:06.000000000 +0100 -+++ lablgtk-2.18.3/src/Makefile 2018-04-25 10:58:54.506522500 +0200 -@@ -461,9 +461,9 @@ - do rm -f "$(BINDIR)"/$$f; done - - lablgtk.cma liblablgtk2$(XA): $(COBJS) $(MLOBJS) -- $(LIBRARIAN) -o lablgtk -oc lablgtk2 $^ $(GTKLIBS) -+ $(LIBRARIAN) -ldopt "-link -Wl,-s" -o lablgtk -oc lablgtk2 $^ $(GTKLIBS) - lablgtk.cmxa: $(COBJS) $(MLOBJS:.cmo=.cmx) -- $(LIBRARIAN) -o lablgtk -oc lablgtk2 $^ $(GTKLIBS) -+ $(LIBRARIAN) -ldopt "-link -Wl,-s" -o lablgtk -oc lablgtk2 $^ $(GTKLIBS) - lablgtk.cmxs: DYNLINKLIBS=$(GTK_LIBS) - - lablgtkgl.cma liblablgtkgl2$(XA): $(GLCOBJS) $(GLMLOBJS) ---- lablgtk-2.18.3.orig/src/ml_glib.c 2014-10-29 08:51:06.000000000 +0100 -+++ lablgtk-2.18.3/src/ml_glib.c 2018-04-25 10:58:54.539535600 +0200 +--- lablgtk-3.0.beta4.orig/src/glib.mli 2019-02-11 07:08:17.000000000 +0100 ++++ lablgtk-3.0.beta4/src/glib.mli 2019-02-20 11:28:28.423592200 +0100 +@@ -75,6 +75,7 @@ + type condition = [ `ERR | `HUP | `IN | `NVAL | `OUT | `PRI] + type id + val channel_of_descr : Unix.file_descr -> channel ++ val channel_of_descr_socket : Unix.file_descr -> channel + val add_watch : + cond:condition list -> callback:(condition list -> bool) -> ?prio:int -> channel -> id + val remove : id -> unit +--- lablgtk-3.0.beta4.orig/src/ml_glib.c 2019-02-11 07:08:17.000000000 +0100 ++++ lablgtk-3.0.beta4/src/ml_glib.c 2019-02-20 11:28:28.455395900 +0100 @@ -25,6 +25,8 @@ #include <string.h> #include <locale.h> @@ -74,7 +49,7 @@ ORIGFOLDER= lablgtk-2.18.3.orig #include "wrappers.h" #include "ml_glib.h" #include "glib_tags.h" -@@ -325,14 +332,23 @@ +@@ -326,14 +333,23 @@ #ifndef _WIN32 ML_1 (g_io_channel_unix_new, Int_val, Val_GIOChannel_noref) diff --git a/dev/build/windows/patches_coq/pkg-config.c b/dev/build/windows/patches_coq/pkg-config.c new file mode 100755 index 0000000000..e4fdcd4d7d --- /dev/null +++ b/dev/build/windows/patches_coq/pkg-config.c @@ -0,0 +1,29 @@ +// MinGW personality wrapper for pkgconf +// This is an excutable replacement for the shell scripts /bin/ARCH-pkg-config +// Compile with e.g. +// gcc pkg-config.c -DARCH=x86_64-w64-mingw32 -o pkg-config.exe +// gcc pkg-config.c -DARCH=i686-w64-mingw32 -o pkg-config.exe +// ATTENTION: Do not compile with MinGW-gcc, compile with cygwin gcc! +// +// To test it execute e.g. +// $ ./pkg-config --path zlib +// /usr/x86_64-w64-mingw32/sys-root/mingw/lib/pkgconfig/zlib.pc + +#include <unistd.h> + +#define STRINGIFY1(arg) #arg +#define STRINGIFY(arg) STRINGIFY1(arg) + +int main(int argc, char *argv[]) +{ + // +1 for extra argument, +1 for trailing NULL + char * argvnew[argc+2]; + int id=0, is=0; + + argvnew[id++] = argv[is++]; + argvnew[id++] = "--personality="STRINGIFY(ARCH); + while( is<argc ) argvnew[id++] = argv[is++]; + argvnew[id++] = 0; + + return execv("/usr/bin/pkgconf", argvnew); +} diff --git a/dev/build/windows/patches_coq/quickchick.patch b/dev/build/windows/patches_coq/quickchick.patch index 1afa6e7f95..1afa6e7f95 100755..100644 --- a/dev/build/windows/patches_coq/quickchick.patch +++ b/dev/build/windows/patches_coq/quickchick.patch diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index deeec3942d..62335ea5d0 100755 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -24,9 +24,9 @@ ######################################################################## # UniMath ######################################################################## -: "${UniMath_CI_REF:=master}" -: "${UniMath_CI_GITURL:=https://github.com/UniMath/UniMath}" -: "${UniMath_CI_ARCHIVEURL:=${UniMath_CI_GITURL}/archive}" +: "${unimath_CI_REF:=master}" +: "${unimath_CI_GITURL:=https://github.com/UniMath/UniMath}" +: "${unimath_CI_ARCHIVEURL:=${unimath_CI_GITURL}/archive}" ######################################################################## # Unicoq + Mtac2 diff --git a/dev/ci/ci-unimath.sh b/dev/ci/ci-unimath.sh index a7644fee23..704e278a4b 100755 --- a/dev/ci/ci-unimath.sh +++ b/dev/ci/ci-unimath.sh @@ -3,6 +3,6 @@ ci_dir="$(dirname "$0")" . "${ci_dir}/ci-common.sh" -git_download UniMath +git_download unimath -( cd "${CI_BUILD_DIR}/UniMath" && make BUILD_COQ=no ) +( cd "${CI_BUILD_DIR}/unimath" && make BUILD_COQ=no ) diff --git a/dev/ci/docker/bionic_coq/Dockerfile b/dev/ci/docker/bionic_coq/Dockerfile index ac763547b6..e553cbed1b 100644 --- a/dev/ci/docker/bionic_coq/Dockerfile +++ b/dev/ci/docker/bionic_coq/Dockerfile @@ -1,4 +1,4 @@ -# CACHEKEY: "bionic_coq-V2019-03-11-V1" +# CACHEKEY: "bionic_coq-V2019-03-12-V1" # ^^ Update when modifying this file. FROM ubuntu:bionic @@ -10,7 +10,7 @@ RUN apt-get update -qq && apt-get install --no-install-recommends -y -qq \ # Dependencies of the image, the test-suite and external projects m4 automake autoconf time wget rsync git gcc-multilib build-essential unzip \ # Dependencies of lablgtk (for CoqIDE) - libgtk2.0-dev libgtksourceview2.0-dev \ + libgtksourceview-3.0-dev \ # Dependencies of stdlib and sphinx doc texlive-latex-extra texlive-fonts-recommended texlive-xetex latexmk \ xindy python3-pip python3-setuptools python3-pexpect python3-bs4 \ @@ -22,7 +22,7 @@ RUN pip3 install sphinx==1.7.8 sphinx_rtd_theme==0.2.5b2 \ antlr4-python3-runtime==4.7.1 sphinxcontrib-bibtex==0.4.0 # We need to install OPAM 2.0 manually for now. -RUN wget https://github.com/ocaml/opam/releases/download/2.0.0/opam-2.0.0-x86_64-linux -O /usr/bin/opam && chmod 755 /usr/bin/opam +RUN wget https://github.com/ocaml/opam/releases/download/2.0.3/opam-2.0.3-x86_64-linux -O /usr/bin/opam && chmod 755 /usr/bin/opam # Basic OPAM setup ENV NJOBS="2" \ @@ -41,7 +41,10 @@ ENV BASE_OPAM="num ocamlfind.1.8.0 dune.1.6.2 ounit.2.0.8 odoc.1.4.0" \ CI_OPAM="menhir.20181113 elpi.1.1.0 ocamlgraph.1.8.8" # BASE switch; CI_OPAM contains Coq's CI dependencies. -ENV COQIDE_OPAM="lablgtk.2.18.5 conf-gtksourceview.2" +ENV COQIDE_OPAM="cairo2.0.6 lablgtk3-sourceview3.3.0.beta5" + +# Must add this to COQIDE_OPAM{,_EDGE} when we update the opam +# packages "lablgtk3-gtksourceview3" # base switch RUN opam init -a --disable-sandboxing --compiler="$COMPILER" default https://opam.ocaml.org && eval $(opam env) && opam update && \ @@ -53,7 +56,7 @@ RUN opam switch create "${COMPILER}+32bit" && eval $(opam env) && \ # EDGE switch ENV COMPILER_EDGE="4.07.1" \ - COQIDE_OPAM_EDGE="lablgtk.2.18.6 conf-gtksourceview.2" \ + COQIDE_OPAM_EDGE="cairo2.0.6 lablgtk3-sourceview3.3.0.beta5" \ BASE_OPAM_EDGE="dune-release.1.1.0" # EDGE+flambda switch, we install CI_OPAM as to be able to use diff --git a/dev/ci/nix/coq.nix b/dev/ci/nix/coq.nix index ecd280e58d..b610790f61 100644 --- a/dev/ci/nix/coq.nix +++ b/dev/ci/nix/coq.nix @@ -5,5 +5,4 @@ let coq = callPackage wd { buildDoc = false; doInstallCheck = false; coq-version coq.overrideAttrs (o: { name = "coq-local-${branch}"; src = fetchGit "${wd}"; - enableParallelBuilding = true; }) diff --git a/dev/ci/nix/default.nix b/dev/ci/nix/default.nix index 94e0a666e2..17070e66ee 100644 --- a/dev/ci/nix/default.nix +++ b/dev/ci/nix/default.nix @@ -1,4 +1,4 @@ -{ pkgs ? import <nixpkgs> {} +{ pkgs ? import ../../nixpkgs.nix {} , branch , wd , project ? "xyz" @@ -20,8 +20,17 @@ let mathcomp = coqPackages.mathcomp.overrideAttrs (o: { let ssreflect = coqPackages.ssreflect.overrideAttrs (o: { inherit (mathcomp) src; }); in -let coq-ext-lib = coqPackages.coq-ext-lib; in -let simple-io = coqPackages.simple-io; in + +let coq-ext-lib = coqPackages.coq-ext-lib.overrideAttrs (o: { + src = fetchTarball "https://github.com/coq-ext-lib/coq-ext-lib/tarball/master"; + }); in + +let simple-io = + (coqPackages.simple-io.override { inherit coq-ext-lib; }) + .overrideAttrs (o: { + src = fetchTarball "https://github.com/Lysxia/coq-simple-io/tarball/master"; + }); in + let bignums = coqPackages.bignums.overrideAttrs (o: if bn == "release" then {} else if bn == "master" then { src = fetchTarball https://github.com/coq/bignums/archive/master.tar.gz; } else diff --git a/dev/ci/nix/quickchick.nix b/dev/ci/nix/quickchick.nix index 46bf02ae3c..b90f1e4f88 100644 --- a/dev/ci/nix/quickchick.nix +++ b/dev/ci/nix/quickchick.nix @@ -1,5 +1,5 @@ { ocamlPackages, ssreflect, coq-ext-lib, simple-io }: { buildInputs = with ocamlPackages; [ ocaml findlib ocamlbuild num ]; - coqBuildInputs = [ ssreflect coq-ext-lib simple-io ]; + coqBuildInputs = [ ssreflect simple-io ]; } diff --git a/dev/ci/user-overlays/09129-ejgallego-proof+no_global_partial.sh b/dev/ci/user-overlays/09129-ejgallego-proof+no_global_partial.sh new file mode 100644 index 0000000000..c09d1b8929 --- /dev/null +++ b/dev/ci/user-overlays/09129-ejgallego-proof+no_global_partial.sh @@ -0,0 +1,30 @@ +if [ "$CI_PULL_REQUEST" = "9129" ] || [ "$CI_BRANCH" = "proof+no_global_partial" ]; then + + aac_tactics_CI_REF=proof+no_global_partial + aac_tactics_CI_GITURL=https://github.com/ejgallego/aac-tactics + + # coqhammer_CI_REF=proof+no_global_partial + # coqhammer_CI_GITURL=https://github.com/ejgallego/coqhammer + + elpi_CI_REF=proof+no_global_partial + elpi_CI_GITURL=https://github.com/ejgallego/coq-elpi + + equations_CI_REF=proof+no_global_partial + equations_CI_GITURL=https://github.com/ejgallego/Coq-Equations + + ltac2_CI_REF=proof+no_global_partial + ltac2_CI_GITURL=https://github.com/ejgallego/ltac2 + + # unicoq_CI_REF=proof+no_global_partial + # unicoq_CI_GITURL=https://github.com/ejgallego/unicoq + + mtac2_CI_REF=proof+no_global_partial + mtac2_CI_GITURL=https://github.com/ejgallego/Mtac2 + + paramcoq_CI_REF=proof+no_global_partial + paramcoq_CI_GITURL=https://github.com/ejgallego/paramcoq + + quickchick_CI_REF=proof+no_global_partial + quickchick_CI_GITURL=https://github.com/ejgallego/QuickChick + +fi diff --git a/dev/ci/user-overlays/09602-gares-more-delta-in-termination-checking.sh b/dev/ci/user-overlays/09602-gares-more-delta-in-termination-checking.sh new file mode 100644 index 0000000000..18a295cdbb --- /dev/null +++ b/dev/ci/user-overlays/09602-gares-more-delta-in-termination-checking.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "9602" ] || [ "$CI_BRANCH" = "more-delta-in-termination-checking" ]; then + + equations_CI_REF=more-delta-in-termination-checking + equations_CI_GITURL=https://github.com/gares/Coq-Equations + +fi diff --git a/dev/ci/user-overlays/09678-printed-by-env.sh b/dev/ci/user-overlays/09678-printed-by-env.sh new file mode 100644 index 0000000000..ccb3498764 --- /dev/null +++ b/dev/ci/user-overlays/09678-printed-by-env.sh @@ -0,0 +1,14 @@ + +if [ "$CI_PULL_REQUEST" = "9678" ] || [ "$CI_BRANCH" = "printed-by-env" ]; then + elpi_CI_REF=printed-by-env + elpi_CI_GITURL=https://github.com/maximedenes/coq-elpi + + equations_CI_REF=printed-by-env + equations_CI_GITURL=https://github.com/maximedenes/Coq-Equations + + ltac2_CI_REF=printed-by-env + ltac2_CI_GITURL=https://github.com/maximedenes/ltac2 + + quickchick_CI_REF=printed-by-env + quickchick_CI_GITURL=https://github.com/maximedenes/QuickChick +fi diff --git a/dev/doc/COMPATIBILITY b/dev/doc/archive/COMPATIBILITY index a81afca32d..a81afca32d 100644 --- a/dev/doc/COMPATIBILITY +++ b/dev/doc/archive/COMPATIBILITY diff --git a/dev/doc/extensions.txt b/dev/doc/archive/extensions.txt index 075496db7c..36d63029f1 100644 --- a/dev/doc/extensions.txt +++ b/dev/doc/archive/extensions.txt @@ -16,4 +16,3 @@ Exemple de l'ajout de l'entrée "clause": faut rejouter clause dans le GLOBAL du GEXTEND - seulement après, le nom clause sera accessible dans les TACTIC EXTEND ! - diff --git a/dev/doc/naming-conventions.tex b/dev/doc/archive/naming-conventions.tex index 337b9226df..0b0811d81b 100644 --- a/dev/doc/naming-conventions.tex +++ b/dev/doc/archive/naming-conventions.tex @@ -133,7 +133,7 @@ has name \texttt{D\_integral}, then \end{quote} will have name \texttt{D\_integral\_inf}. -As an exception, decidability statements, such as +As an exception, decidability statements, such as \begin{quote} \begin{tt} {forall x y, \{x = y\} + \{x <> y\}} @@ -284,7 +284,7 @@ If the conclusion is in the other way than listed below, add suffix \itemrule{Nilpotency of element elt wrt a ring D with additive neutral element {\zero} and multiplicative binary operator -{\op}}{Delt\_nilpotent} +{\op}}{Delt\_nilpotent} {op elt elt = zero} Remark: We leave the ring structure of D implicit; the general definition is ``exists n, iter n op elt = zero''. @@ -487,7 +487,7 @@ binary relation {\rel}}{phi\_op\_rel, phi\_op\_rel\_morphism} {forall x y:D, phi (op x y) <-> rel (phi x) (phi y)} Remark: If the operator and the relation have similar name, one uses -\texttt{phi\_op}. +\texttt{phi\_op}. Question: How to name each direction? (add \_elim for -> and \_intro for <- ?? -- as done in Bool.v ??) diff --git a/dev/doc/newsyntax.tex b/dev/doc/archive/newsyntax.tex index d1986fa0d1..71e964bcc9 100644 --- a/dev/doc/newsyntax.tex +++ b/dev/doc/archive/newsyntax.tex @@ -50,7 +50,7 @@ La réflexion de la rénovation de la syntaxe des tactiques n'est pas encore aussi poussée que pour les termes (section~\ref{constrsyntax}), mais cette section vise à énoncer les quelques principes que l'on -souhaite suivre. +souhaite suivre. \begin{itemize} \item Réutiliser les mots-clés de la syntaxe des termes (i.e. en @@ -612,7 +612,7 @@ Fixpoint plus n m : nat {struct n} := \subsection{Questions ouvertes} Voici les points sur lesquels la discussion est particulièrement -ouverte: +ouverte: \begin{itemize} \item choix d'autres symboles pour les quantificateurs \TERM{!} et \TERM{?}. En l'état actuel des discussions, on garderait le \TERM{!} diff --git a/dev/doc/notes-on-conversion.v b/dev/doc/archive/notes-on-conversion.v index a81f170c63..a78ecd181a 100644 --- a/dev/doc/notes-on-conversion.v +++ b/dev/doc/archive/notes-on-conversion.v @@ -69,5 +69,3 @@ it is not convertible. The only hope to improve this problem is to observe that S' hides (behind two indirections) a Setoid constructor. This could be the argument to solve the problem. - - diff --git a/dev/doc/old_svn_branches.txt b/dev/doc/archive/old_svn_branches.txt index ee56ee24e9..ee56ee24e9 100644 --- a/dev/doc/old_svn_branches.txt +++ b/dev/doc/archive/old_svn_branches.txt diff --git a/dev/doc/perf-analysis b/dev/doc/archive/perf-analysis index ac54fa6f73..ac54fa6f73 100644 --- a/dev/doc/perf-analysis +++ b/dev/doc/archive/perf-analysis diff --git a/dev/doc/versions-history.tex b/dev/doc/archive/versions-history.tex index 1c4913d201..25dabad497 100644 --- a/dev/doc/versions-history.tex +++ b/dev/doc/archive/versions-history.tex @@ -135,7 +135,7 @@ Coq V5.8.3& released 6 December 1993 % Announce on coq-club & & 3 branches: Lyon (V5.8.x), Ulm (V5.10.x) and Rocq (V5.9)\\ -Coq V5.9 alpha& 7 July 1993 & +Coq V5.9 alpha& 7 July 1993 & experimental version based on evars refinement \\ & & (merge from experimental ``V6.0'' and some pre-V5.8.3 \\ & & version), not released\\ @@ -159,7 +159,7 @@ Coq V5.9 & 27 January 1993 & experimental version based on evars refinement\\ \begin{tabular}{l|l|l} version & date & comments \\ \hline -Coq V5.10 ``Murthy'' & 22 January 1994 & +Coq V5.10 ``Murthy'' & 22 January 1994 & introduction of the ``DOPN'' structure\\ & & \feature{eapply/prolog} tactics\\ & & private use of cvs on madiran.inria.fr\\ @@ -179,7 +179,7 @@ Coq Lyon's archive & in 1994 & cvs server set up on woodstock.ens-lyon.fr\\ Coq V5.10.9& announced on 17 August 1994 & % Announced by Catherine Parent on coqdev - % Version avec une copie de THEORIES pour les inductifs mutuels + % Version avec une copie de THEORIES pour les inductifs mutuels \\ Coq V5.10.11& announced on 2 February 1995 & \feature{compute}\\ @@ -192,7 +192,7 @@ Coq V5.10.13& dated 9 June 1995 & on Lyon's cvs\\ Coq V5.10.14.OO& dated 30 June 1995 & on Lyon's cvs\\ -Coq V5.10.14.a& announced 5 September 1995 & bug-fix release \\ % Announce on coq-club by BW +Coq V5.10.14.a& announced 5 September 1995 & bug-fix release \\ % Announce on coq-club by BW Coq V5.10.14.b& released 2 October 1995 & bug-fix release\\ & & MS-DOS version released on 30 October 1995\\ @@ -203,7 +203,7 @@ Coq V5.10.14.b& released 2 October 1995 & bug-fix release\\ Coq V5.10.15 & released 20 February 1996 & \feature{Logic, Sorting, new Sets and Relations libraries} \\ % Announce on coq-club by BW - % dated 15 February 1996 and bound to pauillac's cvs in /net/pauillac/constr archive + % dated 15 February 1996 and bound to pauillac's cvs in /net/pauillac/constr archive & & MacOS 7-9 version released on 1 March 1996 \\ % Announce on coq-club by BW Coq V5.11 & dated 1 March 1996 & not released, not in pauillac's CVS, \feature{eauto} \\ @@ -434,7 +434,7 @@ evars-based experimentation \\ & & to Coq V5.7, version from October/November 1992\\ -CtCoq & released 25 October 1995 & first beta-version \\ % Announce on coq-club by Janet +CtCoq & released 25 October 1995 & first beta-version \\ % Announce on coq-club by Janet Proto with explicit substitutions & 1997 &\\ diff --git a/dev/doc/changes.md b/dev/doc/changes.md index d515ec30e8..416253fad1 100644 --- a/dev/doc/changes.md +++ b/dev/doc/changes.md @@ -54,6 +54,15 @@ Macros: where `atts : Vernacexpr.vernac_flags` was bound in the expression and had to be manually parsed. +- `PRINTED BY` now binds `env` and `sigma`, and expects printers which take + as parameters term printers parametrized by an environment and an `evar_map`. + +Printers + +- `Ppconstr.pr_constr_expr`, `Ppconstr.lconstr_expr`, + `Ppconstr.pr_constr_pattern_expr` and `Ppconstr.pr_lconstr_pattern_expr` + now all take an environment and an `evar_map`. + Libobject - A Higher-level API for objects with fixed scope was introduced. It supports the following kinds of objects: diff --git a/dev/doc/critical-bugs b/dev/doc/critical-bugs index 8d78559c0d..c0a5b9095c 100644 --- a/dev/doc/critical-bugs +++ b/dev/doc/critical-bugs @@ -63,8 +63,8 @@ Typing constructions impacted coqchk versions: ? fixed in: master/trunk (679801, r13450, 23 Sep 2010, Glondu), v8.3 (309a53f2, r13449, 22 Sep 2010, Glondu), v8.2 (41ea5f08, r14263, 6 Jul 2011, Herbelin, backport) found by: Georgi Guninski - exploit: test-suite/bugs/closed/4294.v - GH issue number: #4294 + exploit: test-suite/failure/prop_set_proof_irrelevance.v + GH issue number: none? risk: ? Module system @@ -77,7 +77,7 @@ Module system impacted coqchk versions: ? fixed in: master/trunk (d4869e059, 2 Oct 2015, Sozeau), v8.4 (40350ef3b, 9 Sep 2015, Sozeau) found by: Dénès - exploit: test-suite/bugs/closed/4294.v + exploit: test-suite/bugs/closed/bug_4294.v GH issue number: #4294 risk: ? @@ -105,7 +105,7 @@ Universes impacted coqchk versions: ? fixed in: trunk/master/v8.4 (8082d1faf, 5 Oct 2011, Herbelin), V8.3pl3 (bb582bca2, 5 Oct 2011, Herbelin), v8.2 branch (3333e8d3, 5 Oct 2011, Herbelin), v8.1 branch (a8fc2027, 5 Oct 2011, Herbelin), found by: Barras - exploit: test-suite/failure/inductive4.v + exploit: test-suite/failure/inductive.v GH issue number: none risk: unlikely to be activated by chance @@ -141,7 +141,7 @@ Primitive projections impacted coqchk versions: ? fixed in: trunk/master/v8.5 (120053a50, 4 Mar 2016, Dénès) found by: Dénès exploiting bug #4588 - exploit: test-suite/bugs/closed/4588.v + exploit: test-suite/bugs/closed/bug_4588.v GH issue number: #4588 risk: ? @@ -167,7 +167,7 @@ Conversion machines impacted coqchk versions: none (no virtual machine in coqchk) fixed in: master/trunk/v8.5 (00894adf6/596a4a525, 26-39 Mar 2015, Grégoire), v8.4 (cd2101a39, 1 Apr 2015, Grégoire), v8.3 (a0c7fc05b, 1 Apr 2015, Grégoire), v8.2 (2c6189f61, 1 Apr 2015, Grégoire), v8.1 (bb877e5b5, 29 Nov 2015, Herbelin, backport) found by: Dénès, Pédrot - exploit: test-suite/failure/vm-bug4157.v + exploit: test-suite/bugs/closed/bug_4157.v GH issue number: #4157 risk: @@ -179,7 +179,7 @@ Conversion machines impacted coqchk versions: none (no virtual machine in coqchk) fixed in: master (c9f3a6cbe, 12 Feb 2018, PR#6713, Dénès), v8.7 (c058a4182, 15 Feb 2018, Zimmermann, backport), v8.6 (a2cc54c64, 21 Feb 2018, Herbelin, backport), v8.5 (d4d550d0f, 21 Feb 2018, Herbelin, backport) found by: Dénès - exploit: test-suite/bugs/closed/6677.v + exploit: test-suite/bugs/closed/bug_6677.v GH issue number: #6677 risk: @@ -203,7 +203,7 @@ Conversion machines impacted coqchk versions: none (no native computation in coqchk) fixed in: master/trunk/v8.6 (244d7a9aa, 19 May 2016, letouzey), v8.5 (088b3161c, 19 May 2016, letouzey), found by: Letouzey, Dénès - exploit: lost? + exploit: see commit message for 244d7a9aa GH issue number: ? risk: diff --git a/dev/nixpkgs.nix b/dev/nixpkgs.nix new file mode 100644 index 0000000000..f4786d9431 --- /dev/null +++ b/dev/nixpkgs.nix @@ -0,0 +1,4 @@ +import (fetchTarball { + url = "https://github.com/NixOS/nixpkgs/archive/8471ab76242987b11afd4486b82888e1588f8307.tar.gz"; + sha256 = "06pp6b6x78jlinxifnphkbp79dx58jr990fkm4qziq0ay5klpxd7"; +}) diff --git a/dev/shim/dune b/dev/shim/dune index 39b4ef492c..e307848292 100644 --- a/dev/shim/dune +++ b/dev/shim/dune @@ -7,7 +7,19 @@ (with-outputs-to coqtop-prelude (progn (echo "#!/usr/bin/env bash\n") - (bash "echo \"$(pwd)/%{bin:coqtop} -coqlib $(pwd)/%{project_root}\" \"$@\"") + (bash "echo \"$(pwd)/%{bin:coqtop} -coqlib $(pwd)/%{project_root}\" \\$@") + (run chmod +x %{targets}))))) + +(rule + (targets coqc-prelude) + (deps + %{bin:coqc} + %{project_root}/theories/Init/Prelude.vo) + (action + (with-outputs-to coqc-prelude + (progn + (echo "#!/usr/bin/env bash\n") + (bash "echo \"$(pwd)/%{bin:coqc} -coqlib $(pwd)/%{project_root}\" \\$@") (run chmod +x %{targets}))))) (rule @@ -20,7 +32,7 @@ (with-outputs-to %{targets} (progn (echo "#!/usr/bin/env bash\n") - (bash "echo \"$(pwd)/%{bin:coqtop.byte} -coqlib $(pwd)/%{project_root}\" \"$@\"") + (bash "echo \"$(pwd)/%{bin:coqtop.byte} -coqlib $(pwd)/%{project_root}\" \\$@") (run chmod +x %{targets}))))) (rule @@ -36,5 +48,5 @@ (with-outputs-to coqide-prelude (progn (echo "#!/usr/bin/env bash\n") - (bash "echo \"$(pwd)/%{bin:coqide} -coqlib $(pwd)/%{project_root}\" \"$@\"") + (bash "echo \"$(pwd)/%{bin:coqide} -coqlib $(pwd)/%{project_root}\" \\$@") (run chmod +x %{targets}))))) diff --git a/dev/tools/backport-pr.sh b/dev/tools/backport-pr.sh index 9864fd4d69..1ec8251f66 100755 --- a/dev/tools/backport-pr.sh +++ b/dev/tools/backport-pr.sh @@ -30,13 +30,15 @@ while [[ $# -gt 0 ]]; do esac done -if ! git log master --grep "Merge PR #${PRNUM}" | grep "." > /dev/null; then +MASTER=origin/master + +if ! git log $MASTER --grep "Merge PR #$PRNUM" | grep "." > /dev/null; then echo "PR #${PRNUM} does not exist." exit 1 fi -SIGNATURE_STATUS=$(git log master --grep "Merge PR #${PRNUM}" --format="%G?") -git log master --grep "Merge PR #${PRNUM}" --format="%GG" +SIGNATURE_STATUS=$(git log $MASTER --grep "Merge PR #$PRNUM" --format="%G?") +git log $MASTER --grep "Merge PR #$PRNUM" --format="%GG" if [[ "$NO_SIGNATURE_CHECK" != "true" && "$SIGNATURE_STATUS" != "G" ]]; then echo read -p "Merge commit does not have a good (valid) signature. Bypass? [y/N] " -n 1 -r @@ -47,10 +49,18 @@ if [[ "$NO_SIGNATURE_CHECK" != "true" && "$SIGNATURE_STATUS" != "G" ]]; then fi BRANCH=backport-pr-${PRNUM} -RANGE=$(git log master --grep "Merge PR #${PRNUM}" --format="%P" | sed 's/ /../') -MESSAGE=$(git log master --grep "Merge PR #${PRNUM}" --format="%s" | sed 's/Merge/Backport/') +RANGE=$(git log $MASTER --grep "Merge PR #$PRNUM" --format="%P" | sed 's/ /../') +MESSAGE=$(git log $MASTER --grep "Merge PR #$PRNUM" --format="%s" | sed 's/Merge/Backport/') -if git checkout -b "${BRANCH}"; then +if [[ "$(git rev-parse --abbrev-ref HEAD)" == "$BRANCH" ]]; then + + if ! git cherry-pick --continue; then + echo "Please fix the conflicts, then relaunch the script." + exit 1 + fi + git checkout - + +elif git checkout -b "$BRANCH"; then if ! git cherry-pick -x "${RANGE}"; then if [[ "$NO_CONFLICTS" == "true" ]]; then @@ -61,12 +71,8 @@ if git checkout -b "${BRANCH}"; then git branch -d "$BRANCH" exit 1 fi - echo "Please fix the conflicts, then exit." - bash - while ! git cherry-pick --continue; do - echo "Please fix the conflicts, then exit." - bash - done + echo "Please fix the conflicts, then relaunch the script." + exit 1 fi git checkout - diff --git a/dev/top_printers.ml b/dev/top_printers.ml index 0fbb0634a5..74be300134 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -60,19 +60,25 @@ let prrecarg = function str "Imbr[" ++ MutInd.print mind ++ pr_comma () ++ int i ++ str "]" let ppwf_paths x = pp (Rtree.pp_tree prrecarg x) +let get_current_context () = + try Vernacstate.Proof_global.get_current_context () + with Vernacstate.Proof_global.NoCurrentProof -> + let env = Global.env() in + Evd.from_env env, env + (* term printers *) -let envpp pp = let sigma,env = Pfedit.get_current_context () in pp env sigma +let envpp pp = let sigma,env = get_current_context () in pp env sigma let rawdebug = ref false let ppevar evk = pp (Evar.print evk) let pr_constr t = - let sigma, env = Pfedit.get_current_context () in + let sigma, env = get_current_context () in Printer.pr_constr_env env sigma t let pr_econstr t = - let sigma, env = Pfedit.get_current_context () in + let sigma, env = get_current_context () in Printer.pr_econstr_env env sigma t let ppconstr x = pp (pr_constr x) let ppeconstr x = pp (pr_econstr x) -let ppconstr_expr x = pp (Ppconstr.pr_constr_expr x) +let ppconstr_expr x = let sigma,env = get_current_context () in pp (Ppconstr.pr_constr_expr env sigma x) let ppsconstr x = ppconstr (Mod_subst.force_constr x) let ppconstr_univ x = Constrextern.with_universes ppconstr x let ppglob_constr = (fun x -> pp(pr_lglob_constr_env (Global.env()) x)) @@ -500,7 +506,7 @@ let ppist ist = (* Vernac-level debugging commands *) let in_current_context f c = - let (evmap,sign) = Pfedit.get_current_context () in + let (evmap,sign) = get_current_context () in f (fst (Constrintern.interp_constr sign evmap c))(*FIXME*) (* We expand the result of preprocessing to be independent of camlp5 diff --git a/doc/plugin_tutorial/tuto1/src/g_tuto1.mlg b/doc/plugin_tutorial/tuto1/src/g_tuto1.mlg index 4df284d2d9..1d0aca1caf 100644 --- a/doc/plugin_tutorial/tuto1/src/g_tuto1.mlg +++ b/doc/plugin_tutorial/tuto1/src/g_tuto1.mlg @@ -145,10 +145,12 @@ END it gives an error message that is basically impossible to understand. *) VERNAC COMMAND EXTEND ExploreProof CLASSIFIED AS QUERY -| [ "Cmd9" ] -> - { let p = Proof_global.give_me_the_proof () in - let sigma, env = Pfedit.get_current_context () in - let pprf = Proof.partial_proof p in - Feedback.msg_notice - (Pp.prlist_with_sep Pp.fnl (Printer.pr_econstr_env env sigma) pprf) } +| ![ proof ] [ "Cmd9" ] -> + { fun ~pstate -> + Option.iter (fun (pstate : Proof_global.t) -> + let sigma, env = Pfedit.get_current_context pstate in + let pprf = Proof.partial_proof Proof_global.(give_me_the_proof pstate) in + Feedback.msg_notice + (Pp.prlist_with_sep Pp.fnl (Printer.pr_econstr_env env sigma) pprf)) pstate; + pstate } END diff --git a/doc/plugin_tutorial/tuto1/src/simple_declare.ml b/doc/plugin_tutorial/tuto1/src/simple_declare.ml index e370d37fc4..23f8fbe888 100644 --- a/doc/plugin_tutorial/tuto1/src/simple_declare.ml +++ b/doc/plugin_tutorial/tuto1/src/simple_declare.ml @@ -1,5 +1,5 @@ (* Ideally coq/coq#8811 would get merged and then this function could be much simpler. *) -let edeclare ?hook ident (_, poly, _ as k) ~opaque sigma udecl body tyopt imps = +let edeclare ?hook ~ontop ident (_, poly, _ as k) ~opaque sigma udecl body tyopt imps = let sigma = Evd.minimize_universes sigma in let body = EConstr.to_constr sigma body in let tyopt = Option.map (EConstr.to_constr sigma) tyopt in @@ -13,13 +13,13 @@ let edeclare ?hook ident (_, poly, _ as k) ~opaque sigma udecl body tyopt imps = let ubinders = Evd.universe_binders sigma in let ce = Declare.definition_entry ?types:tyopt ~univs body in let hook_data = Option.map (fun hook -> hook, uctx, []) hook in - DeclareDef.declare_definition ident k ce ubinders imps ?hook_data + DeclareDef.declare_definition ~ontop ident k ce ubinders imps ?hook_data let packed_declare_definition ~poly ident value_with_constraints = let body, ctx = value_with_constraints in let sigma = Evd.from_ctx ctx in let k = (Decl_kinds.Global, poly, Decl_kinds.Definition) in let udecl = UState.default_univ_decl in - ignore (edeclare ident k ~opaque:false sigma udecl body None []) + ignore (edeclare ~ontop:None ident k ~opaque:false sigma udecl body None []) (* But this definition cannot be undone by Reset ident *) diff --git a/doc/sphinx/_static/diffs-error-message.png b/doc/sphinx/_static/diffs-error-message.png Binary files differnew file mode 100644 index 0000000000..6733d9c6a9 --- /dev/null +++ b/doc/sphinx/_static/diffs-error-message.png diff --git a/doc/sphinx/addendum/implicit-coercions.rst b/doc/sphinx/addendum/implicit-coercions.rst index d15aacad44..d5523e8561 100644 --- a/doc/sphinx/addendum/implicit-coercions.rst +++ b/doc/sphinx/addendum/implicit-coercions.rst @@ -154,8 +154,10 @@ Declaring Coercions .. warn:: Ambiguous path. When the coercion :token:`qualid` is added to the inheritance graph, - invalid coercion paths are ignored; they are signaled by a warning - displaying these paths of the form :g:`[f₁;..;fₙ] : C >-> D`. + invalid coercion paths are ignored. The :cmd:`Coercion` command tries to check + that they are convertible with existing ones on the same classes. + The paths for which this check fails are displayed by a warning in the form + :g:`[f₁;..;fₙ] : C >-> D`. .. cmdv:: Local Coercion @qualid : @class >-> @class @@ -322,21 +324,8 @@ are also forgotten. Coercions and Modules --------------------- -.. flag:: Automatic Coercions Import - - Since |Coq| version 8.3, the coercions present in a module are activated - only when the module is explicitly imported. Formerly, the coercions - were activated as soon as the module was required, whether it was - imported or not. - - This option makes it possible to recover the behavior of the versions of - |Coq| prior to 8.3. - -.. warn:: Coercion used but not in scope: @qualid. If you want to use this coercion, please Import the module that contains it. - - This warning is emitted when typechecking relies on a coercion - contained in a module that has not been explicitely imported. It helps - migrating code and stop relying on the option above. +The coercions present in a module are activated only when the module is +explicitly imported. Examples -------- diff --git a/doc/sphinx/addendum/ring.rst b/doc/sphinx/addendum/ring.rst index 20e4c6a3d6..3b350d5dc0 100644 --- a/doc/sphinx/addendum/ring.rst +++ b/doc/sphinx/addendum/ring.rst @@ -323,7 +323,7 @@ The syntax for adding a new ring is decidable :n:`@term` declares the ring as computational. The expression :n:`@term` is the correctness proof of an equality test ``?=!`` - (which hould be evaluable). Its type should be of the form + (which should be evaluable). Its type should be of the form ``forall x y, x ?=! y = true → x == y``. morphism :n:`@term` diff --git a/doc/sphinx/addendum/type-classes.rst b/doc/sphinx/addendum/type-classes.rst index c7ea7e326f..b069cf27f4 100644 --- a/doc/sphinx/addendum/type-classes.rst +++ b/doc/sphinx/addendum/type-classes.rst @@ -1,7 +1,7 @@ .. _typeclasses: -Type Classes -============ +Typeclasses +=========== This chapter presents a quick reference of the commands related to type classes. For an actual introduction to typeclasses, there is a @@ -15,24 +15,25 @@ Class and Instance declarations The syntax for class and instance declarations is the same as the record syntax of Coq: -``Class Id (`` |p_1| ``:`` |t_1| ``) ⋯ (`` |p_n| ``:`` |t_n| ``) [: -sort] := {`` |f_1| ``:`` |u_1| ``; ⋮`` |f_m| ``:`` |u_m| ``}.`` +.. coqdoc:: -``Instance ident : Id`` |p_1| ``⋯`` |p_n| ``:= {`` |f_1| ``:=`` |t_1| ``; ⋮`` |f_m| ``:=`` |t_m| ``}.`` + Class classname (p1 : t1) ⋯ (pn : tn) [: sort] := { f1 : u1 ; ⋯ ; fm : um }. -The |p_i| ``:`` |t_i| variables are called the *parameters* of the class and -the |f_i| ``:`` |t_i| are called the *methods*. Each class definition gives + Instance instancename q1 ⋯ qm : classname p1 ⋯ pn := { f1 := t1 ; ⋯ ; fm := tm }. + +The ``pi : ti`` variables are called the *parameters* of the class and +the ``fi : ti`` are called the *methods*. Each class definition gives rise to a corresponding record declaration and each instance is a -regular definition whose name is given by ident and type is an +regular definition whose name is given by `instancename` and type is an instantiation of the record type. We’ll use the following example class in the rest of the chapter: .. coqtop:: in - Class EqDec (A : Type) := { - eqb : A -> A -> bool ; - eqb_leibniz : forall x y, eqb x y = true -> x = y }. + Class EqDec (A : Type) := + { eqb : A -> A -> bool ; + eqb_leibniz : forall x y, eqb x y = true -> x = y }. This class implements a boolean equality test which is compatible with Leibniz equality on some type. An example implementation is: @@ -40,9 +41,11 @@ Leibniz equality on some type. An example implementation is: .. coqtop:: in Instance unit_EqDec : EqDec unit := - { eqb x y := true ; - eqb_leibniz x y H := - match x, y return x = y with tt, tt => eq_refl tt end }. + { eqb x y := true ; + eqb_leibniz x y H := + match x, y return x = y with + | tt, tt => eq_refl tt + end }. Using :cmd:`Program Instance`, if one does not give all the members in the Instance declaration, Coq generates obligations for the remaining @@ -52,7 +55,7 @@ fields, e.g.: Require Import Program.Tactics. Program Instance eq_bool : EqDec bool := - { eqb x y := if x then y else negb y }. + { eqb x y := if x then y else negb y }. .. coqtop:: all @@ -127,9 +130,9 @@ the constraints as a binding context before the instance, e.g.: .. coqtop:: in Program Instance prod_eqb `(EA : EqDec A, EB : EqDec B) : EqDec (A * B) := - { eqb x y := match x, y with - | (la, ra), (lb, rb) => andb (eqb la lb) (eqb ra rb) - end }. + { eqb x y := match x, y with + | (la, ra), (lb, rb) => andb (eqb la lb) (eqb ra rb) + end }. .. coqtop:: none @@ -138,21 +141,27 @@ the constraints as a binding context before the instance, e.g.: These instances are used just as well as lemmas in the instance hint database. +.. _contexts: + Sections and contexts --------------------- -To ease the parametrization of developments by typeclasses, we provide a new -way to introduce variables into section contexts, compatible with the implicit -argument mechanism. The new command works similarly to the :cmd:`Variables` -vernacular, except it accepts any binding context as argument. For example: +To ease developments parameterized by many instances, one can use the +:cmd:`Context` command to introduce these parameters into section contexts, +it works similarly to the command :cmd:`Variable`, except it accepts any +binding context as an argument, so variables can be implicit, and +:ref:`implicit-generalization` can be used. +For example: .. coqtop:: all Section EqDec_defs. - Context `{EA : EqDec A}. + Context `{EA : EqDec A}. - Global Program Instance option_eqb : EqDec (option A) := +.. coqtop:: in + + Global Program Instance option_eqb : EqDec (option A) := { eqb x y := match x, y with | Some x, Some y => eqb x y | None, None => true @@ -160,14 +169,17 @@ vernacular, except it accepts any binding context as argument. For example: end }. Admit Obligations. +.. coqtop:: all + End EqDec_defs. About option_eqb. -Here the Global modifier redeclares the instance at the end of the +Here the :cmd:`Global` modifier redeclares the instance at the end of the section, once it has been generalized by the context variables it uses. +.. seealso:: Section :ref:`section-mechanism` Building hierarchies -------------------- @@ -188,7 +200,7 @@ superclasses as a binding context: Contrary to Haskell, we have no special syntax for superclasses, but this declaration is equivalent to: -:: +.. coqdoc:: Class `(E : EqDec A) => Ord A := { le : A -> A -> bool }. @@ -248,8 +260,8 @@ explanation). These may be used as parts of other classes: .. coqtop:: all Class PreOrder (A : Type) (R : relation A) := - { PreOrder_Reflexive :> Reflexive A R ; - PreOrder_Transitive :> Transitive A R }. + { PreOrder_Reflexive :> Reflexive A R ; + PreOrder_Transitive :> Transitive A R }. The syntax ``:>`` indicates that each ``PreOrder`` can be seen as a ``Reflexive`` relation. So each time a reflexive relation is needed, a @@ -273,33 +285,31 @@ Summary of the commands .. cmd:: Class @ident {? @binders} : {? @sort} := {? @ident} { {+; @ident :{? >} @term } } The :cmd:`Class` command is used to declare a typeclass with parameters - ``binders`` and fields the declared record fields. - -Variants: + :token:`binders` and fields the declared record fields. -.. _singleton-class: + .. _singleton-class: -.. cmd:: Class @ident {? @binders} : {? @sort} := @ident : @term + .. cmdv:: Class @ident {? @binders} : {? @sort} := @ident : @term - This variant declares a *singleton* class with a single method. This - singleton class is a so-called definitional class, represented simply - as a definition ``ident binders := term`` and whose instances are - themselves objects of this type. Definitional classes are not wrapped - inside records, and the trivial projection of an instance of such a - class is convertible to the instance itself. This can be useful to - make instances of existing objects easily and to reduce proof size by - not inserting useless projections. The class constant itself is - declared rigid during resolution so that the class abstraction is - maintained. + This variant declares a *singleton* class with a single method. This + singleton class is a so-called definitional class, represented simply + as a definition ``ident binders := term`` and whose instances are + themselves objects of this type. Definitional classes are not wrapped + inside records, and the trivial projection of an instance of such a + class is convertible to the instance itself. This can be useful to + make instances of existing objects easily and to reduce proof size by + not inserting useless projections. The class constant itself is + declared rigid during resolution so that the class abstraction is + maintained. -.. cmd:: Existing Class @ident + .. cmdv:: Existing Class @ident - This variant declares a class a posteriori from a constant or - inductive definition. No methods or instances are defined. + This variant declares a class a posteriori from a constant or + inductive definition. No methods or instances are defined. - .. warn:: @ident is already declared as a typeclass + .. warn:: @ident is already declared as a typeclass - This command has no effect when used on a typeclass. + This command has no effect when used on a typeclass. .. cmd:: Instance @ident {? @binders} : @class t1 … tn [| priority] := { field1 := b1 ; …; fieldi := bi } @@ -314,32 +324,33 @@ Variants: :tacn:`auto` hints. If the priority is not specified, it defaults to the number of non-dependent binders of the instance. -.. cmdv:: Instance @ident {? @binders} : forall {? @binders}, @class @term__1 … @term__n [| priority] := @term + .. cmdv:: Instance @ident {? @binders} : forall {? @binders}, @class @term__1 … @term__n [| priority] := @term - This syntax is used for declaration of singleton class instances or - for directly giving an explicit term of type :n:`forall @binders, @class - @term__1 … @term__n`. One need not even mention the unique field name for - singleton classes. + This syntax is used for declaration of singleton class instances or + for directly giving an explicit term of type :n:`forall @binders, @class + @term__1 … @term__n`. One need not even mention the unique field name for + singleton classes. -.. cmdv:: Global Instance + .. cmdv:: Global Instance + :name: Global Instance - One can use the ``Global`` modifier on instances declared in a - section so that their generalization is automatically redeclared - after the section is closed. + One can use the :cmd:`Global` modifier on instances declared in a + section so that their generalization is automatically redeclared + after the section is closed. -.. cmdv:: Program Instance - :name: Program Instance + .. cmdv:: Program Instance + :name: Program Instance - Switches the type checking to Program (chapter :ref:`programs`) and - uses the obligation mechanism to manage missing fields. + Switches the type checking to `Program` (chapter :ref:`programs`) and + uses the obligation mechanism to manage missing fields. -.. cmdv:: Declare Instance - :name: Declare Instance + .. cmdv:: Declare Instance + :name: Declare Instance - In a Module Type, this command states that a corresponding concrete - instance should exist in any implementation of this Module Type. This - is similar to the distinction between :cmd:`Parameter` vs. :cmd:`Definition`, or - between :cmd:`Declare Module` and :cmd:`Module`. + In a :cmd:`Module Type`, this command states that a corresponding concrete + instance should exist in any implementation of this :cmd:`Module Type`. This + is similar to the distinction between :cmd:`Parameter` vs. :cmd:`Definition`, or + between :cmd:`Declare Module` and :cmd:`Module`. Besides the :cmd:`Class` and :cmd:`Instance` vernacular commands, there are a @@ -354,11 +365,6 @@ few other commands related to typeclasses. equivalent to ``Hint Resolve ident : typeclass_instances``, except it registers instances for :cmd:`Print Instances`. -.. cmd:: Context @binders - - Declares variables according to the given binding context, which might - use :ref:`implicit-generalization`. - .. tacn:: typeclasses eauto :name: typeclasses eauto @@ -449,9 +455,8 @@ By default, all constants and local variables are considered transparent. One should take care not to make opaque any constant that is used to abbreviate a type, like: -:: - - relation A := A -> A -> Prop. +.. coqdoc:: + Definition relation A := A -> A -> Prop. This is equivalent to ``Hint Transparent, Opaque ident : typeclass_instances``. @@ -556,6 +561,8 @@ Settings .. flag:: Refine Instance Mode + .. deprecated:: 8.10 + This flag allows to switch the behavior of instance declarations made through the Instance command. @@ -568,18 +575,19 @@ Settings Typeclasses eauto `:=` ~~~~~~~~~~~~~~~~~~~~~~ -.. cmd:: Typeclasses eauto := {? debug} {? {dfs | bfs}} depth +.. cmd:: Typeclasses eauto := {? debug} {? (dfs) | (bfs) } @num :name: Typeclasses eauto This command allows more global customization of the typeclass resolution tactic. The semantics of the options are: - + ``debug`` In debug mode, the trace of successfully applied tactics is - printed. This value can also be set with :flag:`Typeclasses Debug`. + + ``debug`` This sets the debug mode. In debug mode, the trace of + successfully applied tactics is printed. The debug mode can also + be set with :flag:`Typeclasses Debug`. - + ``dfs, bfs`` This sets the search strategy to depth-first search (the - default) or breadth-first search. This value can also be set with - :flag:`Typeclasses Iterative Deepening`. + + ``(dfs)``, ``(bfs)`` This sets the search strategy to depth-first + search (the default) or breadth-first search. The search strategy + can also be set with :flag:`Typeclasses Iterative Deepening`. - + ``depth`` This sets the depth limit of the search. This value can also be set with - :opt:`Typeclasses Depth`. + + :token:`num` This sets the depth limit of the search. The depth + limit can also be set with :opt:`Typeclasses Depth`. diff --git a/doc/sphinx/language/gallina-extensions.rst b/doc/sphinx/language/gallina-extensions.rst index 59506a6ff2..695dea222f 100644 --- a/doc/sphinx/language/gallina-extensions.rst +++ b/doc/sphinx/language/gallina-extensions.rst @@ -754,10 +754,46 @@ used by ``Function``. A more precise description is given below. Section mechanism ----------------- -The sectioning mechanism can be used to to organize a proof in -structured sections. Then local declarations become available (see -Section :ref:`gallina-definitions`). +Sections create local contexts which can be shared across multiple definitions. +.. example:: + + Sections are opened by the :cmd:`Section` command, and closed by :cmd:`End`. + + .. coqtop:: all + + Section s1. + + Inside a section, local parameters can be introduced using :cmd:`Variable`, + :cmd:`Hypothesis`, or :cmd:`Context` (there are also plural variants for + the first two). + + .. coqtop:: all + + Variables x y : nat. + + The command :cmd:`Let` introduces section-wide :ref:`let-in`. These definitions + won't persist when the section is closed, and all persistent definitions which + depend on `y'` will be prefixed with `let y' := y in`. + + .. coqtop:: in + + Let y' := y. + Definition x' := S x. + Definition x'' := x' + y'. + + .. coqtop:: all + + Print x'. + Print x''. + + End s1. + + Print x'. + Print x''. + + Notice the difference between the value of :g:`x'` and :g:`x''` inside section + :g:`s1` and outside. .. cmd:: Section @ident @@ -768,43 +804,80 @@ Section :ref:`gallina-definitions`). .. cmd:: End @ident This command closes the section named :token:`ident`. After closing of the - section, the local declarations (variables and local definitions) get + section, the local declarations (variables and local definitions, see :cmd:`Variable`) get *discharged*, meaning that they stop being visible and that all global objects defined in the section are generalized with respect to the variables and local definitions they each depended on in the section. - .. example:: + .. exn:: This is not the last opened section. + :undocumented: - .. coqtop:: all +.. note:: + Most commands, like :cmd:`Hint`, :cmd:`Notation`, option management, … which + appear inside a section are canceled when the section is closed. - Section s1. +.. cmd:: Variable @ident : @type - Variables x y : nat. + This command links :token:`type` to the name :token:`ident` in the context of + the current section. When the current section is closed, name :token:`ident` + will be unknown and every object using this variable will be explicitly + parameterized (the variable is *discharged*). - Let y' := y. + .. exn:: @ident already exists. + :name: @ident already exists. (Variable) + :undocumented: - Definition x' := S x. + .. cmdv:: Variable {+ @ident } : @type - Definition x'' := x' + y'. + Links :token:`type` to each :token:`ident`. - Print x'. + .. cmdv:: Variable {+ ( {+ @ident } : @type ) } - End s1. + Declare one or more variables with various types. - Print x'. + .. cmdv:: Variables {+ ( {+ @ident } : @type) } + Hypothesis {+ ( {+ @ident } : @type) } + Hypotheses {+ ( {+ @ident } : @type) } + :name: Variables; Hypothesis; Hypotheses - Print x''. + These variants are synonyms of :n:`Variable {+ ( {+ @ident } : @type) }`. - Notice the difference between the value of :g:`x'` and :g:`x''` inside section - :g:`s1` and outside. +.. cmd:: Let @ident := @term - .. exn:: This is not the last opened section. + This command binds the value :token:`term` to the name :token:`ident` in the + environment of the current section. The name :token:`ident` is accessible + only within the current section. When the section is closed, all persistent + definitions and theorems within it and depending on :token:`ident` + will be prefixed by the let-in definition :n:`let @ident := @term in`. + + .. exn:: @ident already exists. + :name: @ident already exists. (Let) :undocumented: -.. note:: - Most commands, like :cmd:`Hint`, :cmd:`Notation`, option management, … which - appear inside a section are canceled when the section is closed. + .. cmdv:: Let @ident {? @binders } {? : @type } := @term + :undocumented: + + .. cmdv:: Let Fixpoint @ident @fix_body {* with @fix_body} + :name: Let Fixpoint + :undocumented: + + .. cmdv:: Let CoFixpoint @ident @cofix_body {* with @cofix_body} + :name: Let CoFixpoint + :undocumented: + +.. cmd:: Context @binders + + Declare variables in the context of the current section, like :cmd:`Variable`, + but also allowing implicit variables, :ref:`implicit-generalization`, and + let-binders. + + .. coqdoc:: + + Context {A : Type} (a b : A). + Context `{EqDec A}. + Context (b' := b). +.. seealso:: Section :ref:`binders`. Section :ref:`contexts` in chapter :ref:`typeclasses`. Module system ------------- @@ -1357,8 +1430,8 @@ with the same physical-to-logical translation and with an empty logical prefix. The command line option ``-R`` is a variant of ``-Q`` which has the strictly same behavior regarding loadpaths, but which also makes the corresponding ``.vo`` files available through their short names in a way -not unlike the ``Import`` command (see :ref:`here <import_qualid>`). For instance, ``-R`` `path` ``Lib`` -associates to the file path `path`\ ``/path/fOO/Bar/File.vo`` the logical name +not unlike the ``Import`` command (see :ref:`here <import_qualid>`). For instance, ``-R path Lib`` +associates to the file ``/path/fOO/Bar/File.vo`` the logical name ``Lib.fOO.Bar.File``, but allows this file to be accessed through the short names ``fOO.Bar.File,Bar.File`` and ``File``. If several files with identical base name are present in different subdirectories of a @@ -2028,7 +2101,7 @@ or :g:`m` to the type :g:`nat` of natural numbers). This is useful for declaring the implicit type of a single variable. -.. cmdv:: Implicit Types {+ ( {+ @ident } : @term ) } +.. cmdv:: Implicit Types {+ ( {+ @ident } : @type ) } Adds blocks of implicit types with different specifications. diff --git a/doc/sphinx/language/gallina-specification-language.rst b/doc/sphinx/language/gallina-specification-language.rst index 02fb9d84ce..8a5e9d87f8 100644 --- a/doc/sphinx/language/gallina-specification-language.rst +++ b/doc/sphinx/language/gallina-specification-language.rst @@ -630,33 +630,21 @@ has type :token:`type`. These variants are synonyms of :n:`{? Local } Parameter {+ ( {+ @ident } : @type ) }`. -.. cmd:: Variable @ident : @type + .. cmdv:: Variable {+ ( {+ @ident } : @type ) } + Variables {+ ( {+ @ident } : @type ) } + Hypothesis {+ ( {+ @ident } : @type ) } + Hypotheses {+ ( {+ @ident } : @type ) } + :name: Variable (outside a section); Variables (outside a section); Hypothesis (outside a section); Hypotheses (outside a section) - This command links :token:`type` to the name :token:`ident` in the context of - the current section (see Section :ref:`section-mechanism` for a description of - the section mechanism). When the current section is closed, name :token:`ident` - will be unknown and every object using this variable will be explicitly - parametrized (the variable is *discharged*). Using the :cmd:`Variable` command out - of any section is equivalent to using :cmd:`Local Parameter`. + Outside of any section, these variants are synonyms of + :n:`Local Parameter {+ ( {+ @ident } : @type ) }`. + For their meaning inside a section, see :cmd:`Variable` in + :ref:`section-mechanism`. - .. exn:: @ident already exists. - :name: @ident already exists. (Variable) - :undocumented: - - .. cmdv:: Variable {+ @ident } : @term - - Links :token:`type` to each :token:`ident`. + .. warn:: @ident is declared as a local axiom [local-declaration,scope] - .. cmdv:: Variable {+ ( {+ @ident } : @term ) } - - Adds blocks of variables with different specifications. - - .. cmdv:: Variables {+ ( {+ @ident } : @term) } - Hypothesis {+ ( {+ @ident } : @term) } - Hypotheses {+ ( {+ @ident } : @term) } - :name: Variables; Hypothesis; Hypotheses - - These variants are synonyms of :n:`Variable {+ ( {+ @ident } : @term) }`. + Warning generated when using :cmd:`Variable` instead of + :cmd:`Local Parameter`. .. note:: It is advised to use the commands :cmd:`Axiom`, :cmd:`Conjecture` and @@ -665,6 +653,8 @@ has type :token:`type`. :cmd:`Parameter` and :cmd:`Variable` (and their plural forms) in other cases (corresponding to the declaration of an abstract mathematical entity). +.. seealso:: Section :ref:`section-mechanism`. + .. _gallina-definitions: Definitions @@ -704,10 +694,10 @@ Section :ref:`typing-rules`. .. exn:: The term @term has type @type while it is expected to have type @type'. :undocumented: - .. cmdv:: Definition @ident @binders {? : @term } := @term + .. cmdv:: Definition @ident @binders {? : @type } := @term This is equivalent to - :n:`Definition @ident : forall @binders, @term := fun @binders => @term`. + :n:`Definition @ident : forall @binders, @type := fun @binders => @term`. .. cmdv:: Local Definition @ident {? @binders } {? : @type } := @term :name: Local Definition @@ -721,32 +711,18 @@ Section :ref:`typing-rules`. This is equivalent to :cmd:`Definition`. -.. seealso:: :cmd:`Opaque`, :cmd:`Transparent`, :tacn:`unfold`. + .. cmdv:: Let @ident := @term + :name: Let (outside a section) -.. cmd:: Let @ident := @term + Outside of any section, this variant is a synonym of + :n:`Local Definition @ident := @term`. + For its meaning inside a section, see :cmd:`Let` in + :ref:`section-mechanism`. - This command binds the value :token:`term` to the name :token:`ident` in the - environment of the current section. The name :token:`ident` disappears when the - current section is eventually closed, and all persistent objects (such - as theorems) defined within the section and depending on :token:`ident` are - prefixed by the let-in definition :n:`let @ident := @term in`. - Using the :cmd:`Let` command out of any section is equivalent to using - :cmd:`Local Definition`. + .. warn:: @ident is declared as a local definition [local-declaration,scope] - .. exn:: @ident already exists. - :name: @ident already exists. (Let) - :undocumented: - - .. cmdv:: Let @ident {? @binders } {? : @type } := @term - :undocumented: - - .. cmdv:: Let Fixpoint @ident @fix_body {* with @fix_body} - :name: Let Fixpoint - :undocumented: - - .. cmdv:: Let CoFixpoint @ident @cofix_body {* with @cofix_body} - :name: Let CoFixpoint - :undocumented: + Warning generated when using :cmd:`Let` instead of + :cmd:`Local Definition`. .. seealso:: Section :ref:`section-mechanism`, commands :cmd:`Opaque`, :cmd:`Transparent`, and tactic :tacn:`unfold`. @@ -877,8 +853,8 @@ which is a type whose conclusion is a sort. successor :g:`(S (S n))` satisfies also :g:`P`. This is indeed analogous to the structural induction principle we got for :g:`nat`. -Parametrized inductive types -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Parameterized inductive types +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ .. cmdv:: Inductive @ident @binders {? : @type } := {? | } @ident : @type {* | @ident : @type} @@ -954,7 +930,7 @@ Parametrized inductive types because the conclusion of the type of constructors should be :g:`listw A` in both cases. - + A parametrized inductive definition can be defined using annotations + + A parameterized inductive definition can be defined using annotations instead of parameters but it will sometimes give a different (bigger) sort for the inductive definition and will produce a less convenient rule for case elimination. @@ -1014,7 +990,7 @@ Mutually defined inductive types .. cmdv:: Inductive @ident @binders {? : @type } := {? | } {*| @ident : @type } {* with {? | } {*| @ident @binders {? : @type } } } - In this variant, the inductive definitions are parametrized + In this variant, the inductive definitions are parameterized with :token:`binders`. However, parameters correspond to a local context in which the whole set of inductive declarations is done. For this reason, the parameters must be strictly the same for each inductive types. @@ -1050,7 +1026,7 @@ Mutually defined inductive types Check forest_rec. - Assume we want to parametrize our mutual inductive definitions with the + Assume we want to parameterize our mutual inductive definitions with the two type variables :g:`A` and :g:`B`, the declaration should be done the following way: diff --git a/doc/sphinx/practical-tools/coqide.rst b/doc/sphinx/practical-tools/coqide.rst index 8b7fe20191..97d86943fb 100644 --- a/doc/sphinx/practical-tools/coqide.rst +++ b/doc/sphinx/practical-tools/coqide.rst @@ -218,11 +218,12 @@ Using Unicode symbols |CoqIDE| is based on GTK+ and inherits from it support for Unicode in its text windows. Consequently a large set of symbols is available for -notations. +notations. Furthermore, |CoqIDE| conveniently provides a simple way to +input Unicode characters. Displaying Unicode symbols -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~~~~~~~~~~~~~~~~~~~~~~~~~~ You just need to define suitable notations as described in the chapter :ref:`syntaxextensionsandinterpretationscopes`. For example, to use the @@ -251,38 +252,79 @@ use antialiased fonts or not, by setting the environment variable `GDK_USE_XFT` to 1 or 0 respectively. -Defining an input method for non-ASCII symbols -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Bindings for input of Unicode symbols +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -To input a Unicode symbol, a general method provided by GTK+ is to -simultaneously press the Control, Shift and “u” keys, release, then -type the hexadecimal code of the symbol required, for example `2200` -for the ∀ symbol. A list of symbol codes is available at -`http://www.unicode.org`. +CoqIDE supports a builtin mechanism to input non-ASCII symbols. +For example, to input ``π``, it suffices to type ``\pi`` then press the +combination of key ``Shift+Space`` (default key binding). Often, it +suffices to type a prefix of the latex token, e.g. typing ``\p`` +then ``Shift+Space`` suffices to insert a ``π``. -An alternative method which does not require to know the hexadecimal -code of the character is to use an Input Method Editor. On POSIX -systems (Linux distributions, BSD variants and MacOS X), you can -use `uim` version 1.6 or later which provides a LaTeX-style input -method. +For several symbols, ASCII art is also recognized, e.g. ``\->`` for a +right arrow, or ``\>=`` for a greater than or equal sign. -To configure uim, execute uim-pref-gtk as your regular user. In the -"Global Settings" group set the default Input Method to "ELatin" -(don’t forget to tick the checkbox "Specify default IM"). In the -"ELatin" group set the layout to "TeX", and remember the content of -the "[ELatin] on" field (by default Control-\\). You can now execute -|CoqIDE| with the following commands (assuming you use a Bourne-style -shell): +A larger number of latex tokens are supported by default. The full list +is available here: +https://github.com/coq/coq/blob/master/ide/default_bindings_src.ml -:: +Custom bindings may be added, as explained further on. - $ export GTK_IM_MODULE=uim - $ coqide +.. note:: + It remains possible to input non-ASCII symbols using system-wide + approaches independent of |CoqIDE|. + + +Adding custom bindings +~~~~~~~~~~~~~~~~~~~~~~ + +To extend the default set of bindings, create a file named ``coqide.bindings`` +and place it in the same folder as ``coqide.keys``. On Linux, this would be +the folder ``~/.config/coq``. The file `coqide.bindings` should contain one +binding per line, in the form ``\key value``, followed by an optional priority +integer. (The key and value should not contain any space character.) + +.. example:: + + Here is an example configuration file: + + :: + + \par || + \pi π 1 + \le ≤ 1 + \lambda λ 2 + \lambdas λs + +Above, the priority number 1 on ``\pi`` indicates that the prefix ``\p`` +should resolve to ``\pi``, and not to something else (e.g. ``\par``). +Similarly, the above settings ensure than ``\l`` resolves to ``\le``, +and that ``\la`` resolves to ``\lambda``. + +It can be useful to work with per-project binding files. For this purpose +|CoqIDE| accepts a command line argument of the form +``-unicode-bindings file1,file2,...,fileN``. +Each of the file tokens provided may consists of one of: + + - a path to a custom bindings file, + - the token ``default``, which resolves to the default bindings file, + - the token ``local``, which resolves to the `coqide.bindings` file + stored in the user configuration directory. + +.. warning:: + + If a filename other than the first one includes a "~" to refer + to the home directory, it won't be expanded properly. To work around that + issue, one should not use comas but instead repeat the flag, in the form: + ``-unicode-bindings file1 .. -unicode-bindings fileN``. + +.. note:: + + If two bindings for a same token both have the same priority value + (or both have no priority value set), then the binding considered is + the one from the file that comes first on the command line. -Activate the ELatin Input Method with Control-\\, then type the -sequence `\\Gamma`. You will see the sequence being replaced by Γ as -soon as you type the second "a". .. _character-encoding-saved-files: diff --git a/doc/sphinx/proof-engine/ltac.rst b/doc/sphinx/proof-engine/ltac.rst index 52e3029b8f..0322b43694 100644 --- a/doc/sphinx/proof-engine/ltac.rst +++ b/doc/sphinx/proof-engine/ltac.rst @@ -1071,6 +1071,16 @@ Proving a subgoal as a separate lemma It may be useful to generate lemmas minimal w.r.t. the assumptions they depend on. This can be obtained thanks to the option below. + .. warning:: + + The abstract tactic, while very useful, still has some known + limitations, see https://github.com/coq/coq/issues/9146 for more + details. Thus we recommend using it caution in some + "non-standard" contexts. In particular, ``abstract`` won't + properly work when used inside quotations ``ltac:(...)``, or + if used as part of typeclass resolution, it may produce wrong + terms when in universe polymorphic mode. + .. tacv:: abstract @expr using @ident Give explicitly the name of the auxiliary lemma. diff --git a/doc/sphinx/proof-engine/proof-handling.rst b/doc/sphinx/proof-engine/proof-handling.rst index 27360f02d3..16b158c397 100644 --- a/doc/sphinx/proof-engine/proof-handling.rst +++ b/doc/sphinx/proof-engine/proof-handling.rst @@ -544,6 +544,10 @@ Requesting information ``<Your Tactic Text here>``. + .. deprecated:: 8.10 + + Please use a text editor. + .. cmdv:: Show Proof :name: Show Proof @@ -628,7 +632,8 @@ Showing differences between proof steps --------------------------------------- -Coq can automatically highlight the differences between successive proof steps. +Coq can automatically highlight the differences between successive proof steps and between +values in some error messages. For example, the following screenshots of CoqIDE and coqtop show the application of the same :tacn:`intros` tactic. The tactic creates two new hypotheses, highlighted in green. The conclusion is entirely in pale green because although it’s changed, no tokens were added @@ -665,15 +670,24 @@ new, no line of old text is shown for them. .. image:: ../_static/diffs-coqtop-on3.png :alt: coqtop with Set Diffs on +This image shows an error message with diff highlighting in CoqIDE: + +.. + + .. image:: ../_static/diffs-error-message.png + :alt: |CoqIDE| error message with diffs + How to enable diffs ``````````````````` .. opt:: Diffs %( "on" %| "off" %| "removed" %) :name: Diffs - The “on” option highlights added tokens in green, while the “removed” option + The “on” setting highlights added tokens in green, while the “removed” setting additionally reprints items with removed tokens in red. Unchanged tokens in - modified items are shown with pale green or red. (Colors are user-configurable.) + modified items are shown with pale green or red. Diffs in error messages + use red and green for the compared values; they appear regardless of the setting. + (Colors are user-configurable.) For coqtop, showing diffs can be enabled when starting coqtop with the ``-diffs on|off|removed`` command-line option or by setting the :opt:`Diffs` option @@ -42,3 +42,5 @@ (name runtest) (package coqide-server) (deps test-suite/summary.log)) + +; (dirs (:standard _build_ci)) diff --git a/gramlib/grammar.ml b/gramlib/grammar.ml index f46ddffd6e..74350c4f15 100644 --- a/gramlib/grammar.ml +++ b/gramlib/grammar.ml @@ -15,7 +15,7 @@ module type S = sig type te type parsable - val parsable : char Stream.t -> parsable + val parsable : ?loc:Loc.t -> char Stream.t -> parsable val tokens : string -> (string * int) list module Entry : sig @@ -1398,8 +1398,8 @@ let clear_entry e = Dlevels _ -> e.edesc <- Dlevels [] | Dparser _ -> () - let parsable cs = - let (ts, lf) = L.lexer.Plexing.tok_func cs in + let parsable ?loc cs = + let (ts, lf) = L.lexer.Plexing.tok_func ?loc cs in {pa_chr_strm = cs; pa_tok_strm = ts; pa_loc_func = lf} module Entry = struct diff --git a/gramlib/grammar.mli b/gramlib/grammar.mli index bde07ddc48..7cb7a92f85 100644 --- a/gramlib/grammar.mli +++ b/gramlib/grammar.mli @@ -23,7 +23,7 @@ module type S = sig type te type parsable - val parsable : char Stream.t -> parsable + val parsable : ?loc:Loc.t -> char Stream.t -> parsable val tokens : string -> (string * int) list module Entry : sig diff --git a/gramlib/plexing.ml b/gramlib/plexing.ml index fce5445ad8..c294923a85 100644 --- a/gramlib/plexing.ml +++ b/gramlib/plexing.ml @@ -5,7 +5,7 @@ type pattern = string * string type location_function = int -> Loc.t -type 'te lexer_func = char Stream.t -> 'te Stream.t * location_function +type 'te lexer_func = ?loc:Loc.t -> char Stream.t -> 'te Stream.t * location_function type 'te lexer = { tok_func : 'te lexer_func; diff --git a/gramlib/plexing.mli b/gramlib/plexing.mli index 6139dc4020..f6e4d96b80 100644 --- a/gramlib/plexing.mli +++ b/gramlib/plexing.mli @@ -28,7 +28,7 @@ type 'te lexer = tok_match : pattern -> 'te -> string; tok_text : pattern -> string; } -and 'te lexer_func = char Stream.t -> 'te Stream.t * location_function +and 'te lexer_func = ?loc:Loc.t -> char Stream.t -> 'te Stream.t * location_function and location_function = int -> Loc.t (** The type of a function giving the location of a token in the source from the token number in the stream (starting from zero). *) diff --git a/ide/configwin.ml b/ide/configwin.ml index 24be721631..79a1eae880 100644 --- a/ide/configwin.ml +++ b/ide/configwin.ml @@ -37,8 +37,10 @@ type return_button = | Return_cancel let string = Configwin_ihm.string +(* let strings = Configwin_ihm.strings let list = Configwin_ihm.list +*) let bool = Configwin_ihm.bool let combo = Configwin_ihm.combo let custom = Configwin_ihm.custom diff --git a/ide/configwin.mli b/ide/configwin.mli index 0ee77d69b5..fa22846d19 100644 --- a/ide/configwin.mli +++ b/ide/configwin.mli @@ -69,6 +69,7 @@ val string : ?editable: bool -> ?expand: bool -> ?help: string -> val bool : ?editable: bool -> ?help: string -> ?f: (bool -> unit) -> string -> bool -> parameter_kind +(* (** [strings label value] creates a string list parameter. @param editable indicate if the value is editable (default is [true]). @param help an optional help message. @@ -119,6 +120,7 @@ val list : ?editable: bool -> ?help: string -> ('a -> string list) -> 'a list -> parameter_kind +*) (** [combo label choices value] creates a combo parameter. @param editable indicate if the value is editable (default is [true]). diff --git a/ide/configwin_ihm.ml b/ide/configwin_ihm.ml index 8420d930d5..0f3fd38a7a 100644 --- a/ide/configwin_ihm.ml +++ b/ide/configwin_ihm.ml @@ -27,6 +27,10 @@ open Configwin_types +let set_help_tip wev = function + | None -> () + | Some help -> GtkBase.Widget.Tooltip.set_text wev#as_widget help + let modifiers_to_string m = let rec iter m s = match m with @@ -55,7 +59,7 @@ class type widget = let debug = false let dbg s = if debug then Minilib.log s else () - +(* (** 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 @@ -71,7 +75,6 @@ class ['a] list_selection_box f_color (eq : 'a -> 'a -> bool) add_function title editable - (tt:GData.tooltips) = let _ = dbg "list_selection_box" in let wev = GBin.event_box () in @@ -94,12 +97,8 @@ class ['a] list_selection_box ~titles_show: true ~packing: wscroll#add () in - let _ = - match help_opt with - None -> () - | Some help -> - tt#set_tip ~text: help ~privat: help wev#coerce - in (* the vbox for the buttons *) + let _ = set_help_tip wev help_opt in + (* the vbox for the buttons *) let vbox_buttons = GPack.vbox () in let _ = if editable then @@ -279,10 +278,10 @@ class ['a] list_selection_box (* initialize the clist with the listref *) self#update !listref end;; - +*) (** This class is used to build a box for a string parameter.*) -class string_param_box param (tt:GData.tooltips) = +class string_param_box param = let _ = dbg "string_param_box" in let hbox = GPack.hbox () in let wev = GBin.event_box ~packing: (hbox#pack ~expand: false ~padding: 2) () in @@ -292,12 +291,7 @@ class string_param_box param (tt:GData.tooltips) = ~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 wev#coerce - in + let _ = set_help_tip wev param.string_help in let _ = we#set_text (param.string_to_string param.string_value) in object (self) @@ -316,17 +310,12 @@ class string_param_box param (tt:GData.tooltips) = end ;; (** This class is used to build a box for a combo parameter.*) -class combo_param_box param (tt:GData.tooltips) = +class combo_param_box param = let _ = dbg "combo_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.combo_label ~packing: wev#add () in - let _ = - match param.combo_help with - None -> () - | Some help -> - tt#set_tip ~text: help ~privat: help wev#coerce - in + let _ = set_help_tip wev param.combo_help in let get_value = if not param.combo_new_allowed then let wc = GEdit.combo_box_text ~strings: param.combo_choices @@ -341,13 +330,13 @@ class combo_param_box param (tt:GData.tooltips) = fun () -> match GEdit.text_combo_get_active wc with |None -> "" |Some s -> s else let (wc,_) = GEdit.combo_box_entry_text - ~strings: param.combo_choices - ~packing: (hbox#pack ~expand: param.combo_expand ~padding: 2) - () + ~strings: param.combo_choices + ~packing: (hbox#pack ~expand: param.combo_expand ~padding: 2) + () in let _ = wc#entry#set_editable param.combo_editable in let _ = wc#entry#set_text param.combo_value in - fun () -> wc#entry#text + fun () -> wc#entry#text in object (self) @@ -365,7 +354,7 @@ object (self) end ;; (** Class used to pack a custom box. *) -class custom_param_box param (tt:GData.tooltips) = +class custom_param_box param = let _ = dbg "custom_param_box" in let top = match param.custom_framed with @@ -381,7 +370,7 @@ class custom_param_box param (tt:GData.tooltips) = end (** This class is used to build a box for a text parameter.*) -class text_param_box param (tt:GData.tooltips) = +class text_param_box param = let _ = dbg "text_param_box" in let wf = GBin.frame ~label: param.string_label ~height: 100 () in let wev = GBin.event_box ~packing: wf#add () in @@ -395,12 +384,7 @@ class text_param_box param (tt:GData.tooltips) = ~packing: wscroll#add () in - let _ = - match param.string_help with - None -> () - | Some help -> - tt#set_tip ~text: help ~privat: help wev#coerce - in + let _ = set_help_tip wev param.string_help in let _ = dbg "text_param_box: buffer creation" in let buffer = GText.buffer () in @@ -427,17 +411,13 @@ class text_param_box param (tt:GData.tooltips) = end ;; (** This class is used to build a box for a boolean parameter.*) -class bool_param_box param (tt:GData.tooltips) = +class bool_param_box param = let _ = dbg "bool_param_box" in let wchk = GButton.check_button ~label: param.bool_label () in - let _ = - match param.bool_help with - None -> () - | Some help -> tt#set_tip ~text: help ~privat: help wchk#coerce - in + let _ = set_help_tip wchk param.bool_help in let _ = wchk#set_active param.bool_value in let _ = wchk#misc#set_sensitive param.bool_editable in @@ -471,14 +451,7 @@ class modifiers_param_box param = else value := List.filter ((<>) modifier) !value))) param.md_allow in - let _ = - match param.md_help with - None -> () - | Some help -> - let tooltips = GData.tooltips () in - ignore (hbox#connect#destroy ~callback: tooltips#destroy); - tooltips#set_tip wev#coerce ~text: help ~privat: help - in + let _ = set_help_tip wev param.md_help in object (self) (** This method returns the main box ready to be packed. *) @@ -493,9 +466,9 @@ class modifiers_param_box param = 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) = +class ['a] list_param_box (param : 'a list_param) = let _ = dbg "list_param_box" in let listref = ref param.list_value in let frame_selection = new list_selection_box @@ -520,9 +493,10 @@ class ['a] list_param_box (param : 'a list_param) (tt:GData.tooltips) = param.list_f_apply !listref ; param.list_value <- !listref end ;; +*) (** This class creates a configuration box from a configuration structure *) -class configuration_box (tt : GData.tooltips) conf_struct = +class configuration_box conf_struct = let main_box = GPack.hbox () in @@ -553,27 +527,27 @@ class configuration_box (tt : GData.tooltips) conf_struct = let make_param (main_box : #GPack.box) = function | String_param p -> - let box = new string_param_box p tt in + let box = new string_param_box p 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 box = new combo_param_box p 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 box = new text_param_box p 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 box = new bool_param_box p in let _ = main_box#pack ~expand: false ~padding: 2 box#box in box | List_param f -> - let box = f tt in + let box = f () 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 box = new custom_param_box p in let _ = main_box#pack ~expand: p.custom_expand ~padding: 2 box#box in box | Modifiers_param p -> @@ -684,11 +658,9 @@ let edit ?(with_apply=true) ?parent ?height ?width () in - let tooltips = GData.tooltips () in - - let config_box = new configuration_box tooltips conf_struct in + let config_box = new configuration_box conf_struct in - let _ = dialog#vbox#add config_box#box#coerce in + let _ = dialog#vbox#pack ~expand:true config_box#box#coerce in if with_apply then dialog#add_button Configwin_messages.mApply `APPLY; @@ -697,7 +669,6 @@ let edit ?(with_apply=true) dialog#add_button Configwin_messages.mCancel `CANCEL; let destroy () = - tooltips#destroy () ; dialog#destroy (); in let rec iter rep = @@ -714,10 +685,12 @@ let edit ?(with_apply=true) in iter Return_cancel +(* let edit_string l s = match GToolbox.input_string ~title: l ~text: s Configwin_messages.mValue with None -> s | Some s2 -> s2 +*) (** Create a string param. *) let string ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v = @@ -744,6 +717,7 @@ let bool ?(editable=true) ?help ?(f=(fun _ -> ())) label v = bool_f_apply = f ; } +(* (** Create a list param. *) let list ?(editable=true) ?help ?(f=(fun (_:'a list) -> ())) @@ -753,7 +727,7 @@ let list ?(editable=true) ?help ?titles ?(color=(fun (_:'a) -> (None : string option))) label (f_strings : 'a -> string list) v = List_param - (fun tt -> + (fun () -> new list_param_box { list_label = label ; @@ -768,7 +742,6 @@ let list ?(editable=true) ?help list_f_add = add ; list_f_apply = f ; } - tt ) (** Create a strings param. *) @@ -777,6 +750,7 @@ let strings ?(editable=true) ?help ?(eq=Pervasives.(=)) ?(add=(fun () -> [])) label v = list ~editable ?help ~f ~eq ~edit: (edit_string label) ~add label (fun s -> [s]) v +*) (** Create a combo param. *) let combo ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) diff --git a/ide/configwin_ihm.mli b/ide/configwin_ihm.mli index 772a0958ff..ce6cd4d7c1 100644 --- a/ide/configwin_ihm.mli +++ b/ide/configwin_ihm.mli @@ -29,6 +29,7 @@ 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) -> @@ -45,6 +46,7 @@ val list : ?editable: bool -> ?help: 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 -> diff --git a/ide/configwin_types.ml b/ide/configwin_types.ml index 9e339d135d..251e3dded3 100644 --- a/ide/configwin_types.ml +++ b/ide/configwin_types.ml @@ -97,7 +97,7 @@ type modifiers_param = { (** This type represents the different kinds of parameters. *) type parameter_kind = String_param of string string_param - | List_param of (GData.tooltips -> <box: GObj.widget ; apply : unit>) + | List_param of (unit -> <box: GObj.widget ; apply : unit>) | Bool_param of bool_param | Text_param of string string_param | Combo_param of combo_param diff --git a/ide/coq.ml b/ide/coq.ml index e7eea4ced2..a420a3cbf5 100644 --- a/ide/coq.ml +++ b/ide/coq.ml @@ -128,16 +128,15 @@ and asks_for_coqtop args = let () = pb_mes#destroy () in filter_coq_opts args | `DELETE_EVENT | `NO -> - let () = pb_mes#destroy () in - let cmd_sel = GWindow.file_selection + let file = select_file_for_open ~title:"coqidetop to execute (edit your preference then)" - ~filename:(coqtop_path ()) ~urgency_hint:true () in - match cmd_sel#run () with - | `OK -> - let () = custom_coqtop := (Some cmd_sel#filename) in - let () = cmd_sel#destroy () in + ~filter:false + ~filename:(coqtop_path ()) () in + match file with + | Some _ -> + let () = custom_coqtop := file in filter_coq_opts args - | `CANCEL | `DELETE_EVENT | `HELP -> exit 0 + | None -> exit 0 exception WrongExitStatus of string diff --git a/ide/coqide.ml b/ide/coqide.ml index 94778e0c60..aa9e150fd5 100644 --- a/ide/coqide.ml +++ b/ide/coqide.ml @@ -193,7 +193,7 @@ let confirm_save ok = let select_and_save ?parent ~saveas ?filename sn = let do_save = if saveas then sn.fileops#saveas ?parent else sn.fileops#save in let title = if saveas then "Save file as" else "Save file" in - match select_file_for_save ~title ?filename () with + match select_file_for_save ~title ?parent ?filename () with |None -> false |Some f -> let ok = do_save f in @@ -213,7 +213,8 @@ let check_save ?parent ~saveas sn = exception DontQuit let check_quit ?parent saveall = - (try save_pref () with _ -> flash_info "Cannot save preferences"); + (try save_pref () + with e -> flash_info ("Cannot save preferences (" ^ Printexc.to_string e ^ ")")); let is_modified sn = sn.buffer#modified in if List.exists is_modified notebook#pages then begin let answ = Configwin_ihm.question_box ~title:"Quit" @@ -271,11 +272,11 @@ let newfile _ = let index = notebook#append_term session in notebook#goto_page index -let load _ = +let load ?parent _ = let filename = try notebook#current_term.fileops#filename with Invalid_argument _ -> None in - match select_file_for_open ~title:"Load file" ?filename () with + match select_file_for_open ~title:"Load file" ?parent ?filename () with | None -> () | Some f -> FileAux.load_file f @@ -359,7 +360,7 @@ let print sn = Filename.quote (Filename.basename f_name) ^ " | " ^ cmd_print#get in let w = GWindow.window ~title:"Print" ~modal:true - ~position:`CENTER ~wm_class:"CoqIDE" ~wm_name: "CoqIDE" () + ~position:`CENTER ~wmclass:("CoqIDE","CoqIDE") () in let v = GPack.vbox ~spacing:10 ~border_width:10 ~packing:w#add () in @@ -453,7 +454,7 @@ let compile sn = |None -> flash_info "Active buffer has no name" |Some f -> let args = Coq.get_arguments sn.coqtop in - let cmd = cmd_coqc#get + let cmd = cmd_coqc#get ^ " " ^ String.concat " " args ^ " " ^ (Filename.quote f) ^ " 2>&1" in @@ -766,6 +767,10 @@ let about _ = dialog#set_authors authors; dialog#show () +let apply_unicode_binding = + cb_on_current_term (fun t -> + t.script#apply_unicode_binding()) + let comment = cb_on_current_term (fun t -> t.script#comment ()) let uncomment = cb_on_current_term (fun t -> t.script#uncomment ()) @@ -812,7 +817,7 @@ let zoom_fit sn = let space = script#misc#allocation.Gtk.width in let cols = script#right_margin_position in let pango_ctx = script#misc#pango_context in - let layout = pango_ctx#create_layout in + let layout = pango_ctx#create_layout#as_layout in let fsize = Pango.Font.get_size (Pango.Font.from_string text_font#get) in Pango.Layout.set_text layout (String.make cols 'X'); let tlen = fst (Pango.Layout.get_pixel_size layout) in @@ -939,7 +944,7 @@ let emit_to_focus window sgn = let build_ui () = let w = GWindow.window - ~wm_class:"CoqIde" ~wm_name:"CoqIde" + ~wmclass:("CoqIde","CoqIde") ~width:window_width#get ~height:window_height#get ~title:"CoqIde" () in @@ -972,7 +977,7 @@ let build_ui () = menu file_menu [ item "File" ~label:"_File"; item "New" ~callback:File.newfile ~stock:`NEW; - item "Open" ~callback:File.load ~stock:`OPEN; + item "Open" ~callback:(File.load ~parent:w) ~stock:`OPEN; item "Save" ~callback:(File.save ~parent:w) ~stock:`SAVE ~tooltip:"Save current buffer"; item "Save as" ~label:"S_ave as" ~stock:`SAVE_AS ~callback:(File.saveas ~parent:w); item "Save all" ~label:"Sa_ve all" ~callback:File.saveall; @@ -1021,7 +1026,8 @@ let build_ui () = ~callback:(fun _ -> begin try Preferences.configure ~apply:refresh_notebook_pos w - with _ -> flash_info "Cannot save preferences" + with e -> + flash_info ("Editing preferences failed (" ^ Printexc.to_string e ^ ")") end; reset_revert_timer ()); ]; @@ -1161,6 +1167,8 @@ let build_ui () = ~callback:MiscMenu.uncomment; item "Coqtop arguments" ~label:"Coqtop _arguments" ~callback:MiscMenu.coqtop_arguments; + item "LaTeX-to-unicode" ~label:"_LaTeX-to-unicode" ~accel:"<Shift>space" + ~callback:MiscMenu.apply_unicode_binding; ]; menu compile_menu [ @@ -1220,10 +1228,10 @@ let build_ui () = ((Coqide_ui.ui_m#get_widget "/CoqIde ToolBar")#as_widget) in let () = GtkButton.Toolbar.set - ~orientation:`HORIZONTAL ~style:`ICONS ~tooltips:true tbar + ~orientation:`HORIZONTAL ~style:`ICONS tbar in - let toolbar = new GObj.widget tbar in - let () = vbox#pack toolbar in + let toolbar = new GButton.toolbar tbar in + let () = vbox#pack toolbar#coerce in (* Emacs/PG mode *) NanoPG.init w notebook all_menus; @@ -1303,11 +1311,6 @@ let build_ui () = let _ = source_style#connect#changed ~callback:refresh_style in let _ = source_language#connect#changed ~callback:refresh_language in - (* Color configuration *) - Tags.Script.incomplete#set_property - (`BACKGROUND_STIPPLE - (Gdk.Bitmap.create_from_data ~width:2 ~height:2 "\x01\x02")); - (* Showtime ! *) w#show (); w @@ -1347,9 +1350,12 @@ let main files = this default coqtop path *) let read_coqide_args argv = - let rec filter_coqtop coqtop project_files out = function + let rec filter_coqtop coqtop project_files bindings_files out = function + |"-unicode-bindings" :: sfilenames :: args -> + let filenames = Str.split (Str.regexp ",") sfilenames in + filter_coqtop coqtop project_files (filenames @ bindings_files) out args |"-coqtop" :: prog :: args -> - if coqtop = None then filter_coqtop (Some prog) project_files out args + if coqtop = None then filter_coqtop (Some prog) project_files bindings_files out args else (output_string stderr "Error: multiple -coqtop options"; exit 1) |"-f" :: file :: args -> if project_files <> None then @@ -1357,7 +1363,7 @@ let read_coqide_args argv = let d = CUnix.canonical_path_name (Filename.dirname file) in let warning_fn x = Format.eprintf "%s@\n%!" x in let p = CoqProject_file.read_project_file ~warning_fn file in - filter_coqtop coqtop (Some (d,p)) out args + filter_coqtop coqtop (Some (d,p)) out bindings_files args |"-f" :: [] -> output_string stderr "Error: missing project file name"; exit 1 |"-coqtop" :: [] -> @@ -1366,19 +1372,20 @@ let read_coqide_args argv = Minilib.debug := true; Flags.debug := true; Backtrace.record_backtrace true; - filter_coqtop coqtop project_files ("-debug"::out) args + filter_coqtop coqtop project_files bindings_files ("-debug"::out) args |"-coqtop-flags" :: flags :: args-> Coq.ideslave_coqtop_flags := Some flags; - filter_coqtop coqtop project_files out args + filter_coqtop coqtop project_files bindings_files out args |arg::args when out = [] && Minilib.is_prefix_of "-psn_" arg -> (* argument added by MacOS during .app launch *) - filter_coqtop coqtop project_files out args - |arg::args -> filter_coqtop coqtop project_files (arg::out) args - |[] -> (coqtop,project_files,List.rev out) + filter_coqtop coqtop project_files bindings_files out args + |arg::args -> filter_coqtop coqtop project_files bindings_files (arg::out) args + |[] -> (coqtop,project_files,bindings_files,List.rev out) in - let coqtop,project_files,argv = filter_coqtop None None [] argv in + let coqtop,project_files,bindings_files,argv = filter_coqtop None None [] [] argv in Ideutils.custom_coqtop := coqtop; custom_project_file := project_files; + Unicode_bindings.load_files bindings_files; argv diff --git a/ide/coqide_main.ml b/ide/coqide_main.ml index 21f513b8f4..79420b3857 100644 --- a/ide/coqide_main.ml +++ b/ide/coqide_main.ml @@ -8,7 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -let _ = GtkMain.Main.init () +let _ = Coqide.set_signal_handlers () (* We handle Gtk warning messages ourselves : - on win32, we don't want them to end on a non-existing console diff --git a/ide/coqide_ui.ml b/ide/coqide_ui.ml index c994898a4f..d4a339f4f5 100644 --- a/ide/coqide_ui.ml +++ b/ide/coqide_ui.ml @@ -140,6 +140,8 @@ let init () = \n <menuitem action='Uncomment' />\ \n <separator />\ \n <menuitem action='Coqtop arguments' />\ +\n <separator />\ +\n <menuitem action='LaTeX-to-unicode' />\ \n </menu>\ \n <menu action='Compile'>\ \n <menuitem action='Compile buffer' />\ diff --git a/ide/default_bindings_src.ml b/ide/default_bindings_src.ml new file mode 100644 index 0000000000..85a635a50f --- /dev/null +++ b/ide/default_bindings_src.ml @@ -0,0 +1,2899 @@ +(** Usage + ocamlc default_bindings_src.ml -o generator.out + ./generator.out output_filename +*) + +(** **************************************************************************) +(** * Classifiers *) + +(** Note: for future use *) + +let logic = "logic" +let symbol = "symbols" +let fraction = "fractions" +let letter = "letters" +let greek_letter = "greek letter" +let asciiart = "ASCII art" +let equivalence = "equivalence relations" +let order = "order relations" +let circle = "circles" +let square = "squares" +let triangle = "triangles" +let arrow = "arrows" +let set = "set theory" +let math = "mathematics" +let space = "spaces" +let delimiter = "parentheses and delimiters" +let miscellanea = "miscellanea" + + +(** **************************************************************************) +(** * Bindings set 1 *) + +let bindings_set_1 = [ + +(* {{{ logics *) + ["\\not"; "\\neg"; "\\lnot" ], "¬", [logic]; + ["\\ForAll"; "\\forall" ], "∀", [logic]; + ["\\exist"; "\\Exists"; "\\exists" ], "∃", [logic]; + ["\\nexist"; "\\nexists"; "\\NotExists" ], "∄", [logic]; + ["\\and"; "\\land"; "\\wedge" ], "∧", [logic]; + ["\\or"; "\\vee"; "\\lor" ], "∨", [logic]; + ["\\vdash"; "\\RightTee" ], "⊢", [logic]; + ["\\dashv"; "\\LeftTee" ], "⊣", [logic]; + ["\\top"; "\\DownTee" ], "⊤", [logic]; + ["\\bot"; "\\perp"; "\\UpTee"; "\\bottom" ], "⊥", [logic]; + ["\\models" ], "⊧", [logic]; + ["\\vDash"; "\\DoubleRightTee" ], "⊨", [logic]; + ["\\Vdash" ], "⊩", [logic]; + ["\\Vvdash" ], "⊪", [logic]; + ["\\VDash" ], "⊫", [logic]; + ["\\nvdash" ], "⊬", [logic]; + ["\\nvDash" ], "⊭", [logic]; + ["\\nVdash" ], "⊮", [logic]; + ["\\nVDash" ], "⊯", [logic]; + ["\\Wedge"; "\\xwedge"; "\\bigwedge" ], "⋀", [logic]; + ["\\Vee"; "\\xvee"; "\\bigvee" ], "⋁", [logic]; +(* }}} *) + +(* {{{ symbols *) + ["\\cent" ], "¢", [symbol]; + ["\\pound" ], "£", [symbol]; + ["\\curren" ], "¤", [symbol]; + ["\\yen" ], "¥", [symbol]; + ["\\brvbar" ], "¦", [symbol]; + ["\\sect" ], "§", [symbol]; + ["\\uml"; "\\die"; "\\Dot"; "\\DoubleDot" ], "¨", [symbol]; + ["\\macr"; "\\OverBar" ], "¯", [symbol]; + ["\\sup" ], "^", [symbol]; + ["\\sup2" ], "²", [symbol]; + ["\\sup3" ], "³", [symbol]; + ["\\acute"; "\\DiacriticalAcute" ], "´", [symbol]; + ["\\para" ], "¶", [symbol]; + ["\\middot"; "\\centerdot"; "\\CenterDot" ], "·", [symbol]; + ["\\cedil"; "\\Cedilla" ], "¸", [symbol]; + ["\\sup1" ], "¹", [symbol]; + ["\\iquest" ], "¿", [symbol]; + ["\\thorn" ], "þ", [symbol]; + ["\\imath"; "\\inodot" ], "ı", [symbol]; + ["\\Hacek"; "\\caron" ], "ˇ", [symbol]; + ["\\Breve"; "\\breve" ], "˘", [symbol]; + ["\\dot"; "\\DiacriticalDot" ], "˙", [symbol]; + ["\\ogon" ], "˛", [symbol]; + ["\\tilde"; "\\DiacriticalTilde" ], "˜", [symbol]; + ["\\dblac"; "\\DiacriticalDoubleAcute" ], "˝", [symbol]; + ["\\Hat" ], "̂", [symbol]; + ["\\DownBreve" ], "̑", [symbol]; + ["\\UnderBar" ], "̲", [symbol]; + ["\\dash"; "\\hyphen" ], "‐", [symbol]; + ["\\ndash" ], "–", [symbol]; + ["\\mdash" ], "—", [symbol]; + ["\\horbar" ], "―", [symbol]; + ["\\Vert"; "\\Verbar" ], "‖", [symbol]; + ["\\lsquo"; "\\OpenCurlyQuote" ], "‘", [symbol]; + ["\\rsquo"; "\\rsquor"; "\\CloseCurlyQuote" ], "’", [symbol]; + ["\\lsquor" ], "‚", [symbol]; + ["\\ldquo"; "\\OpenCurlyDoubleQuote" ], "“", [symbol]; + ["\\rdquo"; "\\rdquor"; "\\CloseCurlyDoubleQuote" ], "”", [symbol]; + ["\\ldquor" ], "„", [symbol]; + ["\\dagger" ], "†", [symbol]; + ["\\Dagger"; "\\ddagger" ], "‡", [symbol]; + ["\\nldr" ], "‥", [symbol]; + ["\\mldr"; "\\dots"; "\\ldots"; "\\hellip" ], "…", [symbol]; + ["\\prime" ], "′", [symbol]; + ["\\Prime" ], "″", [symbol]; + ["\\tprime" ], "‴", [symbol]; + ["\\bprime"; "\\backprime" ], "‵", [symbol]; + ["\\caret" ], "⁁", [symbol]; + ["\\hybull" ], "⁃", [symbol]; + ["\\bsemi" ], "⁏", [symbol]; + ["\\qprime" ], "⁗", [symbol]; + ["\\MediumSpace" ], " ", [symbol]; + ["\\tdot"; "\\TripleDot" ], "⃛", [symbol]; + ["\\DotDot" ], "⃜", [symbol]; + ["\\minus" ], "−", [symbol]; + ["\\angrt" ], "∟", [symbol]; + ["\\ang"; "\\angle" ], "∠", [symbol]; + ["\\nang" ], "∠̸", [symbol]; + ["\\angmsd"; "\\measuredangle" ], "∡", [symbol]; + ["\\angsph" ], "∢", [symbol]; + ["\\par"; "\\parallel"; "\\DoubleVerticalBar" ], "∥", [symbol]; + ["\\there4"; "\\Therefore"; "\\therefore" ], "∴", [symbol]; + ["\\becaus"; "\\because"; "\\Because" ], "∵", [symbol]; + ["\\ratio" ], "∶", [symbol]; + ["\\Colon"; "\\Proportion" ], "∷", [symbol]; + ["\\minusd"; "\\dotminus" ], "∸", [symbol]; + ["\\mDDot" ], "∺", [symbol]; + ["\\homtht" ], "∻", [symbol]; + ["\\sim"; "\\Tilde" ], "∼", [symbol]; + ["\\mstpos" ], "∾", [symbol]; + ["\\acd" ], "∿", [symbol]; + ["\\wr"; "\\wreath"; "\\VerticalTilde" ], "≀", [symbol]; + ["\\origof" ], "⊶", [symbol]; + ["\\imof" ], "⊷", [symbol]; + ["\\mumap"; "\\multimap" ], "⊸", [symbol]; + ["\\hercon" ], "⊹", [symbol]; + ["\\intcal"; "\\intercal" ], "⊺", [symbol]; + ["\\veebar" ], "⊻", [symbol]; + ["\\barwed"; "\\barwedge" ], "⊼", [symbol]; + ["\\barvee" ], "⊽", [symbol]; + ["\\vangrt" ], "⊾", [symbol]; + ["\\lrtri" ], "⊿", [symbol]; + ["\\diam"; "\\Diamond"; "\\diamond" ], "⋄", [symbol]; + ["\\sdot" ], "⋅", [symbol]; + ["\\Star"; "\\star"; "\\sstarf" ], "⋆", [symbol]; + ["\\divonx"; "\\divideontimes" ], "⋇", [symbol]; + ["\\bowtie" ], "⋈", [symbol]; + ["\\ltimes" ], "⋉", [symbol]; + ["\\rtimes" ], "⋊", [symbol]; + ["\\lthree"; "\\leftthreetimes" ], "⋋", [symbol]; + ["\\rthree"; "\\rightthreetimes" ], "⋌", [symbol]; + ["\\cuvee"; "\\curlyvee" ], "⋎", [symbol]; + ["\\cuwed"; "\\curlywedge" ], "⋏", [symbol]; + ["\\fork"; "\\pitchfork" ], "⋔", [symbol]; + ["\\epar" ], "⋕", [symbol]; + ["\\vdots"; "\\vellip" ], "⋮", [symbol]; + ["\\cdots"; "\\ctdot" ], "⋯", [symbol]; + ["\\utdot" ], "⋰", [symbol]; + ["\\ddots"; "\\dtdot" ], "⋱", [symbol]; + ["\\Barwed"; "\\doublebarwedge" ], "⌆", [symbol]; + ["\\bnot" ], "⌐", [symbol]; + ["\\profline" ], "⌒", [symbol]; + ["\\profsurf" ], "⌓", [symbol]; + ["\\telrec" ], "⌕", [symbol]; + ["\\frown" ], "⌢", [symbol]; + ["\\smile" ], "⌣", [symbol]; + ["\\blank" ], "␣", [symbol]; + ["\\HorizontalLine" ], "─", [symbol]; + ["\\loz"; "\\lozenge" ], "◊", [symbol]; + ["\\starf"; "\\bigstar" ], "★", [symbol]; + ["\\phone" ], "☎", [symbol]; + ["\\female" ], "♀", [symbol]; + ["\\male" ], "♂", [symbol]; + ["\\spades"; "\\spadesuit" ], "♠", [symbol]; + ["\\heartsuit" ], "♡", [symbol]; + ["\\diamondsuit" ], "♢", [symbol]; + ["\\clubs"; "\\clubsuit" ], "♣", [symbol]; + ["\\diams" ], "♦", [symbol]; + ["\\sung" ], "♪", [symbol]; + ["\\flat" ], "♭", [symbol]; + ["\\natur"; "\\natural" ], "♮", [symbol]; + ["\\sharp" ], "♯", [symbol]; + ["\\check"; "\\checkmark" ], "✓", [symbol]; + ["\\cross" ], "✗", [symbol]; + ["\\malt"; "\\maltese" ], "✠", [symbol]; + ["\\sext" ], "✶", [symbol]; + ["\\VerticalSeparator" ], "❘", [symbol]; + ["\\lozf"; "\\blacklozenge" ], "⧫", [symbol]; + ["\\OverParenthesis" ], "︵", [symbol]; + ["\\UnderParenthesis" ], "︶", [symbol]; + ["\\OverBrace" ], "︷", [symbol]; + ["\\UnderBrace" ], "︸", [symbol]; + ["\\Yang" ], "⚊", [symbol]; +(* }}} *) + +(* {{{ fraction *) + ["\\frac14" ], "¼", [fraction]; + ["\\half"; "\\frac" ], "½", [fraction]; + ["\\frac34" ], "¾", [fraction]; + ["\\permil" ], "‰", [fraction]; + ["\\pertenk" ], "‱", [fraction]; + ["\\incare" ], "℅", [fraction]; + ["\\frac13" ], "⅓", [fraction]; + ["\\frac23" ], "⅔", [fraction]; + ["\\frac15" ], "⅕", [fraction]; + ["\\frac25" ], "⅖", [fraction]; + ["\\frac35" ], "⅗", [fraction]; + ["\\frac45" ], "⅘", [fraction]; + ["\\frac16" ], "⅙", [fraction]; + ["\\frac56" ], "⅚", [fraction]; + ["\\frac18" ], "⅛", [fraction]; + ["\\frac38" ], "⅜", [fraction]; + ["\\frac58" ], "⅝", [fraction]; + ["\\frac78" ], "⅞", [fraction]; +(* }}} *) + +(* {{{ greek letters *) + ["\\alpha" ], "α", [greek_letter]; + ["\\beta" ], "β", [greek_letter]; + ["\\gamma" ], "γ", [greek_letter]; + ["\\delta" ], "δ", [greek_letter]; + ["\\epsilon" ], "ϵ", [greek_letter]; + ["\\varepsilon"; "\\straightepsilon" ], "ε", [greek_letter]; + ["\\epsiv" ], "ɛ", [greek_letter]; + ["\\bepsi"; "\\backepsilon" ], "϶", [greek_letter]; + ["\\zeta" ], "ζ", [greek_letter]; + ["\\eta" ], "η", [greek_letter]; + ["\\theta" ], "θ", [greek_letter]; + ["\\vartheta" ], "ϑ", [greek_letter]; + ["\\iota" ], "ι", [greek_letter]; + ["\\kappa" ], "κ", [greek_letter]; + ["\\varkappa" ], "ϰ", [greek_letter]; + ["\\lambda" ], "λ", [greek_letter]; + ["\\mu" ], "μ", [greek_letter]; + ["\\nu" ], "ν", [greek_letter]; + ["\\xi" ], "ξ", [greek_letter]; + ["\\o" ], "ο", [greek_letter]; + ["\\pi" ], "π", [greek_letter]; + ["\\varpi" ], "ϖ", [greek_letter]; + ["\\rho" ], "ρ", [greek_letter]; + ["\\varrho" ], "ϱ", [greek_letter]; + ["\\sigma" ], "σ", [greek_letter]; + ["\\varsigma" ], "ς", [greek_letter]; + ["\\tau" ], "τ", [greek_letter]; + ["\\upsilon" ], "υ", [greek_letter]; + ["\\phi" ], "ϕ", [greek_letter]; + ["\\varphi"; "\\straightphi" ], "φ", [greek_letter]; + ["\\chi" ], "χ", [greek_letter]; + ["\\psi" ], "ψ", [greek_letter]; + ["\\omega" ], "ω", [greek_letter]; + ["\\Gamma" ], "Γ", [greek_letter]; + ["\\Gammad"; "\\gammad"; "\\digamma" ], "Ϝ", [greek_letter]; + ["\\Delta" ], "Δ", [greek_letter]; + ["\\Theta" ], "Θ", [greek_letter]; + ["\\Lambda" ], "Λ", [greek_letter]; + ["\\Xi" ], "Ξ", [greek_letter]; + ["\\Pi" ], "Π", [greek_letter]; + ["\\Sigma" ], "Σ", [greek_letter]; + ["\\Upsilon" ], "ϒ", [greek_letter]; + ["\\Phi" ], "Φ", [greek_letter]; + ["\\Psi" ], "Ψ", [greek_letter]; + ["\\Omega" ], "Ω", [greek_letter]; +(* }}} *) + +(* {{{ letters *) + ["\\iexcl" ], "¡", [letter]; + ["\\ordf" ], "ª", [letter]; + ["\\micro" ], "µ", [letter]; + ["\\Agrave" ], "À", [letter]; + ["\\Aacute" ], "Á", [letter]; + ["\\Acirc" ], "Â", [letter]; + ["\\Atilde" ], "Ã", [letter]; + ["\\Auml" ], "Ä", [letter]; + ["\\Aring" ], "Å", [letter]; + ["\\AElig" ], "Æ", [letter]; + ["\\Ccedil" ], "Ç", [letter]; + ["\\Egrave" ], "È", [letter]; + ["\\Eacute" ], "É", [letter]; + ["\\Ecirc" ], "Ê", [letter]; + ["\\Euml" ], "Ë", [letter]; + ["\\Igrave" ], "Ì", [letter]; + ["\\Iacute" ], "Í", [letter]; + ["\\Icirc" ], "Î", [letter]; + ["\\Iuml" ], "Ï", [letter]; + ["\\ETH" ], "Ð", [letter]; + ["\\Ntilde" ], "Ñ", [letter]; + ["\\Ograve" ], "Ò", [letter]; + ["\\Oacute" ], "Ó", [letter]; + ["\\Ocirc" ], "Ô", [letter]; + ["\\Otilde" ], "Õ", [letter]; + ["\\Ouml" ], "Ö", [letter]; + ["\\Oslash" ], "Ø", [letter]; + ["\\Ugrave" ], "Ù", [letter]; + ["\\Uacute" ], "Ú", [letter]; + ["\\Ucirc" ], "Û", [letter]; + ["\\Uuml" ], "Ü", [letter]; + ["\\Yacute" ], "Ý", [letter]; + ["\\THORN" ], "Þ", [letter]; + ["\\szlig" ], "ß", [letter]; + ["\\agrave" ], "à", [letter]; + ["\\aacute" ], "á", [letter]; + ["\\acirc" ], "â", [letter]; + ["\\atilde" ], "ã", [letter]; + ["\\auml" ], "ä", [letter]; + ["\\aring" ], "å", [letter]; + ["\\aelig" ], "æ", [letter]; + ["\\ccedil" ], "ç", [letter]; + ["\\egrave" ], "è", [letter]; + ["\\eacute" ], "é", [letter]; + ["\\ecirc" ], "ê", [letter]; + ["\\euml" ], "ë", [letter]; + ["\\igrave" ], "ì", [letter]; + ["\\iacute" ], "í", [letter]; + ["\\icirc" ], "î", [letter]; + ["\\iuml" ], "ï", [letter]; + ["\\eth" ], "ð", [letter]; + ["\\ntilde" ], "ñ", [letter]; + ["\\ograve" ], "ò", [letter]; + ["\\oacute" ], "ó", [letter]; + ["\\ocirc" ], "ô", [letter]; + ["\\otilde" ], "õ", [letter]; + ["\\ouml" ], "ö", [letter]; + ["\\ugrave" ], "ù", [letter]; + ["\\uacute" ], "ú", [letter]; + ["\\ucirc" ], "û", [letter]; + ["\\uuml" ], "ü", [letter]; + ["\\yacute" ], "ý", [letter]; + ["\\yuml" ], "ÿ", [letter]; + ["\\Amacr" ], "Ā", [letter]; + ["\\amacr" ], "ā", [letter]; + ["\\Abreve" ], "Ă", [letter]; + ["\\abreve" ], "ă", [letter]; + ["\\Aogon" ], "Ą", [letter]; + ["\\aogon" ], "ą", [letter]; + ["\\Cacute" ], "Ć", [letter]; + ["\\cacute" ], "ć", [letter]; + ["\\Ccirc" ], "Ĉ", [letter]; + ["\\ccirc" ], "ĉ", [letter]; + ["\\Cdot" ], "Ċ", [letter]; + ["\\cdot" ], "ċ", [letter]; + ["\\Ccaron" ], "Č", [letter]; + ["\\ccaron" ], "č", [letter]; + ["\\Dcaron" ], "Ď", [letter]; + ["\\dcaron" ], "ď", [letter]; + ["\\Dstrok" ], "Đ", [letter]; + ["\\dstrok" ], "đ", [letter]; + ["\\Emacr" ], "Ē", [letter]; + ["\\emacr" ], "ē", [letter]; + ["\\Edot" ], "Ė", [letter]; + ["\\edot" ], "ė", [letter]; + ["\\Eogon" ], "Ę", [letter]; + ["\\eogon" ], "ę", [letter]; + ["\\Ecaron" ], "Ě", [letter]; + ["\\ecaron" ], "ě", [letter]; + ["\\Gcirc" ], "Ĝ", [letter]; + ["\\gcirc" ], "ĝ", [letter]; + ["\\Gbreve" ], "Ğ", [letter]; + ["\\gbreve" ], "ğ", [letter]; + ["\\Gdot" ], "Ġ", [letter]; + ["\\gdot" ], "ġ", [letter]; + ["\\Gcedil" ], "Ģ", [letter]; + ["\\Hcirc" ], "Ĥ", [letter]; + ["\\hcirc" ], "ĥ", [letter]; + ["\\Hstrok" ], "Ħ", [letter]; + ["\\hstrok" ], "ħ", [letter]; + ["\\Itilde" ], "Ĩ", [letter]; + ["\\itilde" ], "ĩ", [letter]; + ["\\Imacr" ], "Ī", [letter]; + ["\\imacr" ], "ī", [letter]; + ["\\Iogon" ], "Į", [letter]; + ["\\iogon" ], "į", [letter]; + ["\\Idot" ], "İ", [letter]; + ["\\IJlig" ], "IJ", [letter]; + ["\\ijlig" ], "ij", [letter]; + ["\\Jcirc" ], "Ĵ", [letter]; + ["\\jcirc" ], "ĵ", [letter]; + ["\\Kcedil" ], "Ķ", [letter]; + ["\\kcedil" ], "ķ", [letter]; + ["\\kgreen" ], "ĸ", [letter]; + ["\\Lacute" ], "Ĺ", [letter]; + ["\\lacute" ], "ĺ", [letter]; + ["\\Lcedil" ], "Ļ", [letter]; + ["\\lcedil" ], "ļ", [letter]; + ["\\Lcaron" ], "Ľ", [letter]; + ["\\lcaron" ], "ľ", [letter]; + ["\\Lmidot" ], "Ŀ", [letter]; + ["\\lmidot" ], "ŀ", [letter]; + ["\\Lstrok" ], "Ł", [letter]; + ["\\lstrok" ], "ł", [letter]; + ["\\Nacute" ], "Ń", [letter]; + ["\\nacute" ], "ń", [letter]; + ["\\Ncedil" ], "Ņ", [letter]; + ["\\ncedil" ], "ņ", [letter]; + ["\\Ncaron" ], "Ň", [letter]; + ["\\ncaron" ], "ň", [letter]; + ["\\napos" ], "ʼn", [letter]; + ["\\ENG" ], "Ŋ", [letter]; + ["\\eng" ], "ŋ", [letter]; + ["\\Omacr" ], "Ō", [letter]; + ["\\omacr" ], "ō", [letter]; + ["\\Odblac" ], "Ő", [letter]; + ["\\odblac" ], "ő", [letter]; + ["\\OElig" ], "Œ", [letter]; + ["\\oelig" ], "œ", [letter]; + ["\\Racute" ], "Ŕ", [letter]; + ["\\racute" ], "ŕ", [letter]; + ["\\Rcedil" ], "Ŗ", [letter]; + ["\\rcedil" ], "ŗ", [letter]; + ["\\Rcaron" ], "Ř", [letter]; + ["\\rcaron" ], "ř", [letter]; + ["\\Sacute" ], "Ś", [letter]; + ["\\sacute" ], "ś", [letter]; + ["\\Scirc" ], "Ŝ", [letter]; + ["\\scirc" ], "ŝ", [letter]; + ["\\Scedil" ], "Ş", [letter]; + ["\\scedil" ], "ş", [letter]; + ["\\Scaron" ], "Š", [letter]; + ["\\scaron" ], "š", [letter]; + ["\\Tcedil" ], "Ţ", [letter]; + ["\\tcedil" ], "ţ", [letter]; + ["\\Tcaron" ], "Ť", [letter]; + ["\\tcaron" ], "ť", [letter]; + ["\\Tstrok" ], "Ŧ", [letter]; + ["\\tstrok" ], "ŧ", [letter]; + ["\\Utilde" ], "Ũ", [letter]; + ["\\utilde" ], "ũ", [letter]; + ["\\Umacr" ], "Ū", [letter]; + ["\\umacr" ], "ū", [letter]; + ["\\Ubreve" ], "Ŭ", [letter]; + ["\\ubreve" ], "ŭ", [letter]; + ["\\Uring" ], "Ů", [letter]; + ["\\uring" ], "ů", [letter]; + ["\\Udblac" ], "Ű", [letter]; + ["\\udblac" ], "ű", [letter]; + ["\\Uogon" ], "Ų", [letter]; + ["\\uogon" ], "ų", [letter]; + ["\\Wcirc" ], "Ŵ", [letter]; + ["\\wcirc" ], "ŵ", [letter]; + ["\\Ycirc" ], "Ŷ", [letter]; + ["\\ycirc" ], "ŷ", [letter]; + ["\\Yuml" ], "Ÿ", [letter]; + ["\\Zacute" ], "Ź", [letter]; + ["\\zacute" ], "ź", [letter]; + ["\\Zdot" ], "Ż", [letter]; + ["\\zdot" ], "ż", [letter]; + ["\\Zcaron" ], "Ž", [letter]; + ["\\zcaron" ], "ž", [letter]; + ["\\fnof" ], "ƒ", [letter]; + ["\\gacute" ], "ǵ", [letter]; + ["\\IOcy" ], "Ё", [letter]; + ["\\DJcy" ], "Ђ", [letter]; + ["\\GJcy" ], "Ѓ", [letter]; + ["\\Jukcy" ], "Є", [letter]; + ["\\DScy" ], "Ѕ", [letter]; + ["\\Iukcy" ], "І", [letter]; + ["\\YIcy" ], "Ї", [letter]; + ["\\Jsercy" ], "Ј", [letter]; + ["\\LJcy" ], "Љ", [letter]; + ["\\NJcy" ], "Њ", [letter]; + ["\\TSHcy" ], "Ћ", [letter]; + ["\\KJcy" ], "Ќ", [letter]; + ["\\Ubrcy" ], "Ў", [letter]; + ["\\DZcy" ], "Џ", [letter]; + ["\\Acy" ], "А", [letter]; + ["\\Bcy" ], "Б", [letter]; + ["\\Vcy" ], "В", [letter]; + ["\\Gcy" ], "Г", [letter]; + ["\\Dcy" ], "Д", [letter]; + ["\\IEcy" ], "Е", [letter]; + ["\\ZHcy" ], "Ж", [letter]; + ["\\Zcy" ], "З", [letter]; + ["\\Icy" ], "И", [letter]; + ["\\Jcy" ], "Й", [letter]; + ["\\Kcy" ], "К", [letter]; + ["\\Lcy" ], "Л", [letter]; + ["\\Mcy" ], "М", [letter]; + ["\\Ncy" ], "Н", [letter]; + ["\\Ocy" ], "О", [letter]; + ["\\Pcy" ], "П", [letter]; + ["\\Rcy" ], "Р", [letter]; + ["\\Scy" ], "С", [letter]; + ["\\Tcy" ], "Т", [letter]; + ["\\Ucy" ], "У", [letter]; + ["\\Fcy" ], "Ф", [letter]; + ["\\KHcy" ], "Х", [letter]; + ["\\TScy" ], "Ц", [letter]; + ["\\CHcy" ], "Ч", [letter]; + ["\\SHcy" ], "Ш", [letter]; + ["\\SHCHcy" ], "Щ", [letter]; + ["\\HARDcy" ], "Ъ", [letter]; + ["\\Ycy" ], "Ы", [letter]; + ["\\SOFTcy" ], "Ь", [letter]; + ["\\Ecy" ], "Э", [letter]; + ["\\YUcy" ], "Ю", [letter]; + ["\\YAcy" ], "Я", [letter]; + ["\\acy" ], "а", [letter]; + ["\\bcy" ], "б", [letter]; + ["\\vcy" ], "в", [letter]; + ["\\gcy" ], "г", [letter]; + ["\\dcy" ], "д", [letter]; + ["\\iecy" ], "е", [letter]; + ["\\zhcy" ], "ж", [letter]; + ["\\zcy" ], "з", [letter]; + ["\\icy" ], "и", [letter]; + ["\\jcy" ], "й", [letter]; + ["\\kcy" ], "к", [letter]; + ["\\lcy" ], "л", [letter]; + ["\\mcy" ], "м", [letter]; + ["\\ncy" ], "н", [letter]; + ["\\ocy" ], "о", [letter]; + ["\\pcy" ], "п", [letter]; + ["\\rcy" ], "р", [letter]; + ["\\scy" ], "с", [letter]; + ["\\tcy" ], "т", [letter]; + ["\\ucy" ], "у", [letter]; + ["\\fcy" ], "ф", [letter]; + ["\\khcy" ], "х", [letter]; + ["\\tscy" ], "ц", [letter]; + ["\\chcy" ], "ч", [letter]; + ["\\shcy" ], "ш", [letter]; + ["\\shchcy" ], "щ", [letter]; + ["\\hardcy" ], "ъ", [letter]; + ["\\ycy" ], "ы", [letter]; + ["\\softcy" ], "ь", [letter]; + ["\\ecy" ], "э", [letter]; + ["\\yucy" ], "ю", [letter]; + ["\\yacy" ], "я", [letter]; + ["\\iocy" ], "ё", [letter]; + ["\\djcy" ], "ђ", [letter]; + ["\\gjcy" ], "ѓ", [letter]; + ["\\jukcy" ], "є", [letter]; + ["\\dscy" ], "ѕ", [letter]; + ["\\iukcy" ], "і", [letter]; + ["\\yicy" ], "ї", [letter]; + ["\\jsercy" ], "ј", [letter]; + ["\\ljcy" ], "љ", [letter]; + ["\\njcy" ], "њ", [letter]; + ["\\tshcy" ], "ћ", [letter]; + ["\\kjcy" ], "ќ", [letter]; + ["\\ubrcy" ], "ў", [letter]; + ["\\dzcy" ], "џ", [letter]; + ["\\Copf"; "\\complexes" ], "ℂ", [letter]; + ["\\gscr" ], "ℊ", [letter]; + ["\\Hscr"; "\\hamilt"; "\\HilbertSpace" ], "ℋ", [letter]; + ["\\Hfr"; "\\Poincareplane" ], "ℌ", [letter]; + ["\\Hopf"; "\\quaternions" ], "ℍ", [letter]; + ["\\planckh" ], "ℎ", [letter]; + ["\\hslash"; "\\plankv" ], "ℏ", [letter]; + ["\\hbar"; "\\planck" ], "ℏ︀", [letter]; + ["\\Iscr"; "\\imagline" ], "ℐ", [letter]; + ["\\Im"; "\\Ifr"; "\\image"; "\\imagpart" ], "ℑ", [letter]; + ["\\Lscr"; "\\lagran"; "\\Laplacetrf" ], "ℒ", [letter]; + ["\\ell"; "\\lscr" ], "ℓ", [letter]; + ["\\Nopf"; "\\naturals" ], "ℕ", [letter]; + ["\\numero" ], "№", [letter]; + ["\\copysr" ], "℗", [letter]; + ["\\wp"; "\\weierp" ], "℘", [letter]; + ["\\Popf"; "\\primes" ], "ℙ", [letter]; + ["\\Qopf"; "\\rationals" ], "ℚ", [letter]; + ["\\Rscr"; "\\realine" ], "ℛ", [letter]; + ["\\Re"; "\\Rfr"; "\\real"; "\\realpart" ], "ℜ", [letter]; + ["\\Ropf"; "\\reals" ], "ℝ", [letter]; + ["\\rx" ], "℞", [letter]; + ["\\trade" ], "™", [letter]; + ["\\Zopf"; "\\integers" ], "ℤ", [letter]; + ["\\ohm" ], "Ω", [letter]; + ["\\mho" ], "℧", [letter]; + ["\\Zfr"; "\\zeetrf" ], "ℨ", [letter]; + ["\\iiota" ], "℩", [letter]; + ["\\angst" ], "Å", [letter]; + ["\\Bscr"; "\\bernou"; "\\Bernoullis" ], "ℬ", [letter]; + ["\\Cfr"; "\\Cayleys" ], "ℭ", [letter]; + ["\\escr" ], "ℯ", [letter]; + ["\\Escr"; "\\expectation" ], "ℰ", [letter]; + ["\\Fscr"; "\\Fouriertrf" ], "ℱ", [letter]; + ["\\Mscr"; "\\phmmat"; "\\Mellintrf" ], "ℳ", [letter]; + ["\\oscr"; "\\order"; "\\orderof" ], "ℴ", [letter]; + ["\\aleph" ], "ℵ", [letter]; + ["\\beth" ], "ℶ", [letter]; + ["\\gimel" ], "ℷ", [letter]; + ["\\daleth" ], "ℸ", [letter]; + ["\\DD"; "\\CapitalDifferentialD" ], "ⅅ", [letter]; + ["\\dd"; "\\DifferentialD" ], "ⅆ", [letter]; + ["\\ee"; "\\exponentiale"; "\\ExponentialE" ], "ⅇ", [letter]; + ["\\ii"; "\\ImaginaryI" ], "ⅈ", [letter]; + ["\\comp"; "\\complement" ], "∁", [letter]; + ["\\part"; "\\partial"; "\\PartialD" ], "∂", [letter]; + ["\\npart" ], "∂̸", [letter]; + ["\\easter" ], "≛", [letter]; + ["\\fpartint" ], "⨍", [letter]; + ["\\fflig" ], "ff", [letter]; + ["\\filig" ], "fi", [letter]; + ["\\fllig" ], "fl", [letter]; + ["\\ffilig" ], "ffi", [letter]; + ["\\ffllig" ], "ffl", [letter]; + ["\\Aopf" ], "𝔸", [letter]; + ["\\Bopf" ], "𝔹", [letter]; + ["\\Dopf" ], "𝔻", [letter]; + ["\\Eopf" ], "𝔼", [letter]; + ["\\Fopf" ], "𝔽", [letter]; + ["\\Gopf" ], "𝔾", [letter]; + ["\\Iopf" ], "𝕀", [letter]; + ["\\Jopf" ], "𝕁", [letter]; + ["\\Kopf" ], "𝕂", [letter]; + ["\\Lopf"; "\\imped" ], "𝕃", [letter]; + ["\\Mopf" ], "𝕄", [letter]; + ["\\Oopf" ], "𝕆", [letter]; + ["\\Sopf" ], "𝕊", [letter]; + ["\\Topf" ], "𝕋", [letter]; + ["\\Uopf" ], "𝕌", [letter]; + ["\\Vopf" ], "𝕍", [letter]; + ["\\Wopf" ], "𝕎", [letter]; + ["\\Xopf" ], "𝕏", [letter]; + ["\\Yopf" ], "𝕐", [letter]; + ["\\aopf" ], "𝕒", [letter]; + ["\\bopf" ], "𝕓", [letter]; + ["\\copf" ], "𝕔", [letter]; + ["\\dopf" ], "𝕕", [letter]; + ["\\eopf" ], "𝕖", [letter]; + ["\\fopf" ], "𝕗", [letter]; + ["\\gopf" ], "𝕘", [letter]; + ["\\hopf" ], "𝕙", [letter]; + ["\\iopf" ], "𝕚", [letter]; + ["\\jopf" ], "𝕛", [letter]; + ["\\kopf" ], "𝕜", [letter]; + ["\\lopf" ], "𝕝", [letter]; + ["\\mopf" ], "𝕞", [letter]; + ["\\nopf" ], "𝕟", [letter]; + ["\\oopf" ], "𝕠", [letter]; + ["\\popf" ], "𝕡", [letter]; + ["\\qopf" ], "𝕢", [letter]; + ["\\ropf" ], "𝕣", [letter]; + ["\\sopf" ], "𝕤", [letter]; + ["\\topf" ], "𝕥", [letter]; + ["\\uopf" ], "𝕦", [letter]; + ["\\vopf" ], "𝕧", [letter]; + ["\\wopf" ], "𝕨", [letter]; + ["\\xopf" ], "𝕩", [letter]; + ["\\yopf" ], "𝕪", [letter]; + ["\\zopf" ], "𝕫", [letter]; +(* }}} *) + +(* {{{ ASCII art *) + ["\\lceil"; "\\LeftCeiling" ], "⌈", [asciiart]; + ["\\rceil"; "\\RightCeiling" ], "⌉", [asciiart]; + ["\\lfloor"; "\\LeftFloor" ], "⌊", [asciiart]; + ["\\rfloor"; "\\RightFloor" ], "⌋", [asciiart]; + ["\\drcrop" ], "⌌", [asciiart]; + ["\\dlcrop" ], "⌍", [asciiart]; + ["\\urcrop" ], "⌎", [asciiart]; + ["\\ulcrop" ], "⌏", [asciiart]; + ["\\ulcorn"; "\\ulcorner" ], "⌜", [asciiart]; + ["\\urcorn"; "\\urcorner" ], "⌝", [asciiart]; + ["\\dlcorn"; "\\llcorner" ], "⌞", [asciiart]; + ["\\drcorn"; "\\lrcorner" ], "⌟", [asciiart]; + ["\\boxh" ], "─", [asciiart]; + ["\\boxv" ], "│", [asciiart]; + ["\\boxdr" ], "┌", [asciiart]; + ["\\boxdl" ], "┐", [asciiart]; + ["\\boxur" ], "└", [asciiart]; + ["\\boxul" ], "┘", [asciiart]; + ["\\boxvr" ], "├", [asciiart]; + ["\\boxvl" ], "┤", [asciiart]; + ["\\boxhd" ], "┬", [asciiart]; + ["\\boxhu" ], "┴", [asciiart]; + ["\\boxvh" ], "┼", [asciiart]; + ["\\boxH" ], "═", [asciiart]; + ["\\boxV" ], "║", [asciiart]; + ["\\boxdR" ], "╒", [asciiart]; + ["\\boxDr" ], "╓", [asciiart]; + ["\\boxDR" ], "╔", [asciiart]; + ["\\boxdL" ], "╕", [asciiart]; + ["\\boxDl" ], "╖", [asciiart]; + ["\\boxDL" ], "╗", [asciiart]; + ["\\boxuR" ], "╘", [asciiart]; + ["\\boxUr" ], "╙", [asciiart]; + ["\\boxUR" ], "╚", [asciiart]; + ["\\boxuL" ], "╛", [asciiart]; + ["\\boxUl" ], "╜", [asciiart]; + ["\\boxUL" ], "╝", [asciiart]; + ["\\boxvR" ], "╞", [asciiart]; + ["\\boxVr" ], "╟", [asciiart]; + ["\\boxVR" ], "╠", [asciiart]; + ["\\boxvL" ], "╡", [asciiart]; + ["\\boxVl" ], "╢", [asciiart]; + ["\\boxVL" ], "╣", [asciiart]; + ["\\boxHd" ], "╤", [asciiart]; + ["\\boxhD" ], "╥", [asciiart]; + ["\\boxHD" ], "╦", [asciiart]; + ["\\boxHu" ], "╧", [asciiart]; + ["\\boxhU" ], "╨", [asciiart]; + ["\\boxHU" ], "╩", [asciiart]; + ["\\boxvH" ], "╪", [asciiart]; + ["\\boxVh" ], "╫", [asciiart]; + ["\\boxVH" ], "╬", [asciiart]; + ["\\block" ], "█", [asciiart]; + ["\\blk14" ], "░", [asciiart]; + ["\\blk12" ], "▒", [asciiart]; + ["\\blk34" ], "▓", [asciiart]; +(* }}} *) + +(* {{{ equivalence *) + ["\\bsim"; "\\backsim" ], "∽", [equivalence]; + ["\\nsim"; "\\NotTilde" ], "≁", [equivalence]; + ["\\nvsim" ], "≁̸", [equivalence]; + ["\\esim"; "\\eqsim"; "\\EqualTilde" ], "≂", [equivalence]; + ["\\nesim"; "\\NotEqualTilde" ], "≂̸", [equivalence]; + ["\\sime"; "\\simeq"; "\\TildeEqual" ], "≃", [equivalence]; + ["\\nsime"; "\\nsimeq"; "\\NotTildeEqual" ], "≄", [equivalence]; + ["\\cong"; "\\TildeFullEqual" ], "≅", [equivalence]; + ["\\simne" ], "≆", [equivalence]; + ["\\ncong"; "\\NotTildeFullEqual" ], "≇", [equivalence]; + ["\\ap"; "\\approx"; "\\TildeTilde" ], "≈", [equivalence]; + ["\\nap"; "\\napprox"; "\\NotTildeTilde" ], "≉", [equivalence]; + ["\\nvap" ], "≉̸", [equivalence]; + ["\\apE"; "\\ape"; "\\approxeq" ], "≊", [equivalence]; + ["\\apid" ], "≋", [equivalence]; + ["\\napid" ], "≋̸", [equivalence]; + ["\\bcong"; "\\backcong" ], "≌", [equivalence]; + ["\\asymp"; "\\CupCap" ], "≍", [equivalence]; + ["\\bump"; "\\Bumpeq"; "\\HumpDownHump" ], "≎", [equivalence]; + ["\\nbump"; "\\NotHumpDownHump" ], "≎̸", [equivalence]; + ["\\bumpe"; "\\bumpeq"; "\\HumpEqual" ], "≏", [equivalence]; + ["\\nbumpe"; "\\NotHumpEqual" ], "≏̸", [equivalence]; + ["\\esdot"; "\\doteq"; "\\DotEqual" ], "≐", [equivalence]; + ["\\eDot"; "\\doteqdot" ], "≑", [equivalence]; + ["\\efDot"; "\\fallingdotseq" ], "≒", [equivalence]; + ["\\erDot"; "\\risingdotseq" ], "≓", [equivalence]; + ["\\colone"; "\\Assign"; "\\coloneq" ], "≔", [equivalence]; + ["\\ecolon"; "\\eqcolon" ], "≕", [equivalence]; + ["\\ecir"; "\\eqcirc" ], "≖", [equivalence]; + ["\\cire"; "\\circeq" ], "≗", [equivalence]; + ["\\wedgeq" ], "≙", [equivalence]; + ["\\veeeq" ], "≚", [equivalence]; + ["\\trie"; "\\triangleq" ], "≜", [equivalence]; + ["\\def";"\\:=" ], "≝", [equivalence]; + ["\\equest"; "\\questeq" ], "≟", [equivalence]; + ["\\ne"; "\\neq"; "\\NotEqual" ], "≠", [equivalence]; + ["\\equiv"; "\\Congruent" ], "≡", [equivalence]; + ["\\nequiv"; "\\NotCongruent" ], "≢", [equivalence]; + ["\\NotCupCap" ], "≭", [equivalence]; + ["\\bsime"; "\\backsimeq" ], "⋍", [equivalence]; + ["\\bumpE" ], "⪮", [equivalence]; +(* }}} *) + +(* {{{ order *) + ["\\le"; "\\leq";"\\<=" ], "≤", [order]; + ["\\ge"; "\\geq"; "\\GreaterEqual";"\\>=" ], "≥", [order]; + ["\\lE"; "\\leqq"; "\\LessFullEqual" ], "≦", [order]; + ["\\gE"; "\\geqq"; "\\GreaterFullEqual" ], "≧", [order]; + ["\\lnE"; "\\lne"; "\\lneq"; "\\lneqq" ], "≨", [order]; + ["\\gnE"; "\\gne"; "\\gneq"; "\\gneqq" ], "≩", [order]; + ["\\Lt"; "\\ll"; "\\NestedLessLess" ], "≪", [order]; + ["\\nLt" ], "≪̸", [order]; + ["\\gg"; "\\Gt"; "\\NestedGreaterGreater" ], "≫", [order]; + ["\\nGt" ], "≫̸", [order]; + ["\\nlt"; "\\nvlt"; "\\nless"; "\\NotLess" ], "≮", [order]; + ["\\ngt"; "\\ngtr"; "\\nvgt"; "\\NotGreater" ], "≯", [order]; + ["\\nlE"; "\\nleq"; "\\nvle"; "\\nles"; "\\nleqq"; "\\nleqslant"; "\\NotLessSlantEqual"; "\\NotGreaterFullEqual"], "≰", [order]; + ["\\ngE"; "\\nges"; "\\nvge"; "\\ngeq"; "\\ngeqq"; "\\ngeqslant"; "\\NotGreaterSlantEqual"], "≱", [order]; + ["\\lap"; "\\lsim"; "\\lesssim"; "\\LessTilde"; "\\lessapprox" ], "≲", [order]; + ["\\gap"; "\\gsim"; "\\gtrsim"; "\\gtrapprox"; "\\GreaterTilde" ], "≳", [order]; + ["\\nlsim"; "\\NotLessTilde" ], "≴", [order]; + ["\\ngsim"; "\\NotGreaterTilde" ], "≵", [order]; + ["\\lessgtr"; "\\LessGreater" ], "≶", [order]; + ["\\gl"; "\\gtrless"; "\\GreaterLess" ], "≷", [order]; + ["\\ntlg"; "\\NotLessGreater" ], "≸", [order]; + ["\\ntgl"; "\\NotGreaterLess" ], "≹", [order]; + ["\\pr"; "\\prec"; "\\Precedes" ], "≺", [order]; + ["\\sc"; "\\succ"; "\\Succeeds" ], "≻", [order]; + ["\\prcue"; "\\preccurlyeq"; "\\PrecedesSlantEqual" ], "≼", [order]; + ["\\sce"; "\\sccue"; "\\succeq"; "\\succcurlyeq"; "\\SucceedsEqual"; "\\SucceedsSlantEqual"], "≽", [order]; + ["\\scE"; "\\prap"; "\\prsim"; "\\precsim"; "\\precapprox"; "\\PrecedesTilde"], "≾", [order]; + ["\\scap"; "\\scsim"; "\\succsim"; "\\succapprox"; "\\SucceedsTilde"], "≿", [order]; + ["\\NotSucceedsTilde" ], "≿̸", [order]; + ["\\npr"; "\\nprec"; "\\NotPrecedes" ], "⊀", [order]; + ["\\nsc"; "\\nsucc"; "\\NotSucceeds" ], "⊁", [order]; + ["\\ltdot"; "\\lessdot" ], "⋖", [order]; + ["\\gtdot"; "\\gtrdot" ], "⋗", [order]; + ["\\Ll" ], "⋘", [order]; + ["\\nLl" ], "⋘̸", [order]; + ["\\Gg"; "\\ggg" ], "⋙", [order]; + ["\\nGg" ], "⋙̸", [order]; + ["\\lEg"; "\\leg"; "\\lesseqgtr"; "\\lesseqqgtr"; "\\LessEqualGreater"], "⋚", [order]; + ["\\gEl"; "\\gel"; "\\gtreqless"; "\\gtreqqless"; "\\GreaterEqualLess"], "⋛", [order]; + ["\\els"; "\\eqslantless" ], "⋜", [order]; + ["\\egs"; "\\eqslantgtr" ], "⋝", [order]; + ["\\cuepr"; "\\curlyeqprec" ], "⋞", [order]; + ["\\cuesc"; "\\curlyeqsucc" ], "⋟", [order]; + ["\\nprcue"; "\\NotPrecedesSlantEqual" ], "⋠", [order]; + ["\\nsccue"; "\\NotSucceedsSlantEqual" ], "⋡", [order]; + ["\\lnsim" ], "⋦", [order]; + ["\\gnsim" ], "⋧", [order]; + ["\\prnap"; "\\prnsim"; "\\precnsim"; "\\precnapprox" ], "⋨", [order]; + ["\\scnap"; "\\scnsim"; "\\succnsim"; "\\succnapprox" ], "⋩", [order]; + ["\\gtrarr" ], "⥸", [order]; + ["\\les"; "\\leqslant"; "\\LessSlantEqual" ], "⩽", [order]; + ["\\ges"; "\\geqslant"; "\\GreaterSlantEqual" ], "⩾", [order]; + ["\\lesdot" ], "⩿", [order]; + ["\\gesdot" ], "⪀", [order]; + ["\\lesdoto" ], "⪁", [order]; + ["\\gesdoto" ], "⪂", [order]; + ["\\lesdotor" ], "⪃", [order]; + ["\\gesdotol" ], "⪄", [order]; + ["\\lnap"; "\\lnapprox" ], "⪉", [order]; + ["\\gnap"; "\\gnapprox" ], "⪊", [order]; + ["\\lsime" ], "⪍", [order]; + ["\\gsime" ], "⪎", [order]; + ["\\lsimg" ], "⪏", [order]; + ["\\gsiml" ], "⪐", [order]; + ["\\lgE" ], "⪑", [order]; + ["\\glE" ], "⪒", [order]; + ["\\lesges" ], "⪓", [order]; + ["\\gesles" ], "⪔", [order]; + ["\\elsdot" ], "⪗", [order]; + ["\\egsdot" ], "⪘", [order]; + ["\\el" ], "⪙", [order]; + ["\\eg" ], "⪚", [order]; + ["\\siml" ], "⪝", [order]; + ["\\simg" ], "⪞", [order]; + ["\\simlE" ], "⪟", [order]; + ["\\simgE" ], "⪠", [order]; + ["\\prE"; "\\pre"; "\\preceq"; "\\PrecedesEqual" ], "⪯", [order]; + ["\\npre"; "\\npreceq"; "\\NotPrecedesEqual" ], "⪯̸", [order]; + ["\\nsce"; "\\nsucceq"; "\\NotSucceedsEqual" ], "⪰̸", [order]; + ["\\prnE"; "\\precneqq" ], "⪵", [order]; + ["\\scnE"; "\\succneqq" ], "⪶", [order]; +(* }}} *) + +(* {{{ circles *) + ["\\copy" ], "©", [circle]; + ["\\reg"; "\\circledR" ], "®", [circle]; + ["\\ordm" ], "º", [circle]; + ["\\oslash" ], "ø", [circle]; + ["\\ring" ], "˚", [circle]; + ["\\bull"; "\\bullet" ], "•", [circle]; + ["\\circ"; "\\compfn"; "\\SmallCircle" ], "∘", [circle]; + ["\\oplus"; "\\xoplus"; "\\bigoplus"; "\\CirclePlus" ], "⊕", [circle]; + ["\\ominus"; "\\CircleMinus" ], "⊖", [circle]; + ["\\xotime"; "\\otimes"; "\\bigotimes"; "\\CircleTimes"], "⊗", [circle]; + ["\\osol" ], "⊘", [circle]; + ["\\odot"; "\\xodot"; "\\bigodot"; "\\CircleDot" ], "⊙", [circle]; + ["\\ocir"; "\\circledcirc" ], "⊚", [circle]; + ["\\oast"; "\\circledast" ], "⊛", [circle]; + ["\\odash"; "\\circleddash" ], "⊝", [circle]; + ["\\ovbar" ], "⌽", [circle]; + ["\\NotNestedLessLess" ], "⒡̸", [circle]; + ["\\NotNestedGreaterGreater" ], "⒢̸", [circle]; + ["\\oS"; "\\circledS" ], "Ⓢ", [circle]; + ["\\cir"; ], "○", [circle]; + ["\\xcirc"; "\\bigcirc" ], "◯", [circle]; +(* }}} *) + +(* {{{ squares *) + ["\\plusb"; "\\boxplus" ], "⊞", [square]; + ["\\minusb"; "\\boxminus" ], "⊟", [square]; + ["\\timesb"; "\\boxtimes" ], "⊠", [square]; + ["\\sdotb"; "\\dotsquare" ], "⊡", [square]; + ["\\uhblk" ], "▀", [square]; + ["\\lhblk" ], "▄", [square]; + ["\\squ"; "\\square"; "\\Square" ], "□", [square]; + ["\\squf"; "\\squarf"; "\\blacksquare" ], "▪", [square]; + ["\\rect" ], "▭", [square]; + ["\\marker" ], "▮", [square]; + ["\\EmptySmallSquare" ], "◽", [square]; + ["\\FilledSmallSquare" ], "◾", [square]; +(* }}} *) + +(* {{{ triangles *) + ["\\Del"; "\\nabla" ], "∇", [triangle]; + ["\\vltri"; "\\LeftTriangle"; "\\vartriangleleft" ], "⊲", [triangle]; + ["\\vrtri"; "\\RightTriangle"; "\\vartriangleright" ], "⊳", [triangle]; + ["\\ltrie"; "\\trianglelefteq"; "\\LeftTriangleEqual" ], "⊴", [triangle]; + ["\\rtrie"; "\\trianglerighteq"; "\\RightTriangleEqual" ], "⊵", [triangle]; + ["\\nltri"; "\\ntriangleleft"; "\\NotLeftTriangle" ], "⋪", [triangle]; + ["\\nrtri"; "\\ntriangleright"; "\\NotRightTriangle" ], "⋫", [triangle]; + ["\\nltrie"; "\\ntrianglelefteq"; "\\NotLeftTriangleEqual" ], "⋬", [triangle]; + ["\\nvltrie" ], "⋬̸", [triangle]; + ["\\nrtrie"; "\\ntrianglerighteq"; "\\NotRightTriangleEqual" ], "⋭", [triangle]; + ["\\nvrtrie" ], "⋭̸", [triangle]; + ["\\xutri"; "\\bigtriangleup" ], "△", [triangle]; + ["\\utrif"; "\\blacktriangle" ], "▴", [triangle]; + ["\\utri"; "\\triangle" ], "▵", [triangle]; + ["\\rtrif"; "\\blacktriangleright" ], "▸", [triangle]; + ["\\rtri"; "\\triangleright" ], "▹", [triangle]; + ["\\xdtri"; "\\bigtriangledown" ], "▽", [triangle]; + ["\\dtrif"; "\\blacktriangledown" ], "▾", [triangle]; + ["\\dtri"; "\\triangledown" ], "▿", [triangle]; + ["\\ltrif"; "\\blacktriangleleft" ], "◂", [triangle]; + ["\\ltri"; "\\triangleleft" ], "◃", [triangle]; + ["\\tridot" ], "◬", [triangle]; + ["\\ultri" ], "◸", [triangle]; + ["\\urtri" ], "◹", [triangle]; + ["\\lltri" ], "◺", [triangle]; + ["\\rtriltri" ], "⧎", [triangle]; + ["\\LeftTriangleBar" ], "⧏", [triangle]; + ["\\NotLeftTriangleBar" ], "⧏̸", [triangle]; + ["\\RightTriangleBar" ], "⧐", [triangle]; + ["\\NotRightTriangleBar" ], "⧐̸", [triangle]; +(* }}} *) + +(* {{{ arrows *) + ["\\larr"; "\\gets"; "\\leftarrow"; "\\LeftArrow";"\\<-" ], "←", [arrow]; + ["\\uarr"; "\\UpArrow"; "\\uparrow" ], "↑", [arrow]; + ["\\to"; "\\rarr"; "\\RightArrow"; "\\rightarrow";"\\->"], "→", [arrow]; + ["\\darr"; "\\downarrow"; "\\DownArrow" ], "↓", [arrow]; + ["\\harr"; "\\LeftRightArrow"; "\\leftrightarrow" ], "↔", [arrow]; + ["\\varr"; "\\updownarrow"; "\\UpDownArrow" ], "↕", [arrow]; + ["\\nwarr"; "\\nwarrow"; "\\UpperLeftArrow" ], "↖", [arrow]; + ["\\nearr"; "\\nearrow"; "\\UpperRightArrow" ], "↗", [arrow]; + ["\\searr"; "\\searrow"; "\\LowerRightArrow" ], "↘", [arrow]; + ["\\swarr"; "\\swarrow"; "\\LowerLeftArrow" ], "↙", [arrow]; + ["\\nlarr"; "\\nleftarrow" ], "↚", [arrow]; + ["\\nrarr"; "\\nrightarrow" ], "↛", [arrow]; + ["\\rarrw"; "\\rightsquigarrow" ], "↝", [arrow]; + ["\\nrarrw" ], "↝̸", [arrow]; + ["\\Larr"; "\\twoheadleftarrow" ], "↞", [arrow]; + ["\\Uarr" ], "↟", [arrow]; + ["\\Rarr"; "\\twoheadrightarrow" ], "↠", [arrow]; + ["\\Darr" ], "↡", [arrow]; + ["\\larrtl"; "\\leftarrowtail" ], "↢", [arrow]; + ["\\ratail"; "\\rarrtl"; "\\rightarrowtail" ], "↣", [arrow]; + ["\\mapstoleft"; "\\LeftTeeArrow" ], "↤", [arrow]; + ["\\mapstoup"; "\\UpTeeArrow" ], "↥", [arrow]; + ["\\map"; "\\mapsto"; "\\RightTeeArrow" ], "↦", [arrow]; + ["\\mapstodown"; "\\DownTeeArrow" ], "↧", [arrow]; + ["\\larrhk"; "\\hookleftarrow" ], "↩", [arrow]; + ["\\rarrhk"; "\\hookrightarrow" ], "↪", [arrow]; + ["\\larrlp"; "\\looparrowleft" ], "↫", [arrow]; + ["\\rarrlp"; "\\looparrowright" ], "↬", [arrow]; + ["\\harrw"; "\\leftrightsquigarrow" ], "↭", [arrow]; + ["\\nharr"; "\\nleftrightarrow" ], "↮", [arrow]; + ["\\Lsh"; "\\lsh" ], "↰", [arrow]; + ["\\Rsh"; "\\rsh" ], "↱", [arrow]; + ["\\ldsh" ], "↲", [arrow]; + ["\\rdsh" ], "↳", [arrow]; + ["\\cularr"; "\\curvearrowleft" ], "↶", [arrow]; + ["\\curarr"; "\\curvearrowright" ], "↷", [arrow]; + ["\\olarr"; "\\circlearrowleft" ], "↺", [arrow]; + ["\\orarr"; "\\circlearrowright" ], "↻", [arrow]; + ["\\lharu"; "\\LeftVector"; "\\leftharpoonup" ], "↼", [arrow]; + ["\\lhard"; "\\DownLeftVector"; "\\leftharpoondown" ], "↽", [arrow]; + ["\\uharr"; "\\RightUpVector"; "\\upharpoonright" ], "↾", [arrow]; + ["\\uharl"; "\\LeftUpVector"; "\\upharpoonleft" ], "↿", [arrow]; + ["\\rharu"; "\\RightVector"; "\\rightharpoonup" ], "⇀", [arrow]; + ["\\rhard"; "\\DownRightVector"; "\\rightharpoondown" ], "⇁", [arrow]; + ["\\dharr"; "\\RightDownVector"; "\\downharpoonright" ], "⇂", [arrow]; + ["\\dharl"; "\\LeftDownVector"; "\\downharpoonleft" ], "⇃", [arrow]; + ["\\rlarr"; "\\rightleftarrows"; "\\RightArrowLeftArrow" ], "⇄", [arrow]; + ["\\udarr"; "\\UpArrowDownArrow" ], "⇅", [arrow]; + ["\\lrarr"; "\\leftrightarrows"; "\\LeftArrowRightArrow" ], "⇆", [arrow]; + ["\\llarr"; "\\leftleftarrows" ], "⇇", [arrow]; + ["\\uuarr"; "\\upuparrows" ], "⇈", [arrow]; + ["\\rrarr"; "\\rightrightarrows" ], "⇉", [arrow]; + ["\\ddarr"; "\\downdownarrows" ], "⇊", [arrow]; + ["\\lrhar"; "\\leftrightharpoons"; "\\ReverseEquilibrium" ], "⇋", [arrow]; + ["\\rlhar"; "\\Equilibrium"; "\\rightleftharpoons" ], "⇌", [arrow]; + ["\\nlArr"; "\\nvlArr"; "\\nLeftarrow" ], "⇍", [arrow]; + ["\\nhArr"; "\\nvHarr"; "\\nLeftrightarrow" ], "⇎", [arrow]; + ["\\nrArr"; "\\nvrArr"; "\\nRightarrow" ], "⇏", [arrow]; + ["\\lArr"; "\\Leftarrow"; "\\DoubleLeftArrow";"\\<==" ], "⇐", [arrow]; + ["\\uArr"; "\\Uparrow"; "\\DoubleUpArrow" ], "⇑", [arrow]; + ["\\rArr"; "\\Implies"; "\\Rightarrow"; "\\Longrightarrow"; "\\DoubleRightArrow"; "\\==>"], "⇒", [arrow]; + ["\\dArr"; "\\Downarrow"; "\\DoubleDownArrow" ], "⇓", [arrow]; + ["\\iff"; "\\hArr"; "\\Leftrightarrow"; "\\DoubleLeftRightArrow";"\\<==>" ], "⇔", [arrow]; + ["\\vArr"; "\\Updownarrow"; "\\DoubleUpDownArrow" ], "⇕", [arrow]; + ["\\nwArr" ], "⇖", [arrow]; + ["\\neArr" ], "⇗", [arrow]; + ["\\seArr" ], "⇘", [arrow]; + ["\\swArr" ], "⇙", [arrow]; + ["\\lAarr"; "\\Lleftarrow" ], "⇚", [arrow]; + ["\\rAarr"; "\\Rrightarrow" ], "⇛", [arrow]; + ["\\zigrarr" ], "⇝", [arrow]; + ["\\larrb"; "\\LeftArrowBar" ], "⇤", [arrow]; + ["\\rarrb"; "\\RightArrowBar" ], "⇥", [arrow]; + ["\\duarr"; "\\DownArrowUpArrow" ], "⇵", [arrow]; + ["\\loarr" ], "⇽", [arrow]; + ["\\roarr" ], "⇾", [arrow]; + ["\\hoarr" ], "⇿", [arrow]; + ["\\Map" ], "⤅", [arrow]; + ["\\lbarr" ], "⤌", [arrow]; + ["\\rbarr"; "\\bkarow" ], "⤍", [arrow]; + ["\\lBarr" ], "⤎", [arrow]; + ["\\ac"; "\\rBarr"; "\\dbkarow" ], "⤏", [arrow]; + ["\\RBarr"; "\\drbkarow" ], "⤐", [arrow]; + ["\\DDotrahd" ], "⤑", [arrow]; + ["\\UpArrowBar" ], "⤒", [arrow]; + ["\\DownArrowBar" ], "⤓", [arrow]; + ["\\Rarrtl" ], "⤖", [arrow]; + ["\\latail" ], "⤙", [arrow]; + ["\\lAtail" ], "⤛", [arrow]; + ["\\rAtail" ], "⤜", [arrow]; + ["\\larrfs" ], "⤝", [arrow]; + ["\\rarrfs" ], "⤞", [arrow]; + ["\\larrbfs" ], "⤟", [arrow]; + ["\\rarrbfs" ], "⤠", [arrow]; + ["\\nwarhk" ], "⤣", [arrow]; + ["\\nearhk" ], "⤤", [arrow]; + ["\\searhk"; "\\hksearow" ], "⤥", [arrow]; + ["\\swarhk"; "\\hkswarow" ], "⤦", [arrow]; + ["\\nwnear" ], "⤧", [arrow]; + ["\\toea"; "\\nesear" ], "⤨", [arrow]; + ["\\tosa"; "\\seswar" ], "⤩", [arrow]; + ["\\swnwar" ], "⤪", [arrow]; + ["\\rarrc" ], "⤳", [arrow]; + ["\\nrarrc" ], "⤳̸", [arrow]; + ["\\cudarrr" ], "⤵", [arrow]; + ["\\ldca" ], "⤶", [arrow]; + ["\\rdca" ], "⤷", [arrow]; + ["\\cudarrl" ], "⤸", [arrow]; + ["\\larrpl" ], "⤹", [arrow]; + ["\\curarrm" ], "⤼", [arrow]; + ["\\cularrp" ], "⤽", [arrow]; + ["\\rarrpl" ], "⥅", [arrow]; + ["\\harrcir" ], "⥈", [arrow]; + ["\\Uarrocir" ], "⥉", [arrow]; + ["\\lurdshar" ], "⥊", [arrow]; + ["\\ldrushar" ], "⥋", [arrow]; + ["\\LeftRightVector" ], "⥎", [arrow]; + ["\\RightUpDownVector" ], "⥏", [arrow]; + ["\\DownLeftRightVector" ], "⥐", [arrow]; + ["\\LeftUpDownVector" ], "⥑", [arrow]; + ["\\LeftVectorBar" ], "⥒", [arrow]; + ["\\RightVectorBar" ], "⥓", [arrow]; + ["\\RightUpVectorBar" ], "⥔", [arrow]; + ["\\RightDownVectorBar" ], "⥕", [arrow]; + ["\\DownLeftVectorBar" ], "⥖", [arrow]; + ["\\DownRightVectorBar" ], "⥗", [arrow]; + ["\\LeftUpVectorBar" ], "⥘", [arrow]; + ["\\LeftDownVectorBar" ], "⥙", [arrow]; + ["\\LeftTeeVector" ], "⥚", [arrow]; + ["\\RightTeeVector" ], "⥛", [arrow]; + ["\\RightUpTeeVector" ], "⥜", [arrow]; + ["\\RightDownTeeVector" ], "⥝", [arrow]; + ["\\DownLeftTeeVector" ], "⥞", [arrow]; + ["\\DownRightTeeVector" ], "⥟", [arrow]; + ["\\LeftUpTeeVector" ], "⥠", [arrow]; + ["\\LeftDownTeeVector" ], "⥡", [arrow]; + ["\\lHar" ], "⥢", [arrow]; + ["\\uHar" ], "⥣", [arrow]; + ["\\rHar" ], "⥤", [arrow]; + ["\\dHar" ], "⥥", [arrow]; + ["\\luruhar" ], "⥦", [arrow]; + ["\\ldrdhar" ], "⥧", [arrow]; + ["\\ruluhar" ], "⥨", [arrow]; + ["\\rdldhar" ], "⥩", [arrow]; + ["\\lharul" ], "⥪", [arrow]; + ["\\llhard" ], "⥫", [arrow]; + ["\\rharul" ], "⥬", [arrow]; + ["\\lrhard" ], "⥭", [arrow]; + ["\\udhar"; "\\UpEquilibrium" ], "⥮", [arrow]; + ["\\duhar"; "\\ReverseUpEquilibrium" ], "⥯", [arrow]; + ["\\RoundImplies" ], "⥰", [arrow]; + ["\\erarr" ], "⥱", [arrow]; + ["\\simrarr" ], "⥲", [arrow]; + ["\\larrsim" ], "⥳", [arrow]; + ["\\rarrsim" ], "⥴", [arrow]; + ["\\rarrap" ], "⥵", [arrow]; + ["\\ltlarr" ], "⥶", [arrow]; + ["\\suplarr" ], "⥻", [arrow]; + ["\\lfisht" ], "⥼", [arrow]; + ["\\rfisht" ], "⥽", [arrow]; + ["\\ufisht" ], "⥾", [arrow]; + ["\\dfisht" ], "⥿", [arrow]; +(* }}} *) + +(* {{{ set operations *) + ["\\emptyv"; "\\varnothing" ], "∅", [set]; + ["\\in"; "\\isin"; "\\isinv"; "\\Element" ], "∈", [set]; + ["\\notin"; "\\NotElement" ], "∉", [set]; + ["\\notinva" ], "∉̸", [set]; + ["\\ni"; "\\niv"; "\\owns"; "\\SuchThat"; "\\ReverseElement" ], "∋", [set]; + ["\\notni"; "\\notniva"; "\\NotReverseElement" ], "∌", [set]; + ["\\coprod"; "\\Coproduct" ], "∐", [set]; + ["\\cap" ], "∩", [set]; + ["\\cup" ], "∪", [set]; + ["\\twixt"; "\\between" ], "≬", [set]; + ["\\subset" ], "⊂", [set]; + ["\\supset"; "\\Superset" ], "⊃", [set]; + ["\\suphsol" ], "⊃/", [set]; + ["\\nsub"; "\\vnsub"; "\\nsubset"; "\\NotSubset" ], "⊄", [set]; + ["\\nsup"; "\\vnsup"; "\\nsupset"; "\\NotSuperset" ], "⊅", [set]; + ["\\subE"; "\\sube"; "\\subseteq"; "\\subseteqq"; "\\SubsetEqual" ], "⊆", [set]; + ["\\supe"; "\\supE"; "\\supseteq"; "\\supseteqq"; "\\SupersetEqual"], "⊇", [set]; + ["\\nsube"; "\\nsubE"; "\\nsubseteq"; "\\nsubseteqq"; "\\NotSubsetEqual"], "⊈", [set]; + ["\\nsupe"; "\\nsupE"; "\\nsupseteq"; "\\nsupseteqq"; "\\NotSupersetEqual"], "⊉", [set]; + ["\\subne"; "\\subnE"; "\\subsetneq"; "\\subsetneqq" ], "⊊", [set]; + ["\\supne"; "\\supnE"; "\\supsetneq"; "\\supsetneqq" ], "⊋", [set]; + ["\\cupdot" ], "⊍", [set]; + ["\\uplus"; "\\xuplus"; "\\biguplus"; "\\UnionPlus" ], "⊎", [set]; + ["\\sqsub"; "\\sqsubset"; "\\SquareSubset" ], "⊏", [set]; + ["\\NotSquareSubset" ], "⊏̸", [set]; + ["\\sqsup"; "\\sqsupset"; "\\SquareSuperset" ], "⊐", [set]; + ["\\NotSquareSuperset" ], "⊐̸", [set]; + ["\\sqsube"; "\\sqsubseteq"; "\\SquareSubsetEqual" ], "⊑", [set]; + ["\\sqsupe"; "\\sqsupseteq"; "\\SquareSupersetEqual" ], "⊒", [set]; + ["\\sqcap"; "\\SquareIntersection" ], "⊓", [set]; + ["\\sqcup"; "\\xsqcup"; "\\bigsqcup"; "\\SquareUnion" ], "⊔", [set]; + ["\\xcap"; "\\bigcap"; "\\Intersection" ], "⋂", [set]; + ["\\xcup"; "\\Union"; "\\bigcup" ], "⋃", [set]; + ["\\Sub"; "\\Subset" ], "⋐", [set]; + ["\\Sup"; "\\Supset" ], "⋑", [set]; + ["\\Cap" ], "⋒", [set]; + ["\\Cup" ], "⋓", [set]; + ["\\nsqsube"; "\\NotSquareSubsetEqual" ], "⋢", [set]; + ["\\nsqsupe"; "\\NotSquareSupersetEqual" ], "⋣", [set]; + ["\\disin" ], "⋲", [set]; + ["\\isinsv" ], "⋳", [set]; + ["\\isins" ], "⋴", [set]; + ["\\isindot" ], "⋵", [set]; + ["\\notinvc" ], "⋶", [set]; + ["\\notindot" ], "⋶︀", [set]; + ["\\notinvb" ], "⋷", [set]; + ["\\isinE" ], "⋹", [set]; + ["\\nisd" ], "⋺", [set]; + ["\\xnis" ], "⋻", [set]; + ["\\nis" ], "⋼", [set]; + ["\\notnivc" ], "⋽", [set]; + ["\\notnivb" ], "⋾", [set]; + ["\\subrarr" ], "⥹", [set]; +(* }}} *) + +(* {{{ math *) + ["\\pm"; "\\plusmn"; "\\PlusMinus" ], "±", [math]; + ["\\times" ], "×", [math]; + ["\\div"; "\\divide" ], "÷", [math]; + ["\\prod"; "\\Product" ], "∏", [math]; + ["\\sum"; "\\Sum" ], "∑", [math]; + ["\\mp"; "\\mnplus"; "\\MinusPlus" ], "∓", [math]; + ["\\plusdo"; "\\dotplus" ], "∔", [math]; + ["\\setmn"; "\\setminus"; "\\Backslash" ], "∖", [math]; + ["\\lowast" ], "∗", [math]; + ["\\Sqrt"; "\\radic" ], "√", [math]; + ["\\prop"; "\\vprop"; "\\propto"; "\\varpropto"; "\\Proportional" ], "∝", [math]; + ["\\infty"; "\\infin" ], "∞", [math]; + ["\\mid"; "\\divides"; "\\VerticalBar" ], "∣", [math]; + ["\\nmid"; "\\ndivides"; "\\NotVerticalBar" ], "∤", [math]; + ["\\npar"; "\\nparallel"; "\\NotDoubleVerticalBar" ], "∦", [math]; + ["\\int"; "\\Integral" ], "∫", [math]; + ["\\Int" ], "∬", [math]; + ["\\tint"; "\\iiint" ], "∭", [math]; + ["\\oint"; "\\conint"; "\\ContourIntegral" ], "∮", [math]; + ["\\Conint"; "\\DoubleContourIntegral" ], "∯", [math]; + ["\\Cconint" ], "∰", [math]; + ["\\cwint" ], "∱", [math]; + ["\\cwconint"; "\\ClockwiseContourIntegral" ], "∲", [math]; + ["\\awconint"; "\\CounterClockwiseContourIntegral" ], "∳", [math]; + ["\\qint"; "\\iiiint" ], "⨌", [math]; + ["\\cirfnint" ], "⨐", [math]; + ["\\awint" ], "⨑", [math]; + ["\\rppolint" ], "⨒", [math]; + ["\\scpolint" ], "⨓", [math]; + ["\\npolint" ], "⨔", [math]; + ["\\pointint" ], "⨕", [math]; + ["\\quatint" ], "⨖", [math]; + ["\\intlarhk" ], "⨗", [math]; + ["\\Cross" ], "⨯", [math]; +(* }}} *) + +(* {{{ spaces *) + ["\\nbsp"; "\\NonBreakingSpace" ], " ", [space]; + ["\\shy" ], "", [space]; + ["\\ensp" ], " ", [space]; + ["\\emsp" ], " ", [space]; + ["\\emsp13" ], " ", [space]; + ["\\emsp14" ], " ", [space]; + ["\\numsp" ], " ", [space]; + ["\\puncsp" ], " ", [space]; + ["\\thinsp"; "\\ThinSpace" ], " ", [space]; + ["\\ThickSpace" ], " ", [space]; + ["\\hairsp"; "\\VeryThinSpace" ], " ", [space]; + ["\\ic"; "\\ZeroWidthSpace"; "\\InvisibleComma" ], "", [space]; + ["\\af"; "\\ApplyFunction" ], "", [space]; + ["\\it"; "\\InvisibleTimes" ], "", [space]; + ["\\NoBreak" ], "", [space]; +(* }}} *) + +(* {{{ parenteses *) + ["\\laquo" ], "«", [delimiter] ; + ["\\raquo" ], "»", [delimiter] ; + ["\\lang"; "\\langle"; "\\LeftAngleBracket" ], "〈", [delimiter] ; + ["\\rang"; "\\rangle"; "\\RightAngleBracket" ], "〉", [delimiter] ; + ["\\lmoust"; "\\lmoustache" ], "⎰", [delimiter] ; + ["\\rmoust"; "\\rmoustache" ], "⎱", [delimiter] ; + ["\\Lang" ], "《", [delimiter] ; + ["\\Rang" ], "》", [delimiter] ; + ["\\lbbrk" ], "〔", [delimiter] ; + ["\\rbbrk" ], "〕", [delimiter] ; + ["\\lopar" ], "〘", [delimiter] ; + ["\\ropar" ], "〙", [delimiter] ; + ["\\lobrk"; "\\LeftDoubleBracket" ], "〚", [delimiter] ; + ["\\robrk"; "\\RightDoubleBracket" ], "〛", [delimiter] ; +(* }}} *) + +(* {{{ Missing font *) + ["\\NegativeThickSpace" ], " ︀", [miscellanea]; + ["\\NegativeThinSpace" ], " ︀", [miscellanea]; + ["\\NegativeVeryThinSpace" ], " ︀", [miscellanea]; + ["\\NegativeMediumSpace" ], " ︀", [miscellanea]; + ["\\slarr"; "\\ShortLeftArrow" ], "←︀", [miscellanea]; + ["\\srarr"; "\\ShortRightArrow" ], "→︀", [miscellanea]; + ["\\empty"; "\\emptyset" ], "∅︀", [miscellanea]; + ["\\ssetmn"; "\\smallsetminus" ], "∖︀", [miscellanea]; + ["\\smid"; "\\shortmid" ], "∣︀", [miscellanea]; + ["\\nsmid"; "\\nshortmid" ], "∤︀", [miscellanea]; + ["\\spar"; "\\parsl"; "\\shortparallel" ], "∥︀", [miscellanea]; + ["\\nparsl" ], "∥︀⃥", [miscellanea]; + ["\\nspar"; "\\nshortparallel" ], "∦︀", [miscellanea]; + ["\\caps" ], "∩︀", [miscellanea]; + ["\\cups" ], "∪︀", [miscellanea]; + ["\\thksim"; "\\thicksim" ], "∼︀", [miscellanea]; + ["\\thkap"; "\\thickapprox" ], "≈︀", [miscellanea]; + ["\\nedot" ], "≠︀", [miscellanea]; + ["\\bnequiv" ], "≡⃥", [miscellanea]; + ["\\lvnE"; "\\lvertneqq" ], "≨︀", [miscellanea]; + ["\\gvnE"; "\\gvertneqq" ], "≩︀", [miscellanea]; + ["\\nLtv"; "\\NotLessLess" ], "≪̸︀", [miscellanea]; + ["\\nGtv"; "\\NotGreaterGreater" ], "≫̸︀", [miscellanea]; + ["\\nle"; "\\NotLessEqual" ], "≰⃥", [miscellanea]; + ["\\nge"; "\\NotGreaterEqual" ], "≱⃥", [miscellanea]; + ["\\vsubnE"; "\\vsubne"; "\\varsubsetneq"; "\\varsubsetneqq" ], "⊊︀", [miscellanea]; + ["\\vsupne"; "\\vsupnE"; "\\varsupsetneq"; "\\varsupsetneqq" ], "⊋︀", [miscellanea]; + ["\\sqcaps" ], "⊓︀", [miscellanea]; + ["\\sqcups" ], "⊔︀", [miscellanea]; + ["\\prurel" ], "⊰", [miscellanea]; + ["\\lesg" ], "⋚︀", [miscellanea]; + ["\\gesl" ], "⋛︀", [miscellanea]; + ["\\ShortUpArrow" ], "⌃︀", [miscellanea]; + ["\\ShortDownArrow" ], "⌄︀", [miscellanea]; + ["\\target" ], "⌖", [miscellanea]; + ["\\cylcty" ], "⌭", [miscellanea]; + ["\\profalar" ], "⌮", [miscellanea]; + ["\\topbot" ], "⌶", [miscellanea]; + ["\\solbar" ], "⌿", [miscellanea]; + ["\\angzarr" ], "⍼", [miscellanea]; + ["\\tbrk"; "\\OverBracket" ], "⎴", [miscellanea]; + ["\\bbrk"; "\\UnderBracket" ], "⎵", [miscellanea]; + ["\\lbrke" ], "⦋", [miscellanea]; + ["\\rbrke" ], "⦌", [miscellanea]; + ["\\lbrkslu" ], "⦍", [miscellanea]; + ["\\rbrksld" ], "⦎", [miscellanea]; + ["\\lbrksld" ], "⦏", [miscellanea]; + ["\\rbrkslu" ], "⦐", [miscellanea]; + ["\\langd" ], "⦑", [miscellanea]; + ["\\rangd" ], "⦒", [miscellanea]; + ["\\lparlt" ], "⦓", [miscellanea]; + ["\\rpargt" ], "⦔", [miscellanea]; + ["\\gtlPar" ], "⦕", [miscellanea]; + ["\\ltrPar" ], "⦖", [miscellanea]; + ["\\vzigzag" ], "⦚", [miscellanea]; + ["\\angrtvbd" ], "⦝", [miscellanea]; + ["\\angrtvb" ], "⦝︀", [miscellanea]; + ["\\ange" ], "⦤", [miscellanea]; + ["\\range" ], "⦥", [miscellanea]; + ["\\dwangle" ], "⦦", [miscellanea]; + ["\\uwangle" ], "⦧", [miscellanea]; + ["\\angmsdaa" ], "⦨", [miscellanea]; + ["\\angmsdab" ], "⦩", [miscellanea]; + ["\\angmsdac" ], "⦪", [miscellanea]; + ["\\angmsdad" ], "⦫", [miscellanea]; + ["\\angmsdae" ], "⦬", [miscellanea]; + ["\\angmsdaf" ], "⦭", [miscellanea]; + ["\\angmsdag" ], "⦮", [miscellanea]; + ["\\angmsdah" ], "⦯", [miscellanea]; + ["\\bemptyv" ], "⦰", [miscellanea]; + ["\\demptyv" ], "⦱", [miscellanea]; + ["\\cemptyv" ], "⦲", [miscellanea]; + ["\\raemptyv" ], "⦳", [miscellanea]; + ["\\laemptyv" ], "⦴", [miscellanea]; + ["\\ohbar" ], "⦵", [miscellanea]; + ["\\omid" ], "⦶", [miscellanea]; + ["\\opar" ], "⦷", [miscellanea]; + ["\\operp" ], "⦹", [miscellanea]; + ["\\olcross" ], "⦻", [miscellanea]; + ["\\odsold" ], "⦼", [miscellanea]; + ["\\olcir" ], "⦾", [miscellanea]; + ["\\ofcir" ], "⦿", [miscellanea]; + ["\\olt" ], "⧀", [miscellanea]; + ["\\ogt" ], "⧁", [miscellanea]; + ["\\cirscir" ], "⧂", [miscellanea]; + ["\\cirE" ], "⧃", [miscellanea]; + ["\\solb" ], "⧄", [miscellanea]; + ["\\bsolb" ], "⧅", [miscellanea]; + ["\\boxbox" ], "⧉", [miscellanea]; + ["\\trisb" ], "⧍", [miscellanea]; + ["\\race" ], "⧚", [miscellanea]; + ["\\acE" ], "⧛", [miscellanea]; + ["\\iinfin" ], "⧜", [miscellanea]; + ["\\nvinfin" ], "⧞", [miscellanea]; + ["\\eparsl" ], "⧣", [miscellanea]; + ["\\smeparsl" ], "⧤", [miscellanea]; + ["\\eqvparsl" ], "⧥", [miscellanea]; + ["\\RuleDelayed" ], "⧴", [miscellanea]; + ["\\dsol" ], "⧶", [miscellanea]; + ["\\pluscir" ], "⨢", [miscellanea]; + ["\\plusacir" ], "⨣", [miscellanea]; + ["\\simplus" ], "⨤", [miscellanea]; + ["\\plusdu" ], "⨥", [miscellanea]; + ["\\plussim" ], "⨦", [miscellanea]; + ["\\plustwo" ], "⨧", [miscellanea]; + ["\\mcomma" ], "⨩", [miscellanea]; + ["\\minusdu" ], "⨪", [miscellanea]; + ["\\loplus" ], "⨭", [miscellanea]; + ["\\roplus" ], "⨮", [miscellanea]; + ["\\timesd" ], "⨰", [miscellanea]; + ["\\timesbar" ], "⨱", [miscellanea]; + ["\\smashp" ], "⨳", [miscellanea]; + ["\\lotimes" ], "⨴", [miscellanea]; + ["\\rotimes" ], "⨵", [miscellanea]; + ["\\otimesas" ], "⨶", [miscellanea]; + ["\\Otimes" ], "⨷", [miscellanea]; + ["\\odiv" ], "⨸", [miscellanea]; + ["\\triplus" ], "⨹", [miscellanea]; + ["\\triminus" ], "⨺", [miscellanea]; + ["\\tritime" ], "⨻", [miscellanea]; + ["\\iprod"; "\\intprod" ], "⨼", [miscellanea]; + ["\\amalg" ], "⨿", [miscellanea]; + ["\\capdot" ], "⩀", [miscellanea]; + ["\\ncup" ], "⩂", [miscellanea]; + ["\\ncap" ], "⩃", [miscellanea]; + ["\\capand" ], "⩄", [miscellanea]; + ["\\cupor" ], "⩅", [miscellanea]; + ["\\cupcap" ], "⩆", [miscellanea]; + ["\\capcup" ], "⩇", [miscellanea]; + ["\\cupbrcap" ], "⩈", [miscellanea]; + ["\\capbrcup" ], "⩉", [miscellanea]; + ["\\cupcup" ], "⩊", [miscellanea]; + ["\\capcap" ], "⩋", [miscellanea]; + ["\\ccups" ], "⩌", [miscellanea]; + ["\\ccaps" ], "⩍", [miscellanea]; + ["\\ccupssm" ], "⩐", [miscellanea]; + ["\\And" ], "⩓", [miscellanea]; + ["\\Or" ], "⩔", [miscellanea]; + ["\\andand" ], "⩕", [miscellanea]; + ["\\oror" ], "⩖", [miscellanea]; + ["\\orslope" ], "⩗", [miscellanea]; + ["\\andslope" ], "⩘", [miscellanea]; + ["\\andv" ], "⩚", [miscellanea]; + ["\\orv" ], "⩛", [miscellanea]; + ["\\andd" ], "⩜", [miscellanea]; + ["\\ord" ], "⩝", [miscellanea]; + ["\\wedbar" ], "⩟", [miscellanea]; + ["\\sdote" ], "⩦", [miscellanea]; + ["\\simdot" ], "⩪", [miscellanea]; + ["\\congdot" ], "⩭", [miscellanea]; + ["\\ncongdot" ], "⩭̸", [miscellanea]; + ["\\apacir" ], "⩯", [miscellanea]; + ["\\napE" ], "⩰̸", [miscellanea]; + ["\\eplus" ], "⩱", [miscellanea]; + ["\\pluse" ], "⩲", [miscellanea]; + ["\\Esim" ], "⩳", [miscellanea]; + ["\\Colone" ], "⩴", [miscellanea]; + ["\\Equal" ], "⩵", [miscellanea]; + ["\\eDDot"; "\\ddotseq" ], "⩷", [miscellanea]; + ["\\equivDD" ], "⩸", [miscellanea]; + ["\\ltcir" ], "⩹", [miscellanea]; + ["\\gtcir" ], "⩺", [miscellanea]; + ["\\ltquest" ], "⩻", [miscellanea]; + ["\\gtquest" ], "⩼", [miscellanea]; + ["\\LessLess" ], "⪡", [miscellanea]; + ["\\GreaterGreater" ], "⪢", [miscellanea]; + ["\\glj" ], "⪤", [miscellanea]; + ["\\gla" ], "⪥", [miscellanea]; + ["\\ltcc" ], "⪦", [miscellanea]; + ["\\gtcc" ], "⪧", [miscellanea]; + ["\\lescc" ], "⪨", [miscellanea]; + ["\\gescc" ], "⪩", [miscellanea]; + ["\\smt" ], "⪪", [miscellanea]; + ["\\lat" ], "⪫", [miscellanea]; + ["\\smte" ], "⪬", [miscellanea]; + ["\\smtes" ], "⪬︀", [miscellanea]; + ["\\late" ], "⪭", [miscellanea]; + ["\\lates" ], "⪭︀", [miscellanea]; + ["\\Sc" ], "⪼", [miscellanea]; + ["\\subdot" ], "⪽", [miscellanea]; + ["\\supdot" ], "⪾", [miscellanea]; + ["\\subplus" ], "⪿", [miscellanea]; + ["\\supplus" ], "⫀", [miscellanea]; + ["\\submult" ], "⫁", [miscellanea]; + ["\\supmult" ], "⫂", [miscellanea]; + ["\\subedot" ], "⫃", [miscellanea]; + ["\\supedot" ], "⫄", [miscellanea]; + ["\\subsim" ], "⫇", [miscellanea]; + ["\\supsim" ], "⫈", [miscellanea]; + ["\\csub" ], "⫏", [miscellanea]; + ["\\csup" ], "⫐", [miscellanea]; + ["\\csube" ], "⫑", [miscellanea]; + ["\\csupe" ], "⫒", [miscellanea]; + ["\\subsup" ], "⫓", [miscellanea]; + ["\\supsub" ], "⫔", [miscellanea]; + ["\\subsub" ], "⫕", [miscellanea]; + ["\\supsup" ], "⫖", [miscellanea]; + ["\\suphsub" ], "⫗", [miscellanea]; + ["\\supdsub" ], "⫘", [miscellanea]; + ["\\forkv" ], "⫙", [miscellanea]; + ["\\topfork" ], "⫚", [miscellanea]; + ["\\mlcp" ], "⫛", [miscellanea]; + ["\\Dashv"; "\\DoubleLeftTee" ], "⫤", [miscellanea]; + ["\\Vdashl" ], "⫦", [miscellanea]; + ["\\Barv" ], "⫧", [miscellanea]; + ["\\vBar" ], "⫨", [miscellanea]; + ["\\vBarv" ], "⫩", [miscellanea]; + ["\\Vbar" ], "⫫", [miscellanea]; + ["\\Not" ], "⫬", [miscellanea]; + ["\\bNot" ], "⫭", [miscellanea]; + ["\\rnmid" ], "⫮", [miscellanea]; + ["\\cirmid" ], "⫯", [miscellanea]; + ["\\midcir" ], "⫰", [miscellanea]; + ["\\topcir" ], "⫱", [miscellanea]; + ["\\nhpar" ], "⫲", [miscellanea]; + ["\\parsim" ], "⫳", [miscellanea]; + ["\\loang" ], "", [miscellanea]; + ["\\roang" ], "", [miscellanea]; + ["\\xlarr"; "\\LongLeftArrow" ], "", [miscellanea]; + ["\\xrarr"; "\\LongRightArrow" ], "", [miscellanea]; + ["\\xharr"; "\\LongLeftRightArrow" ], "", [miscellanea]; + ["\\xlArr"; "\\DoubleLongLeftArrow" ], "", [miscellanea]; + ["\\xrArr"; "\\DoubleLongRightArrow" ], "", [miscellanea]; + ["\\xhArr"; "\\DoubleLongLeftRightArrow" ], "", [miscellanea]; + ["\\xmap" ], "", [miscellanea]; + ["\\FilledVerySmallSquare" ], "", [miscellanea]; + ["\\EmptyVerySmallSquare" ], "", [miscellanea]; + ["\\dzigrarr" ], "", [miscellanea]; + ["\\Ascr" ], "𝒜", [miscellanea]; + ["\\Cscr" ], "𝒞", [miscellanea]; + ["\\Dscr" ], "𝒟", [miscellanea]; + ["\\Gscr" ], "𝒢", [miscellanea]; + ["\\Jscr" ], "𝒥", [miscellanea]; + ["\\Kscr" ], "𝒦", [miscellanea]; + ["\\Nscr" ], "𝒩", [miscellanea]; + ["\\Oscr" ], "𝒪", [miscellanea]; + ["\\Pscr" ], "𝒫", [miscellanea]; + ["\\Qscr" ], "𝒬", [miscellanea]; + ["\\Sscr" ], "𝒮", [miscellanea]; + ["\\Tscr" ], "𝒯", [miscellanea]; + ["\\Uscr" ], "𝒰", [miscellanea]; + ["\\Vscr" ], "𝒱", [miscellanea]; + ["\\Wscr" ], "𝒲", [miscellanea]; + ["\\Xscr" ], "𝒳", [miscellanea]; + ["\\Yscr" ], "𝒴", [miscellanea]; + ["\\Zscr" ], "𝒵", [miscellanea]; + ["\\ascr" ], "𝒶", [miscellanea]; + ["\\bscr" ], "𝒷", [miscellanea]; + ["\\cscr" ], "𝒸", [miscellanea]; + ["\\dscr" ], "𝒹", [miscellanea]; + ["\\fscr" ], "𝒻", [miscellanea]; + ["\\hscr" ], "𝒽", [miscellanea]; + ["\\iscr" ], "𝒾", [miscellanea]; + ["\\jscr" ], "𝒿", [miscellanea]; + ["\\kscr" ], "𝓀", [miscellanea]; + ["\\mscr" ], "𝓂", [miscellanea]; + ["\\nscr" ], "𝓃", [miscellanea]; + ["\\pscr" ], "𝓅", [miscellanea]; + ["\\qscr" ], "𝓆", [miscellanea]; + ["\\rscr" ], "𝓇", [miscellanea]; + ["\\sscr" ], "𝓈", [miscellanea]; + ["\\tscr" ], "𝓉", [miscellanea]; + ["\\uscr" ], "𝓊", [miscellanea]; + ["\\vscr" ], "𝓋", [miscellanea]; + ["\\wscr" ], "𝓌", [miscellanea]; + ["\\xscr" ], "𝓍", [miscellanea]; + ["\\yscr" ], "𝓎", [miscellanea]; + ["\\zscr" ], "𝓏", [miscellanea]; + ["\\Afr" ], "𝔄", [miscellanea]; + ["\\Bfr" ], "𝔅", [miscellanea]; + ["\\Dfr" ], "𝔇", [miscellanea]; + ["\\Efr" ], "𝔈", [miscellanea]; + ["\\Ffr" ], "𝔉", [miscellanea]; + ["\\Gfr" ], "𝔊", [miscellanea]; + ["\\Jfr" ], "𝔍", [miscellanea]; + ["\\Kfr" ], "𝔎", [miscellanea]; + ["\\Lfr" ], "𝔏", [miscellanea]; + ["\\Mfr" ], "𝔐", [miscellanea]; + ["\\Nfr" ], "𝔑", [miscellanea]; + ["\\Ofr" ], "𝔒", [miscellanea]; + ["\\Pfr" ], "𝔓", [miscellanea]; + ["\\Qfr" ], "𝔔", [miscellanea]; + ["\\Sfr" ], "𝔖", [miscellanea]; + ["\\Tfr" ], "𝔗", [miscellanea]; + ["\\Ufr" ], "𝔘", [miscellanea]; + ["\\Vfr" ], "𝔙", [miscellanea]; + ["\\Wfr" ], "𝔚", [miscellanea]; + ["\\Xfr" ], "𝔛", [miscellanea]; + ["\\Yfr" ], "𝔜", [miscellanea]; + ["\\afr" ], "𝔞", [miscellanea]; + ["\\bfr" ], "𝔟", [miscellanea]; + ["\\cfr" ], "𝔠", [miscellanea]; + ["\\dfr" ], "𝔡", [miscellanea]; + ["\\efr" ], "𝔢", [miscellanea]; + ["\\ffr" ], "𝔣", [miscellanea]; + ["\\gfr" ], "𝔤", [miscellanea]; + ["\\hfr" ], "𝔥", [miscellanea]; + ["\\ifr" ], "𝔦", [miscellanea]; + ["\\jfr" ], "𝔧", [miscellanea]; + ["\\kfr" ], "𝔨", [miscellanea]; + ["\\lfr" ], "𝔩", [miscellanea]; + ["\\mfr" ], "𝔪", [miscellanea]; + ["\\nfr" ], "𝔫", [miscellanea]; + ["\\ofr" ], "𝔬", [miscellanea]; + ["\\pfr" ], "𝔭", [miscellanea]; + ["\\qfr" ], "𝔮", [miscellanea]; + ["\\rfr" ], "𝔯", [miscellanea]; + ["\\sfr" ], "𝔰", [miscellanea]; + ["\\tfr" ], "𝔱", [miscellanea]; + ["\\ufr" ], "𝔲", [miscellanea]; + ["\\vfr" ], "𝔳", [miscellanea]; + ["\\wfr" ], "𝔴", [miscellanea]; + ["\\xfr" ], "𝔵", [miscellanea]; + ["\\yfr" ], "𝔶", [miscellanea]; + ["\\zfr" ], "𝔷", [miscellanea]; +(* }}} *) + +] + + +(** **************************************************************************) +(** * Bindings set 2 *) + +let bindings_set_2 = [ + + (* Symbols *) + "\\!'", "¡"; + "\\`", "‘"; + "\\``", "“"; + "\\'", "′"; + "\\''", "″"; + "\\'''", "‴"; + "\\mbox''", "”"; + "\\mbox'", "’"; + "\\--", "–"; + "\\---", "—"; + "\\Alpha", "Α"; + "\\Beta", "Β"; + "\\Box", "□"; + "\\Bumpeq", "≎"; + "\\Cap", "⋒"; + "\\Chi", "Χ"; + "\\Cup", "⋓"; + "\\DH", "Ð"; + "\\Delta", "Δ "; + "\\Diamond", "◇"; + "\\Downarrow", "⇓"; + "\\Epsilon", "Ε "; + "\\Eta", "Η"; + "\\Finv", "Ⅎ"; + "\\Gamma", "Γ "; + "\\Im", "ℑ"; + "\\Join", "⋈"; + "\\Kappa", "Κ"; + "\\L", "Ł"; + "\\Lambda", "Λ"; + "\\Leftarrow", "⇐"; + "\\Leftrightarrow", "⇔"; + "\\Lleftarrow", "⇚"; + "\\Longleftarrow", "⇐"; + "\\Longleftrightarrow", "⇔"; + "\\Longrightarrow", "⇒"; + "\\Lsh", "↰"; + "\\Mu", "Μ"; + "\\Nu", "Ν"; + "\\O", "Ø"; + "\\OE", "Œ"; + "\\Omega", "Ω"; + "\\W", "Ω"; + "\\Omicron", "Ο"; + "\\P", "¶"; + "\\Phi", "Φ"; + "\\F", "Φ"; + "\\Pi", "Π"; + "\\Psi", "Ψ"; + "\\Re", "ℜ"; + "\\Rho", "Ρ"; + "\\Rightarrow", "⇒"; + "\\Rrightarrow", "⇛"; + "\\Rsh", "↱"; + "\\S", "§"; + "\\Sigma", "Σ"; + "\\Subset", "⋐"; + "\\Supset", "⋑"; + "\\TH", "Þ"; + "\\Tau", "Τ"; + "\\Theta", "Θ"; + "\\Uparrow", "⇑"; + "\\Updownarrow", "⇕"; + "\\Upsilon", "Υ"; + "\\Vdash", "⊩"; + "\\Vvdash", "⊪"; + "\\Xi", "Ξ"; + "\\Zeta", "Ζ"; + "\\aa", "å"; + "\\ae", "æ"; + "\\aleph", "ℵ"; + "\\alpha", "α"; + "\\angle", "∠"; + "\\approx", "≈"; + "\\approxeq", "≊"; + "\\aquarius", "♒"; + "\\aries", "♈"; + "\\ascnode", "☊"; + "\\ast", "∗"; + "\\astrosun", "☉"; + "\\asymp", "≍"; + "\\backepsilon", "∍"; + "\\backprime", "‵"; + "\\backsim", "∽"; + "\\barwedge", "⊼"; + "\\because", "∵"; + "\\beta", "β"; + "\\beth", "ℶ"; + "\\between", "≬"; + "\\bigcap", "⋂"; + "\\bigcirc", "○"; + "\\bigcup", "⋃"; + "\\bigodot", "⊙"; + "\\bigoplus", "⊕"; + "\\bigotimes", "⊗"; + "\\bigsqcup", "⊔"; + "\\bigstar", "★"; + "\\bigtriangledown", "▽"; + "\\bigtriangleup", "△"; + "\\biguplus", "⊎"; + "\\bigvee", "⋁"; + "\\bigwedge", "⋀"; + "\\blackbishop", "♝"; + "\\blackking", "♚"; + "\\blackknight", "♞"; + "\\blacklozenge", "◆"; + "\\blackpawn", "♟"; + "\\blackqueen", "♛"; + "\\blackrook", "♜"; + "\\blacksquare", "■"; + "\\blacktriangle", "▲"; + "\\blacktriangledown", "▼"; + "\\blacktriangleleft", "◀"; + "\\blacktriangleright", "▷"; + "\\bot", "⊥"; + "\\bowtie", "⋈"; + "\\boxdot", "⊡"; + "\\boxminus", "⊟"; + "\\boxplus", "⊞"; + "\\boxtimes", "⊠"; + "\\bullet", "∙"; + "\\bumpeq", "≏"; + "\\cancer", "♋"; + "\\cap", "∩"; + "\\capricornus", "♑"; + "\\capslockkey", "⇪"; + "\\cdot", "⋅"; + "\\cdots", "⋯"; + "\\centerdot", "⋅"; + "\\cents", "¢"; + "\\chi", "χ"; + "\\circ", "∘"; + "\\circeq", "≗"; + "\\circlearrowleft", "↺"; + "\\circlearrowright", "↻"; + "\\circledS", "Ⓢ"; + "\\circledast", "⊛"; + "\\circledcirc", "⊚"; + "\\circleddash", "⊝"; + "\\clubsuit", "♣"; + "\\cmdkey", "⌘"; + "\\complement", "∁"; + "\\cong", "≅"; + "\\conjunction", "☌"; + "\\coprod", "∐"; + "\\copyright", "©"; + "\\cup", "∪"; + "\\curlyeqprec", "⋞"; + "\\curlyeqsucc", "⋟"; + "\\curlyvee", "⋎"; + "\\curlywedge", "⋏"; + "\\curvearrowleft", "↶"; + "\\curvearrowright", "↷"; + "\\cC", "Ç"; + "\\cc", "ç"; + "\\dag", "†"; + "\\dagger", "†"; + "\\daleth", "ℸ"; + "\\dashleftarrow", "⇠"; + "\\dashrightarrow", "⇢"; + "\\dashv", "⊣"; + "\\ddag", "‡"; + "\\ddagger", "‡"; + "\\degree", "°"; + "\\delkey", "⌫"; + "\\delta", "δ "; + "\\descnode", "☋"; + "\\dh", "ð"; + "\\diamond", "⋄"; + "\\diamondsuit", "♢"; + "\\digamma", "Ϝ"; + "\\div", "÷"; + "\\divideontimes", "⋇"; + "\\downarrow", "↓"; + "\\downdownarrows", "⇊"; + "\\downharpoonleft", "⇃"; + "\\downharpoonright", "⇂"; + "\\earth", "⊕"; + "\\ejectkey", "⏏"; + "\\ell", "ℓ"; + "\\emptyset", "∅"; + "\\enterkey", "⌤"; + "\\epsdice1", "⚀"; + "\\epsdice2", "⚁"; + "\\epsdice3", "⚂"; + "\\epsdice4", "⚃"; + "\\epsdice5", "⚄"; + "\\epsdice6", "⚅"; + "\\epsilon", "∊"; + "\\eqcirc", "≖"; + "\\equiv", "≡"; + "\\esckey", "⎋"; + "\\eta", "η"; + "\\eth", "ð"; + "\\euro", "€"; + "\\exists", "∃"; + "\\fallingdotseq", "≒"; + "\\flat", "♭"; + "\\forall", "∀"; + "\\frown", "⌢"; + "\\gamma", "γ"; + "\\ge", "≥"; + "\\gemini", "♊"; + "\\geq", "≥"; + "\\geqq", "≧"; + "\\gg", "≫"; + "\\ggg", "⋙"; + "\\gimel", "ℷ"; + "\\gtrdot", "⋗"; + "\\gtreqless", "⋛"; + "\\gtrless", "≷"; + "\\gtrsim", "≳"; + "\\hbar", "ℏ"; + "\\heartsuit", "♡"; + "\\hookleftarrow", "↩"; + "\\hookrightarrow", "↪"; + "\\hslash", "ℏ"; + "\\iiiint", "⨌"; + "\\iiint", "∭"; + "\\iint", "∬"; + "\\implies", "⇒"; + "\\in", "∈"; + "\\infty", "∞"; + "\\int", "∫"; + "\\intercal", "⊺"; + "\\iota", "ι"; + "\\jupiter", "♃"; + "\\kappa", "κ"; + "\\l{}", "ł"; + "\\lambda", "λ"; + "\\langle", "⟨"; + "\\lceil", "⌈"; + "\\ldots", "…"; + "\\le", "≤"; + "\\leadsto", "↝"; + "\\leftarrow", "←"; + "\\leftarrowtail", "↢"; + "\\leftharpoondown", "↽"; + "\\leftharpoonup", "↼"; + "\\leftleftarrows", "⇇"; + "\\leftmoon", "☾"; + "\\leftrightarrow", "↔"; + "\\leftrightarrows", "⇆"; + "\\leftrightharpoons", "⇋"; + "\\leftrightsquigarrow", "↭"; + "\\leftthreetimes", "⋋"; + "\\leo", "♌"; + "\\leq", "≤"; + "\\leqq", "≦"; + "\\leqslant", "≤"; + "\\lessdot", "⋖"; + "\\lesseqgtr", "⋚"; + "\\lessgtr", "≶"; + "\\lesssim", "≲"; + "\\lfloor", "⌊"; + "\\lhd", "⊲"; + "\\libra", "♎"; + "\\ll", "≪"; + "\\lll", "⋘"; + "\\longleftarrow", "←"; + "\\longleftrightarrow", "↔"; + "\\longmapsto", "⇖"; + "\\longrightarrow", "→"; + "\\looparrowleft", "↫"; + "\\looparrowright", "↬"; + "\\lozenge", "◊"; + "\\ltimes", "⋉"; + "\\mapsto", "↦"; + "\\mars", "♂"; + "\\measuredangle", "∡"; + "\\mercury", "☿"; + "\\mho", "℧"; + "\\mid", "∣"; + "\\models", "⊨"; + "\\mp", "∓"; + "\\mu", "μ"; + "\\multimap", "⊸"; + "\\nabla", "∇"; + "\\natural", "♮"; + "\\nearrow", "↗"; + "\\neg", "¬"; + "\\neptune", "♆"; + "\\neq", "≠"; + "\\nexists", "∄"; + "\\ng", "ŋ"; + "\\ni", "∋"; + "\\not<", "≮"; + "\\not>", "≯"; + "\\not\\Vdash", "⊮"; + "\\not\\approx", "≉"; + "\\not\\cong", "≇"; + "\\not\\equiv", "≢"; + "\\not\\ge", "≱"; + "\\not\\gtrless", "≹"; + "\\not\\in", "∉"; + "\\not\\le", "≰"; + "\\not\\models", "⊭"; + "\\not\\ni", "∌"; + "\\not\\sim", "≄"; + "\\not\\sqsubseteq", "⋢"; + "\\not\\sqsupseteq", "⋣"; + "\\not\\subset", "⊄"; + "\\not\\subseteq", "⊈"; + "\\not\\supset", "⊅"; + "\\not\\supseteq", "⊉"; + "\\not\\vdash", "⊬"; + "\\notin", "∉"; + "\\nu", "ν"; + "\\v", "ν"; + "\\nwarrow", "↖"; + "\\o{}", "ø"; + "\\odot", "⊙"; + "\\oe", "œ"; + "\\oint", "∮"; + "\\omega", "ω"; + "\\w", "ω"; + "\\omicron", "ο"; + "\\ominus", "⊖"; + "\\oplus", "⊕"; + "\\opposition", "☍"; + "\\optkey", "⌥"; + "\\oslash", "⊘"; + "\\otimes", "⊗"; + "\\parallel", "∥"; + "\\partial", "∂"; + "\\perp", "⊥"; + "\\phi", "φ"; + "\\f", "φ"; + "\\pi", "π"; + "\\pilcrow", "¶"; + "\\pisces", "♓"; + "\\pitchfork", "⋔"; + "\\pluto", "♇"; + "\\pm", "±"; + "\\pound", "£"; + "\\pounds", "£"; + "\\prec", "≺"; + "\\preccurlyeq", "≼"; + "\\preceq", "≼"; + "\\precsim", "≾"; + "\\prime", "′"; + "\\prod", "∏"; + "\\propto", "∝"; + "\\psi", "ψ"; + "\\rangle", "⟩"; + "\\rceil", "⌉"; + "\\registered", "®"; + "\\returnkey", "⏎"; + "\\revtabkey", "⇤"; + "\\rfloor", "⌋"; + "\\rhd", "⊳"; + "\\rho", "ρ"; + "\\rightarrow", "→"; + "\\rightarrowtail", "↣"; + "\\rightdelkey", "⌦"; + "\\rightharpoondown", "⇁"; + "\\rightharpoonup", "⇀"; + "\\rightleftarrows", "⇄"; + "\\rightleftharpoons", "⇌"; + "\\rightmoon", "☽"; + "\\rightrightarrows", "⇉"; + "\\rightsquigarrow", "⇝"; + "\\rightthreetimes", "⋌"; + "\\risingdotseq", "≓"; + "\\rtimes", "⋊"; + "\\sagittarius", "♐"; + "\\saturn", "♄"; + "\\scorpio", "♏"; + "\\searrow", "↘"; + "\\section", "§"; + "\\setminus", "∖"; + "\\sharp", "♯"; + "\\shiftkey", "⇧"; + "\\shortparallel", "∥"; + "\\sigma", "σ"; + "\\sim", "∼"; + "\\simeq", "≃"; + "\\smallfrown", "⌢"; + "\\smallsetminus", "∖"; + "\\smallsmile", "⌣"; + "\\smile", "⌣"; + "\\space", "␣"; + "\\spadesuit", "♠"; + "\\sphericalangle", "∢"; + "\\sqcap", "⊓"; + "\\sqcup", "⊔"; + "\\sqsubset", "⊏"; + "\\sqsubseteq", "⊑"; + "\\sqsupset", "⊐"; + "\\sqsupseteq", "⊒"; + "\\square", "□"; + "\\ss", "ß"; + "\\star", "⋆"; + "\\subset", "⊂"; + "\\subseteq", "⊆"; + "\\subsetneq", "⊊"; + "\\succ", "≻"; + "\\succcurlyeq", "≽"; + "\\succeq", "≽"; + "\\succsim", "≿"; + "\\sum", "∑"; + "\\supset", "⊃"; + "\\supseteq", "⊇"; + "\\supsetneq", "⊋"; + "\\surd", "√"; + "\\swarrow", "↙"; + "\\tabkey", "⇥"; + "\\tau", "τ"; + "\\taurus", "♉"; + "\\textbabygamma", "ɤ"; + "\\textbarglotstop", "ʡ"; + "\\textbari", "ɨ"; + "\\textbaro", "ɵ"; + "\\textbarrevglotstop", "ʢ"; + "\\textbaru", "ʉ"; + "\\textbeltl", "ɬ"; + "\\textbeta", "β"; + "\\textbullseye", "ʘ"; + "\\textchi", "χ"; + "\\textcloserevepsilon", "ɞ"; + "\\textcrh", "ħ"; + "\\textctc", "ɕ"; + "\\textctj", "ʝ"; + "\\textctz", "ʑ"; + "\\textdoublepipe", "ǁ"; + "\\textdyoghlig", "ʤ"; + "\\textepsilon", "ɛ"; + "\\textesh", "ʃ"; + "\\textfishhookr", "ɾ"; + "\\textgamma", "ɣ"; + "\\textglotstop", "ʔ"; + "\\textgrgamma", "γ"; + "\\texthtb", "ɓ"; + "\\texthtd", "ɗ"; + "\\texthtg", "ɠ"; + "\\texthth", "ɦ"; + "\\texththeng", "ɧ"; + "\\texthtscg", "ʛ"; + "\\textinvscr", "ʁ"; + "\\textiota", "ι"; + "\\textltailm", "ɱ"; + "\\textltailn", "ɲ"; + "\\textltilde", "ɫ"; + "\\textlyoghlig", "ɮ"; + "\\textopeno", "ɔ"; + "\\textphi", "ɸ"; + "\\textpipe", "ǀ"; + "\\textregistered", "®"; + "\\textreve", "ɘ"; + "\\textrevepsilon", "ɜ"; + "\\textrevglotstop", "ʕ"; + "\\textrhookrevepsilon", "ɝ"; + "\\textrighthookschwa", "ɚ"; + "\\textteshlig", "ʧ"; + "\\texttheta", "θ"; + "\\texttrademark", "™"; + "\\textturna", "ɐ"; + "\\textturnh", "ɥ"; + "\\textturnlonglegr", "ɺ"; + "\\textturnm", "ɯ"; + "\\textturnmrleg", "ɰ"; + "\\textturnr", "ɹ"; + "\\textturnrrtail", "ɻ"; + "\\textturnscripta", "ɒ"; + "\\textturnv", "ʌ"; + "\\textturnw", "ʍ"; + "\\textturny", "ʎ"; + "\\textupsilon", "ʊ"; + "\\textyogh", "ʒ"; + "\\th", "þ"; + "\\therefore", "∴"; + "\\theta", "θ"; + "\\h", "θ"; + "\\thickapprox", "≈"; + "\\thicksim", "∼"; + "\\times", "×"; + "\\top", "⊤"; + "\\trademark", "™"; + "\\triangle", "△"; + "\\triangledown", "▽"; + "\\triangleleft", "◁"; + "\\trianglelefteq", "⊴"; + "\\triangleq", "≜"; + "\\triangleright", "▷"; + "\\trianglerighteq", "⊵"; + "\\twoheadleftarrow", "↞"; + "\\twoheadrightarrow", "↠"; + "\\unlhd", "⊴"; + "\\unrhd", "⊵"; + "\\uparrow", "↑"; + "\\updownarrow", "↕"; + "\\upharpoonleft", "↿"; + "\\upharpoonright", "↾"; + "\\uplus", "⊎"; + "\\upsilon", "υ"; + "\\upuparrows", "⇈"; + "\\uranus", "⛢"; + "\\vDash", "⊨"; + "\\varepsilon", "ε"; + "\\varkappa", "ϰ"; + "\\varnothing", "∅"; + "\\varphi", "ϕ"; + "\\varpi", "ϖ"; + "\\varpropto", "∝"; + "\\varrho", "ϱ"; + "\\varsigma", "ς"; + "\\vartheta", "ϑ"; + "\\vartriangle", "△"; + "\\vartriangleleft", "⊲"; + "\\vartriangleright", "⊳"; + "\\vdash", "⊢"; + "\\vdots", "⋮"; + "\\vee", "∨"; + "\\veebar", "⊻"; + "\\venus", "♀"; + "\\virgo", "♍"; + "\\wedge", "∧"; + "\\whitebishop", "♗"; + "\\whiteking", "♔"; + "\\whiteknight", "♘"; + "\\whitepawn", "♙"; + "\\whitequeen", "♕"; + "\\whiterook", "♖"; + "\\wp", "℘"; + "\\wr", "≀"; + "\\xi", "ξ"; + "\\zeta", "ζ"; + + (* Double accent *) + "\\\"A", "Ä"; + "\\\"E", "Ë"; + "\\\"H", "Ḧ"; + "\\\"I", "Ï"; + "\\\"O", "Ö"; + "\\\"U", "Ü"; + "\\\"W", "Ẅ"; + "\\\"X", "Ẍ"; + "\\\"Y", "Ÿ"; + "\\\"a", "ä"; + "\\\"e", "ë"; + "\\\"h", "ḧ"; + "\\\"i", "ï"; + "\\\"o", "ö"; + "\\\"t", "ẗ"; + "\\\"u", "ü"; + "\\\"w", "ẅ"; + "\\\"x", "ẍ"; + "\\\"y", "ÿ"; + + (* Acute accent *) + "\\'A", "Á"; + "\\'C", "Ć"; + "\\'E", "É"; + "\\'G", "Ǵ"; + "\\'I", "Í"; + "\\'K", "Ḱ"; + "\\'L", "Ĺ"; + "\\'M", "Ḿ"; + "\\'N", "Ń"; + "\\'O", "Ó"; + "\\'P", "Ṕ"; + "\\'R", "Ŕ"; + "\\'S", "Ś"; + "\\'U", "Ú"; + "\\'W", "Ẃ"; + "\\'Y", "Ý"; + "\\'Z", "Ź"; + "\\'a", "á"; + "\\'c", "ć"; + "\\'e", "é"; + "\\'g", "ǵ"; + "\\'i", "í"; + "\\'k", "ḱ"; + "\\'l", "ĺ"; + "\\'m", "ḿ"; + "\\'n", "ń"; + "\\'o", "ó"; + "\\'p", "ṕ"; + "\\'r", "ŕ"; + "\\'s", "ś"; + "\\'u", "ú"; + "\\'w", "ẃ"; + "\\'y", "ý"; + "\\'z", "ź"; + + (* Doted accent *) + "\\.A", "Ȧ"; + "\\.B", "Ḃ"; + "\\.C", "Ċ"; + "\\.D", "Ḋ"; + "\\.E", "Ė"; + "\\.F", "Ḟ"; + "\\.G", "Ġ"; + "\\.H", "Ḣ"; + "\\.I", "İ"; + "\\.M", "Ṁ"; + "\\.N", "Ṅ"; + "\\.O", "Ȯ"; + "\\.P", "Ṗ"; + "\\.R", "Ṙ"; + "\\.S", "Ṡ"; + "\\.T", "Ṫ"; + "\\.W", "Ẇ"; + "\\.X", "Ẋ"; + "\\.Y", "Ẏ"; + "\\.Z", "Ż"; + "\\.a", "ȧ"; + "\\.b", "ḃ"; + "\\.c", "ċ"; + "\\.d", "ḋ"; + "\\.e", "ė"; + "\\.f", "ḟ"; + "\\.g", "ġ"; + "\\.h", "ḣ"; + "\\.m", "ṁ"; + "\\.n", "ṅ"; + "\\.o", "ȯ"; + "\\.p", "ṗ"; + "\\.r", "ṙ"; + "\\.s", "ṡ"; + "\\.t", "ṫ"; + "\\.w", "ẇ"; + "\\.x", "ẋ"; + "\\.y", "ẏ"; + "\\.z", "ż"; + "\\doteq", "≐"; + "\\doteqdot", "≑"; + "\\dotplus", "∔"; + "\\dotA", "Ȧ"; + "\\dotB", "Ḃ"; + "\\dotC", "Ċ"; + "\\dotD", "Ḋ"; + "\\dotE", "Ė"; + "\\dotF", "Ḟ"; + "\\dotG", "Ġ"; + "\\dotH", "Ḣ"; + "\\dotI", "İ"; + "\\dotM", "Ṁ"; + "\\dotN", "Ṅ"; + "\\dotO", "Ȯ"; + "\\dotP", "Ṗ"; + "\\dotR", "Ṙ"; + "\\dotS", "Ṡ"; + "\\dotT", "Ṫ"; + "\\dotW", "Ẇ"; + "\\dotX", "Ẋ"; + "\\dotY", "Ẏ"; + "\\dotZ", "Ż"; + "\\dota", "ȧ"; + "\\dotb", "ḃ"; + "\\dotc", "ċ"; + "\\dotd", "ḋ"; + "\\dote", "ė"; + "\\dotf", "ḟ"; + "\\dotg", "ġ"; + "\\doth", "ḣ"; + "\\dotm", "ṁ"; + "\\dotn", "ṅ"; + "\\doto", "ȯ"; + "\\dotp", "ṗ"; + "\\dotr", "ṙ"; + "\\dots", "ṡ"; + "\\dott", "ṫ"; + "\\dotw", "ẇ"; + "\\dotx", "ẋ"; + "\\doty", "ẏ"; + "\\dotz", "ż"; + "\\dA", "Ạ"; + "\\dB", "Ḅ"; + "\\dD", "Ḍ"; + "\\dE", "Ẹ"; + "\\dH", "Ḥ"; + "\\dI", "Ị"; + "\\dK", "Ḳ"; + "\\dL", "Ḷ"; + "\\dM", "Ṃ"; + "\\dN", "Ṇ"; + "\\dO", "Ọ"; + "\\dR", "Ṛ"; + "\\dS", "Ṣ"; + "\\dT", "Ṭ"; + "\\dU", "Ụ"; + "\\dV", "Ṿ"; + "\\dW", "Ẉ"; + "\\dY", "Ỵ"; + "\\dZ", "Ẓ"; + "\\da", "ạ"; + "\\db", "ḅ"; + "\\dd", "ḍ"; + "\\de", "ẹ"; + "\\dh", "ḥ"; + "\\di", "ị"; + "\\dk", "ḳ"; + "\\dl", "ḷ"; + "\\dm", "ṃ"; + "\\dn", "ṇ"; + "\\do", "ọ"; + "\\dr", "ṛ"; + "\\ds", "ṣ"; + "\\dt", "ṭ"; + "\\du", "ụ"; + "\\dv", "ṿ"; + "\\dw", "ẉ"; + "\\dy", "ỵ"; + "\\dz", "ẓ"; + + (* Double dot accent *) + "\\ddots", "⋱"; + "\\ddotA", "Ä"; + "\\ddotE", "Ë"; + "\\ddotH", "Ḧ"; + "\\ddotI", "Ï"; + "\\ddotO", "Ö"; + "\\ddotU", "Ü"; + "\\ddotW", "Ẅ"; + "\\ddotX", "Ẍ"; + "\\ddotY", "Ÿ"; + "\\ddota", "ä"; + "\\ddote", "ë"; + "\\ddoth", "ḧ"; + "\\ddoti", "ï"; + "\\ddoto", "ö"; + "\\ddott", "ẗ"; + "\\ddotu", "ü"; + "\\ddotw", "ẅ"; + "\\ddotx", "ẍ"; + "\\ddoty", "ÿ"; + + (* Breve accent *) + "\\breveA", "Ă"; + "\\breveE", "Ĕ"; + "\\breveG", "Ğ"; + "\\breveI", "Ĭ"; + "\\breveO", "Ŏ"; + "\\breveU", "Ŭ"; + "\\brevea", "ă"; + "\\brevee", "ĕ"; + "\\breveg", "ğ"; + "\\brevei", "ĭ"; + "\\breveo", "ŏ"; + "\\breveu", "ŭ"; + "\\uA", "Ă"; + "\\uE", "Ĕ"; + "\\uG", "Ğ"; + "\\uI", "Ĭ"; + "\\uO", "Ŏ"; + "\\uU", "Ŭ"; + "\\ua", "ă"; + "\\ue", "ĕ"; + "\\ug", "ğ"; + "\\ui", "ĭ"; + "\\uo", "ŏ"; + "\\uu", "ŭ"; + + (* Check accent *) + "\\checkA", "Ǎ"; + "\\checkC", "Č"; + "\\checkD", "Ď"; + "\\checkE", "Ě"; + "\\checkN", "Ň"; + "\\checkR", "Ř"; + "\\checkS", "Š"; + "\\checkT", "Ť"; + "\\checkZ", "Ž"; + "\\checka", "ǎ"; + "\\checkc", "č"; + "\\checkd", "ď"; + "\\checke", "ě"; + "\\checkn", "ň"; + "\\checkr", "ř"; + "\\checks", "š"; + "\\checkt", "ť"; + "\\checkz", "ž"; + "\\vA", "Ǎ"; + "\\vC", "Č"; + "\\vD", "Ď"; + "\\vE", "Ě"; + "\\vN", "Ň"; + "\\vR", "Ř"; + "\\vS", "Š"; + "\\vT", "Ť"; + "\\vZ", "Ž"; + "\\va", "ǎ"; + "\\vc", "č"; + "\\vd", "ď"; + "\\ve", "ě"; + "\\vn", "ň"; + "\\vr", "ř"; + "\\vs", "š"; + "\\vt", "ť"; + "\\vz", "ž"; + + (* Bar accent *) + "\\=A", "Ā"; + "\\=E", "Ē"; + "\\=G", "Ḡ"; + "\\=I", "Ī"; + "\\=O", "Ō"; + "\\=U", "Ū"; + "\\=Y", "Ȳ"; + "\\=a", "ā"; + "\\=e", "ē"; + "\\=g", "ḡ"; + "\\=i", "ī"; + "\\=o", "ō"; + "\\=u", "ū"; + "\\=y", "ȳ"; + "\\AA", "Å"; + "\\AE", "Æ"; + "\\barA", "Ā"; + "\\barE", "Ē"; + "\\barG", "Ḡ"; + "\\barI", "Ī"; + "\\barO", "Ō"; + "\\barU", "Ū"; + "\\barY", "Ȳ"; + "\\bara", "ā"; + "\\bare", "ē"; + "\\barg", "ḡ"; + "\\bari", "ī"; + "\\baro", "ō"; + "\\baru", "ū"; + "\\bary", "ȳ"; + + (* Hat acccent *) + "\\^A", "Â"; + "\\^C", "Ĉ"; + "\\^E", "Ê"; + "\\^G", "Ĝ"; + "\\^H", "Ĥ"; + "\\^I", "Î"; + "\\^J", "Ĵ"; + "\\^O", "Ô"; + "\\^S", "Ŝ"; + "\\^U", "Û"; + "\\^W", "Ŵ"; + "\\^Y", "Ŷ"; + "\\^Z", "Ẑ"; + "\\^a", "â"; + "\\^c", "ĉ"; + "\\^e", "ê"; + "\\^g", "ĝ"; + "\\^h", "ĥ"; + "\\^i", "î"; + "\\^j", "ĵ"; + "\\^o", "ô"; + "\\^s", "ŝ"; + "\\^u", "û"; + "\\^w", "ŵ"; + "\\^y", "ŷ"; + "\\^z", "ẑ"; + + (* Backquote acccent *) + "\\`A", "À"; + "\\`E", "È"; + "\\`I", "Ì"; + "\\`N", "Ǹ"; + "\\`O", "Ò"; + "\\`U", "Ù"; + "\\`W", "Ẁ"; + "\\`Y", "Ỳ"; + "\\`a", "à"; + "\\`e", "è"; + "\\`i", "ì"; + "\\`n", "ǹ"; + "\\`o", "ò"; + "\\`u", "ù"; + "\\`w", "ẁ"; + "\\`y", "ỳ"; + + (* Tiled acccent *) + "\\~A", "Ā"; + "\\~E", "Ẽ"; + "\\~I", "Ĩ"; + "\\~N", "Ñ"; + "\\~O", "Õ"; + "\\~U", "Ũ"; + "\\~Y", "Ỹ"; + "\\~a", "ã"; + "\\~e", "ẽ"; + "\\~i", "ĩ"; + "\\~n", "ñ"; + "\\~o", "õ"; + "\\~u", "ũ"; + "\\~y", "ỹ"; + + (* textrt font *) + "\\textrtaild", "ɖ"; + "\\textrtaill", "ɭ"; + "\\textrtailn", "ɳ"; + "\\textrtailr", "ɽ"; + "\\textrtails", "ʂ"; + "\\textrtailt", "ʈ"; + "\\textrtailz", "ʐ"; + + (* textsc font *) + "\\textscb", "ʙ"; + "\\textscg", "ɢ"; + "\\textsch", "ʜ"; + "\\textschwa", "ə"; + "\\textsci", "ɪ"; + "\\textscl", "ʟ"; + "\\textscn", "ɴ"; + "\\textscoelig", "ɶ"; + "\\textscr", "ʀ"; + "\\textscripta", "ɑ"; + "\\textscriptv", "ʋ"; + "\\textscy", "ʏ"; + + (* bb font *) + "\\bb0", "𝟘"; + "\\bb1", "𝟙"; + "\\bb2", "𝟚"; + "\\bb3", "𝟛"; + "\\bb4", "𝟜"; + "\\bb5", "𝟝"; + "\\bb6", "𝟞"; + "\\bb7", "𝟟"; + "\\bb8", "𝟠"; + "\\bb9", "𝟡"; + "\\bbA", "𝔸"; + "\\bbB", "𝔹"; + "\\bbC", "ℂ"; + "\\bbD", "𝔻"; + "\\bbE", "𝔼"; + "\\bbF", "𝔽"; + "\\bbG", "𝔾"; + "\\bbH", "ℍ"; + "\\bbI", "𝕀"; + "\\bbJ", "𝕁"; + "\\bbK", "𝕂"; + "\\bbL", "𝕃"; + "\\bbM", "𝕄"; + "\\bbN", "ℕ"; + "\\bbO", "𝕆"; + "\\bbP", "ℙ"; + "\\bbQ", "ℚ"; + "\\bbR", "ℝ"; + "\\bbS", "𝕊"; + "\\bbT", "𝕋"; + "\\bbU", "𝕌"; + "\\bbV", "𝕍"; + "\\bbW", "𝕎"; + "\\bbX", "𝕏"; + "\\bbY", "𝕐"; + "\\bbZ", "ℤ"; + "\\bba", "𝕒"; + "\\bbb", "𝕓"; + "\\bbc", "𝕔"; + "\\bbd", "𝕕"; + "\\bbe", "𝕖"; + "\\bbf", "𝕗"; + "\\bbg", "𝕘"; + "\\bbh", "𝕙"; + "\\bbi", "𝕚"; + "\\bbj", "𝕛"; + "\\bbk", "𝕜"; + "\\bbl", "𝕝"; + "\\bbm", "𝕞"; + "\\bbn", "𝕟"; + "\\bbo", "𝕠"; + "\\bbp", "𝕡"; + "\\bbq", "𝕢"; + "\\bbr", "𝕣"; + "\\bbs", "𝕤"; + "\\bbt", "𝕥"; + "\\bbu", "𝕦"; + "\\bbv", "𝕧"; + "\\bbw", "𝕨"; + "\\bbx", "𝕩"; + "\\bby", "𝕪"; + "\\bbz", "𝕫"; + + (* cal font *) + "\\calA", "𝒜"; + "\\calB", "ℬ"; + "\\calC", "𝒞"; + "\\calD", "𝒟"; + "\\calE", "ℰ"; + "\\calF", "ℱ"; + "\\calG", "𝒢"; + "\\calH", "ℋ"; + "\\calI", "ℐ"; + "\\calJ", "𝒥"; + "\\calK", "𝒦"; + "\\calL", "ℒ"; + "\\calM", "ℳ"; + "\\calN", "𝒩"; + "\\calO", "𝒪"; + "\\calP", "𝒫"; + "\\calQ", "𝒬"; + "\\calR", "ℛ"; + "\\calS", "𝒮"; + "\\calT", "𝒯"; + "\\calU", "𝒰"; + "\\calV", "𝒱"; + "\\calW", "𝒲"; + "\\calX", "𝒳"; + "\\calY", "𝒴"; + "\\calZ", "𝒵"; + "\\cala", "𝒶"; + "\\calb", "𝒷"; + "\\calc", "𝒸"; + "\\cald", "𝒹"; + "\\cale", "ℯ"; + "\\calf", "𝒻"; + "\\calg", "ℊ"; + "\\calh", "𝒽"; + "\\cali", "𝒾"; + "\\calj", "𝒿"; + "\\calk", "𝓀"; + "\\call", "𝓁"; + "\\calm", "𝓂"; + "\\caln", "𝓃"; + "\\calo", "ℴ"; + "\\calp", "𝓅"; + "\\calq", "𝓆"; + "\\calr", "𝓇"; + "\\cals", "𝓈"; + "\\calt", "𝓉"; + "\\calu", "𝓊"; + "\\calv", "𝓋"; + "\\calw", "𝓌"; + "\\calx", "𝓍"; + "\\caly", "𝓎"; + "\\calz", "𝓏"; + + (* frak font *) + "\\frakA", "𝔄"; + "\\frakB", "𝔅"; + "\\frakC", "ℭ"; + "\\frakD", "𝔇"; + "\\frakE", "𝔈"; + "\\frakF", "𝔉"; + "\\frakG", "𝔊"; + "\\frakH", "ℌ"; + "\\frakI", "ℑ"; + "\\frakJ", "𝔍"; + "\\frakK", "𝔎"; + "\\frakL", "𝔏"; + "\\frakM", "𝔐"; + "\\frakN", "𝔑"; + "\\frakO", "𝔒"; + "\\frakP", "𝔓"; + "\\frakQ", "𝔔"; + "\\frakR", "ℜ"; + "\\frakS", "𝔖"; + "\\frakT", "𝔗"; + "\\frakU", "𝔘"; + "\\frakV", "𝔙"; + "\\frakW", "𝔚"; + "\\frakX", "𝔛"; + "\\frakY", "𝔜"; + "\\frakZ", "ℨ"; + "\\fraka", "𝔞"; + "\\frakb", "𝔟"; + "\\frakc", "𝔠"; + "\\frakd", "𝔡"; + "\\frake", "𝔢"; + "\\frakf", "𝔣"; + "\\frakg", "𝔤"; + "\\frakh", "𝔥"; + "\\fraki", "𝔦"; + "\\frakj", "𝔧"; + "\\frakk", "𝔨"; + "\\frakl", "𝔩"; + "\\frakm", "𝔪"; + "\\frakn", "𝔫"; + "\\frako", "𝔬"; + "\\frakp", "𝔭"; + "\\frakq", "𝔮"; + "\\frakr", "𝔯"; + "\\fraks", "𝔰"; + "\\frakt", "𝔱"; + "\\fraku", "𝔲"; + "\\frakv", "𝔳"; + "\\frakw", "𝔴"; + "\\frakx", "𝔵"; + "\\fraky", "𝔶"; + "\\frakz", "𝔷"; + + (* Exponent *) + "\\^(", "⁽"; + "\\^)", "⁾"; + "\\^+", "⁺"; + "\\^-", "⁻"; + "\\^0", "⁰"; + "\\^1", "¹"; + "\\^2", "²"; + "\\^3", "³"; + "\\^4", "⁴"; + "\\^5", "⁵"; + "\\^6", "⁶"; + "\\^7", "⁷"; + "\\^8", "⁸"; + "\\^9", "⁹"; + "\\^=", "⁼"; + "\\^A", "ᴬ"; + "\\^B", "ᴮ"; + "\\^D", "ᴰ"; + "\\^E", "ᴱ"; + "\\^G", "ᴳ"; + "\\^H", "ᴴ"; + "\\^I", "ᴵ"; + "\\^J", "ᴶ"; + "\\^K", "ᴷ"; + "\\^L", "ᴸ"; + "\\^M", "ᴹ"; + "\\^N", "ᴺ"; + "\\^O", "ᴼ"; + "\\^P", "ᴾ"; + "\\^R", "ᴿ"; + "\\^T", "ᵀ"; + "\\^U", "ᵁ"; + "\\^V", "ⱽ"; + "\\^W", "ᵂ"; + "\\^alpha", "ᵅ"; + "\\^beta", "ᵝ"; + "\\^chi", "ᵡ"; + "\\^delta", "ᵟ"; + "\\^epsilon", "ᵋ"; + "\\^gamma", "ᵞ"; + "\\^iota", "ᶥ"; + "\\^phi", "ᶲ"; + "\\^theta", "ᶿ"; + "\\^varphi", "ᵠ"; + "\\^a", "ᵃ"; + "\\^b", "ᵇ"; + "\\^c", "ᶜ"; + "\\^d", "ᵈ"; + "\\^e", "ᵉ"; + "\\^f", "ᶠ"; + "\\^g", "ᵍ"; + "\\^h", "ʰ"; + "\\^i", "ⁱ"; + "\\^j", "ʲ"; + "\\^k", "ᵏ"; + "\\^l", "ˡ"; + "\\^m", "ᵐ"; + "\\^n", "ⁿ"; + "\\^o", "ᵒ"; + "\\^p", "ᵖ"; + "\\^r", "ʳ"; + "\\^s", "ˢ"; + "\\^t", "ᵗ"; + "\\^u", "ᵘ"; + "\\^v", "ᵛ"; + "\\^w", "ʷ"; + "\\^x", "ˣ"; + "\\^y", "ʸ"; + "\\^z", "ᶻ"; + + (* Subscript *) + "\\_(", "₍"; + "\\_)", "₎"; + "\\_+", "₊"; + "\\_-", "₋"; + "\\_0", "₀"; + "\\_1", "₁"; + "\\_2", "₂"; + "\\_3", "₃"; + "\\_4", "₄"; + "\\_5", "₅"; + "\\_6", "₆"; + "\\_7", "₇"; + "\\_8", "₈"; + "\\_9", "₉"; + "\\_=", "₌"; + "\\_beta", "ᵦ"; + "\\_chi", "ᵪ"; + "\\_gamma", "ᵧ"; + "\\_rho", "ᵨ"; + "\\_varphi", "ᵩ"; + "\\_a", "ₐ"; + "\\_e", "ₑ"; + "\\_h", "ₕ"; + "\\_i", "ᵢ"; + "\\_j", "ⱼ"; + "\\_k", "ₖ"; + "\\_l", "ₗ"; + "\\_m", "ₘ"; + "\\_n", "ₙ"; + "\\_o", "ₒ"; + "\\_p", "ₚ"; + "\\_r", "ᵣ"; + "\\_s", "ₛ"; + "\\_t", "ₜ"; + "\\_u", "ᵤ"; + "\\_v", "ᵥ"; + "\\_x", "ₓ"; + +] + + +(** **************************************************************************) +(** * Priorities *) + +(** Set priorities, at the moment only for greek letters *) + +let priorities = [ +(* {{{ greek letters *) + "\\alpha", 1; + "\\beta", 1; + "\\gamma", 1; + "\\delta", 1; + "\\epsilon", 1; + "\\zeta", 1; + "\\eta", 2; + "\\theta", 2; + "\\iota", 1; + "\\kappa", 1; + "\\lambda", 1; + "\\mu", 1; + "\\nu", 1; + "\\xi", 1; + "\\o", 1; + "\\pi", 1; + "\\rho", 1; + "\\sigma", 1; + "\\tau", 1; + "\\upsilon", 1; + "\\phi", 2; + "\\chi", 1; + "\\psi", 2; + "\\omega", 2; + "\\Gamma", 1; + "\\Delta", 1; + "\\Theta", 2; + "\\Lambda", 1; + "\\Xi", 1; + "\\Pi", 1; + "\\Sigma", 1; + "\\Upsilon", 1; + "\\Phi", 2; + "\\Psi", 2; + "\\Omega", 1; +(* }}} *) +] + + +(** **************************************************************************) +(** * Binding generator *) + +let filename = + let args = Sys.argv in + if Array.length args < 2 + then failwith "please provide output filename as argument"; + Sys.argv.(1) + +let _ = (* generate output file *) + let bindings = ref [] in + let add (key,value) = + bindings := (key,value)::!bindings in + (* add bindings from set 1 *) + List.iter (fun (keys,value,_group) -> + List.iter (fun key -> add (key,value)) keys) bindings_set_1; + (* add bindings from set 2 *) + List.iter add bindings_set_2; + (* create table for priorities lookup *) + let priotable = Hashtbl.create 20 in + List.iter (fun (key,prio) -> Hashtbl.add priotable key prio) priorities; + (* remove duplicates and sort *) + let outbindings = List.sort_uniq (fun (key1,_) (key2,_) -> String.compare key1 key2) !bindings in + (* print bindings into file, including optional priorities *) + let file = open_out filename in + let print_binding (key,value) = + Printf.fprintf file "%s %s" key value; + begin match Hashtbl.find_opt priotable key with + | Some prio -> Printf.fprintf file " %d" prio + | None -> () + end; + Printf.fprintf file "\n" + in + List.iter print_binding outbindings; + close_out file + + +(** **************************************************************************) +(** * Groups of similar shapes *) + +(* For future use. + +let predefined_classes = [ + ["&"; "⅋"; ]; + ["|"; "∥"; ]; + ["!"; "¡"; "⫯"; "⫰"; "⟟"; "⫱"; ]; + ["?"; "¿"; "⸮"; ]; + [":"; "⁝"; ]; + ["."; "•"; "◦"; ]; + ["#"; "♯"; "⋕"; "⧣"; "⧤"; "⌘"; ]; + ["+"; "⊞"; ]; + ["-"; "÷"; "⊢"; "⊩"; "⊟"; ]; + ["="; "≝"; "≡"; "⩬"; "≂"; "≃"; "≈"; "≅"; "≗"; "≐"; "≑"; "≚"; "≙"; "⌆"; "⊜"; ]; + ["→"; "↦"; "⇝"; "⤞"; "⇾"; "⤍"; "⤏"; "⤳"; ] ; + ["⇒"; "⤇"; "➾"; "⇨"; "➡"; "⬈"; "➤"; "➸"; "⇉"; "⥰"; ] ; + ["^"; "↑"; ] ; + ["⇑"; "⇧"; "⬆"; ] ; + ["⇓"; "⇩"; "⬇"; "⬊"; "➷"; ] ; + ["⇕"; "⇳"; "⬍"; ]; + ["↔"; "⇔"; "⬄"; "⬌"; ] ; + ["≤"; "≲"; "≼"; "≰"; "≴"; "⋠"; "⊆"; "⫃"; "⊑"; ] ; + ["_"; "↓"; "↙"; "⎽"; "⎼"; "⎻"; "⎺"; ]; + ["<"; "≺"; "≮"; "⊀"; "〈"; "«"; "❬"; "❮"; "❰"; ] ; + ["("; "❨"; "❪"; "❲"; "（"; ]; + [")"; "❩"; "❫"; "❳"; "）"; ]; + ["["; "⦋"; "〚"; ] ; + ["]"; "⦌"; "〛"; ] ; + ["{"; "❴"; "⦃" ] ; + ["}"; "❵"; "⦄" ] ; + ["□"; "◽"; "▪"; "◾"; ]; + ["◊"; "♢"; "⧫"; "♦"; "⟐"; "⟠"; ] ; + [">"; "⭃"; "⧁"; "〉"; "»"; "❭"; "❯"; "❱"; "▸"; "►"; "▶"; "⊃"; "⊐"; ] ; + ["≥"; "⪀"; "≽"; "⪴"; "⥸"; "⊒"; ]; + ["∨"; "⩖"; "∪"; "∩"; "⋓"; "⋒" ] ; + ["a"; "α"; "𝕒"; "𝐚"; "𝛂"; "ⓐ"; ] ; + ["A"; "ℵ"; "𝔸"; "𝐀"; "Ⓐ"; ] ; + ["b"; "β"; "ß"; "𝕓"; "𝐛"; "𝛃"; "ⓑ"; ] ; + ["B"; "ℶ"; "ℬ"; "𝔹"; "𝐁"; "Ⓑ"; ] ; + ["c"; "𝕔"; "𝐜"; "ⓒ"; ] ; + ["C"; "ℭ"; "∁"; "𝐂"; "Ⓒ"; ] ; + ["d"; "δ"; "∂"; "𝕕"; "ⅆ"; "𝐝"; "𝛅"; "ⓓ"; ] ; + ["D"; "Δ"; "𝔻"; "ⅅ"; "𝐃"; "𝚫"; "Ⓓ"; ] ; + ["e"; "ɛ"; "ε"; "ϵ"; "Є"; "ℯ"; "𝕖"; "ⅇ"; "𝐞"; "𝛆"; "𝛜"; "ⓔ"; ] ; + ["E"; "ℰ"; "𝔼"; "𝐄"; "Ⓔ"; ] ; + ["f"; "φ"; "ψ"; "ϕ"; "⨍"; "𝕗"; "𝐟"; "𝛟"; "𝛙"; "ⓕ"; ] ; + ["F"; "Φ"; "Ψ"; "ℱ"; "𝔽"; "𝐅"; "𝚽"; "𝚿"; "Ⓕ"; ] ; + ["g"; "γ"; "ℊ"; "𝕘"; "𝐠"; "𝛄"; "ⓖ"; ] ; + ["G"; "Γ"; "𝔾"; "𝐆"; "𝚪"; "Ⓖ"; ] ; + ["h"; "η"; "ℌ"; "ℎ"; "𝕙"; "𝐡"; "ⓗ"; ] ; + ["H"; "ℋ"; "ℍ"; "𝐇"; "Ⓗ"; ] ; + ["i"; "ι"; "ℐ"; "𝕚"; "ⅈ"; "𝐢"; "𝛊"; "ⓘ"; ] ; + ["I"; "𝕀"; "𝐈"; "Ⓘ"; ] ; + ["j"; "𝕛"; "𝐣"; "ⓙ"; ] ; + ["J"; "Ј"; "𝕁"; "𝐉"; "Ⓙ"; ] ; + ["k"; "κ"; "𝕜"; "𝐤"; "𝛋"; "ⓚ"; ] ; + ["K"; "𝕂"; "𝐊"; "Ⓚ"; ] ; + ["l"; "λ"; "𝕝"; "𝐥"; "𝛌"; "ⓛ"; ] ; + ["L"; "Λ"; "𝕃"; "𝐋"; "𝚲"; "Ⓛ"; ] ; + ["m"; "μ"; "𝕞"; "𝐦"; "𝛍"; "ⓜ"; ] ; + ["M"; "ℳ"; "𝕄"; "𝐌"; "Ⓜ"; ] ; + ["n"; "𝕟"; "𝐧"; "𝛈"; "ⓝ"; ] ; + ["N"; "ℕ"; "№"; "𝐍"; "Ⓝ"; ] ; + ["o"; "θ"; "ϑ"; "𝕠"; "∘"; "⊚"; "ø"; "○"; "𝐨"; "𝛉"; "ⓞ"; ] ; + ["O"; "Θ"; "𝕆"; "𝐎"; "𝚯"; "𝚹"; "Ⓞ"; ] ; + ["p"; "π"; "𝕡"; "𝐩"; "𝛑"; "ⓟ"; ] ; + ["P"; "Π"; "℘"; "ℙ"; "𝐏"; "𝚷"; "Ⓟ"; ] ; + ["q"; "𝕢"; "𝐪"; "ⓠ"; ] ; + ["Q"; "ℚ"; "𝐐"; "Ⓠ"; ] ; + ["r"; "ρ"; "ϱ"; "𝕣"; "𝐫"; "𝛒"; "𝛠"; "ⓡ"; ] ; + ["R"; "ℛ"; "ℜ"; "ℝ"; "𝐑"; "Ⓡ"; ] ; + ["s"; "σ"; "ς"; "𝕤"; "𝐬"; "𝛔"; "ⓢ"; ] ; + ["S"; "Σ"; "𝕊"; "𝐒"; "𝚺"; "Ⓢ"; ] ; + ["t"; "τ"; "𝕥"; "𝐭"; "𝛕"; "ⓣ"; ] ; + ["T"; "𝕋"; "𝐓"; "Ⓣ"; "⊥"; ] ; + ["u"; "𝕦"; "𝐮"; "ⓤ"; ] ; + ["U"; "𝕌"; "𝐔"; "Ⓤ"; ] ; + ["v"; "ν"; "𝕧"; "𝐯"; "𝛖"; "𝛎"; "ⓥ"; "▼"; ] ; + ["V"; "𝕍"; "𝐕"; "Ⓥ"; ] ; + ["w"; "ω"; "𝕨"; "𝐰"; "𝛚"; "ⓦ"; ] ; + ["W"; "Ω"; "𝕎"; "𝐖"; "𝛀"; "Ⓦ"; ] ; + ["x"; "ξ"; "χ"; "ϰ"; "𝕩"; "𝐱"; "𝛏"; "𝛘"; "𝛞"; "ⓧ"; ] ; + ["X"; "Ξ"; "𝕏";"𝐗"; "𝚵"; "Ⓧ"; "⦻"; ] ; + ["y"; "υ"; "𝕪"; "𝐲"; "ⓨ"; ] ; + ["Y"; "ϒ"; "𝕐"; "𝐘"; "𝚼"; "Ⓨ"; ] ; + ["z"; "ζ"; "𝕫"; "𝐳"; "𝛇"; "ⓩ"; ] ; + ["Z"; "ℨ"; "ℤ"; "𝐙"; "Ⓩ"; ] ; + ["0"; "𝟘"; "⓪"; ] ; + ["1"; "𝟙"; "①"; "⓵"; ] ; + ["2"; "𝟚"; "②"; "⓶"; ] ; + ["3"; "𝟛"; "③"; "⓷"; ] ; + ["4"; "𝟜"; "④"; "⓸"; ] ; + ["5"; "𝟝"; "⑤"; "⓹"; ] ; + ["6"; "𝟞"; "⑥"; "⓺"; ] ; + ["7"; "𝟟"; "⑦"; "⓻"; ] ; + ["8"; "𝟠"; "⑧"; "⓼"; "∞"; ] ; + ["9"; "𝟡"; "⑨"; "⓽"; ] ; + ] + +*) @@ -27,9 +27,9 @@ (library (name coqide_gui) (wrapped false) - (modules (:standard \ document fake_ide idetop coqide_main)) + (modules (:standard \ document fake_ide idetop coqide_main default_bindings_src)) (optional) - (libraries coqide-server.protocol coqide-server.core lablgtk2.sourceview2)) + (libraries coqide-server.protocol coqide-server.core lablgtk3-sourceview3)) (rule (targets coqide_os_specific.ml) @@ -43,6 +43,16 @@ (modules coqide_main) (libraries coqide_gui)) +; Input-method bindings +(executable + (name default_bindings_src) + (modules default_bindings_src)) + +(rule + (targets default.bindings) + (deps (:gen ./default_bindings_src.exe)) + (action (run %{gen} %{targets}))) + ; FIXME: we should install those in share/coqide. We better do this ; once the make-based system has been phased out. (install @@ -50,6 +60,7 @@ (package coqide) (files (coq.png as coq/coq.png) + (default.bindings as coq/default.bindings) (coq_style.xml as coq/coq_style.xml) (coq.lang as coq/coq.lang) (coq-ssreflect.lang as coq/coq-ssreflect.lang))) diff --git a/ide/ide.mllib b/ide/ide.mllib index a7ade71307..ed6520f29f 100644 --- a/ide/ide.mllib +++ b/ide/ide.mllib @@ -9,8 +9,8 @@ Config_lexer Utf8_convert Preferences Project_file -Topfmt Ideutils +Unicode_bindings Coq Coq_lex Sentence diff --git a/ide/idetop.ml b/ide/idetop.ml index 608577b297..f744ce2ee3 100644 --- a/ide/idetop.ml +++ b/ide/idetop.ml @@ -231,30 +231,30 @@ let goals () = let doc = get_doc () in set_doc @@ Stm.finish ~doc; try - let newp = Proof_global.give_me_the_proof () in + let newp = Vernacstate.Proof_global.give_me_the_proof () in if Proof_diffs.show_diffs () then begin let oldp = Stm.get_prev_proof ~doc (Stm.get_current_state ~doc) in let diff_goal_map = Proof_diffs.make_goal_map oldp newp in Some (export_pre_goals Proof.(data newp) (process_goal_diffs diff_goal_map oldp)) end else Some (export_pre_goals Proof.(data newp) process_goal) - with Proof_global.NoCurrentProof -> None;; + with Vernacstate.Proof_global.NoCurrentProof -> None;; let evars () = try let doc = get_doc () in set_doc @@ Stm.finish ~doc; - let pfts = Proof_global.give_me_the_proof () in + let pfts = Vernacstate.Proof_global.give_me_the_proof () in let Proof.{ sigma } = Proof.data pfts in let exl = Evar.Map.bindings (Evd.undefined_map sigma) in let map_evar ev = { Interface.evar_info = string_of_ppcmds (pr_evar sigma ev); } in let el = List.map map_evar exl in Some el - with Proof_global.NoCurrentProof -> None + with Vernacstate.Proof_global.NoCurrentProof -> None let hints () = try - let pfts = Proof_global.give_me_the_proof () in + let pfts = Vernacstate.Proof_global.give_me_the_proof () in let Proof.{ goals; sigma } = Proof.data pfts in match goals with | [] -> None @@ -263,7 +263,7 @@ let hints () = let get_hint_hyp env d accu = hyp_next_tac sigma env d :: accu in let hint_hyps = List.rev (Environ.fold_named_context get_hint_hyp env ~init: []) in Some (hint_hyps, concl_next_tac) - with Proof_global.NoCurrentProof -> None + with Vernacstate.Proof_global.NoCurrentProof -> None (** Other API calls *) @@ -284,11 +284,11 @@ let status force = List.rev_map Names.Id.to_string l in let proof = - try Some (Names.Id.to_string (Proof_global.get_current_proof_name ())) - with Proof_global.NoCurrentProof -> None + try Some (Names.Id.to_string (Vernacstate.Proof_global.get_current_proof_name ())) + with Vernacstate.Proof_global.NoCurrentProof -> None in let allproofs = - let l = Proof_global.get_all_proof_names () in + let l = Vernacstate.Proof_global.get_all_proof_names () in List.map Names.Id.to_string l in { @@ -336,7 +336,8 @@ let import_search_constraint = function | Interface.Include_Blacklist -> Search.Include_Blacklist let search flags = - List.map export_coq_object (Search.interface_search ( + let pstate = Vernacstate.Proof_global.get () in + List.map export_coq_object (Search.interface_search ?pstate ( List.map (fun (c, b) -> (import_search_constraint c, b)) flags) ) diff --git a/ide/ideutils.ml b/ide/ideutils.ml index 5beaba3604..8c5b3fcc5b 100644 --- a/ide/ideutils.ml +++ b/ide/ideutils.ml @@ -8,9 +8,10 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) - open Preferences +let _ = GtkMain.Main.init () + let warn_image () = let img = GMisc.image () in img#set_stock `DIALOG_WARNING; @@ -229,14 +230,17 @@ let current_dir () = match project_path#get with | None -> "" | Some dir -> dir -let select_file_for_open ~title ?filename () = +let select_file_for_open ~title ?(filter=true) ?parent ?filename () = let file_chooser = - GWindow.file_chooser_dialog ~action:`OPEN ~modal:true ~title () + GWindow.file_chooser_dialog ~action:`OPEN ~modal:true ~title ?parent () in file_chooser#add_button_stock `CANCEL `CANCEL ; file_chooser#add_select_button_stock `OPEN `OPEN ; - file_chooser#add_filter (filter_coq_files ()); - file_chooser#add_filter (filter_all_files ()); + if filter then + begin + file_chooser#add_filter (filter_coq_files ()); + file_chooser#add_filter (filter_all_files ()) + end; file_chooser#set_default_response `OPEN; let dir = match filename with | None -> current_dir () @@ -255,10 +259,10 @@ let select_file_for_open ~title ?filename () = file_chooser#destroy (); file -let select_file_for_save ~title ?filename () = +let select_file_for_save ~title ?parent ?filename () = let file = ref None in let file_chooser = - GWindow.file_chooser_dialog ~action:`SAVE ~modal:true ~title () + GWindow.file_chooser_dialog ~action:`SAVE ~modal:true ~title ?parent () in file_chooser#add_button_stock `CANCEL `CANCEL ; file_chooser#add_select_button_stock `SAVE `SAVE ; diff --git a/ide/ideutils.mli b/ide/ideutils.mli index 531c71cd4b..57f59d19fe 100644 --- a/ide/ideutils.mli +++ b/ide/ideutils.mli @@ -30,9 +30,10 @@ val find_tag_limits : GText.tag -> GText.iter -> GText.iter * GText.iter val find_tag_start : GText.tag -> GText.iter -> GText.iter val find_tag_stop : GText.tag -> GText.iter -> GText.iter -val select_file_for_open : title:string -> ?filename:string -> unit -> string option +val select_file_for_open : + title:string -> ?filter:bool -> ?parent:GWindow.window -> ?filename:string -> unit -> string option val select_file_for_save : - title:string -> ?filename:string -> unit -> string option + title:string -> ?parent:GWindow.window -> ?filename:string -> unit -> string option val try_convert : string -> string val try_export : string -> string -> bool val stock_to_widget : diff --git a/ide/nanoPG.ml b/ide/nanoPG.ml index f2913b1d1d..d85d87142c 100644 --- a/ide/nanoPG.ml +++ b/ide/nanoPG.ml @@ -52,7 +52,7 @@ let pr_key t = type action = | Action of string * string | Callback of (gui -> unit) - | Edit of (status -> GSourceView2.source_buffer -> GText.iter -> + | Edit of (status -> GSourceView3.source_buffer -> GText.iter -> (string -> string -> unit) -> status) | Motion of (status -> GText.iter -> GText.iter * status) diff --git a/ide/preferences.ml b/ide/preferences.ml index fb0eea1405..e04001974e 100644 --- a/ide/preferences.ml +++ b/ide/preferences.ml @@ -12,10 +12,10 @@ open Configwin let pref_file = Filename.concat (Minilib.coqide_config_home ()) "coqiderc" let accel_file = Filename.concat (Minilib.coqide_config_home ()) "coqide.keys" -let lang_manager = GSourceView2.source_language_manager ~default:true +let lang_manager = GSourceView3.source_language_manager ~default:true let () = lang_manager#set_search_path ((Minilib.coqide_data_dirs ())@lang_manager#search_path) -let style_manager = GSourceView2.source_style_scheme_manager ~default:true +let style_manager = GSourceView3.source_style_scheme_manager ~default:true let () = style_manager#set_search_path ((Minilib.coqide_data_dirs ())@style_manager#search_path) @@ -28,6 +28,7 @@ type tag = { tag_strikethrough : bool; } + (** Generic preferences *) type obj = { @@ -73,11 +74,11 @@ object (self) method default = default end -let stick (pref : 'a preference) (obj : #GObj.widget as 'obj) +let stick (pref : 'a preference) (obj : < connect : #GObj.widget_signals ; .. >) (cb : 'a -> unit) = let _ = cb pref#get in let p_id = pref#connect#changed ~callback:(fun v -> cb v) in - let _ = obj#misc#connect#destroy ~callback:(fun () -> pref#connect#disconnect p_id) in + let _ = obj#connect#destroy ~callback:(fun () -> pref#connect#disconnect p_id) in () (** Useful marshallers *) @@ -248,6 +249,18 @@ let loaded_accel_file = try get_config_file "coqide.keys" with Not_found -> Filename.concat (Option.default "" (Glib.get_home_dir ())) ".coqide.keys" +let get_unicode_bindings_local_file () = + try Some (get_config_file "coqide.bindings") + with Not_found -> None + +let get_unicode_bindings_default_file () = + let name = "default.bindings" in + let chk d = Sys.file_exists (Filename.concat d name) in + try + let dir = List.find chk (Minilib.coqide_data_dirs ()) in + Some (Filename.concat dir name) + with Not_found -> None + (** Hooks *) (** New style preferences *) @@ -326,7 +339,7 @@ let modifier_for_navigation = let modifier_for_templates = new preference ~name:["modifier_for_templates"] ~init:"<Control><Shift>" ~repr:Repr.(string) - + let modifier_for_tactics = new preference ~name:["modifier_for_tactics"] ~init:"<Control><Alt>" ~repr:Repr.(string) @@ -413,8 +426,11 @@ let attach_fg (pref : string preference) (tag : GText.tag) = let processing_color = new preference ~name:["processing_color"] ~init:"light blue" ~repr:Repr.(string) +let incompletely_processed_color = + new preference ~name:["incompletely_processed_color"] ~init:"light sky blue" ~repr:Repr.(string) + let _ = attach_bg processing_color Tags.Script.to_process -let _ = attach_bg processing_color Tags.Script.incomplete +let _ = attach_bg incompletely_processed_color Tags.Script.incomplete let tags = ref Util.String.Map.empty @@ -575,7 +591,7 @@ object (self) | None -> set#set_active true | Some c -> set#set_active false; - but#set_color (Tags.color_of_string c) + but#set_color (Gdk.Color.color_parse c) in track tag.tag_bg_color bg_color bg_unset; track tag.tag_fg_color fg_color fg_unset; @@ -587,7 +603,7 @@ object (self) method tag = let get but set = if set#active then None - else Some (Tags.string_of_color but#color) + else Some (Gdk.Color.color_to_string but#color) in { tag_bg_color = get bg_color bg_unset; @@ -644,13 +660,13 @@ let save_pref () = let load_pref () = let () = try GtkData.AccelMap.load loaded_accel_file with _ -> () in - let m = Config_lexer.load_file loaded_pref_file in - let iter name v = - if Util.String.Map.mem name !preferences then - try (Util.String.Map.find name !preferences).set v with _ -> () - else unknown_preferences := Util.String.Map.add name v !unknown_preferences - in - Util.String.Map.iter iter m + let m = Config_lexer.load_file loaded_pref_file in + let iter name v = + if Util.String.Map.mem name !preferences then + try (Util.String.Map.find name !preferences).set v with _ -> () + else unknown_preferences := Util.String.Map.add name v !unknown_preferences + in + Util.String.Map.iter iter m let pstring name p = string ~f:p#set name p#get let pbool name p = bool ~f:p#set name p#get @@ -691,7 +707,7 @@ let configure ?(apply=(fun () -> ())) parent = let config_color = let box = GPack.vbox () in - let table = GPack.table + let grid = GPack.grid ~row_spacings:5 ~col_spacings:5 ~border_width:2 @@ -703,19 +719,19 @@ let configure ?(apply=(fun () -> ())) parent = in let iter i (text, pref) = let label = GMisc.label - ~text ~packing:(table#attach ~expand:`X ~left:0 ~top:i) () + ~text ~packing:(grid#attach (*~expand:`X*) ~left:0 ~top:i) () in let () = label#set_xalign 0. in let button = GButton.color_button - ~color:(Tags.color_of_string pref#get) - ~packing:(table#attach ~left:1 ~top:i) () + ~color:(Gdk.Color.color_parse pref#get) + ~packing:(grid#attach ~left:1 ~top:i) () in let _ = button#connect#color_set ~callback:begin fun () -> - pref#set (Tags.string_of_color button#color) + pref#set (Gdk.Color.color_to_string button#color) end in let reset _ = pref#reset (); - button#set_color Tags.(color_of_string pref#get) + button#set_color (Gdk.Color.color_parse pref#get) in let _ = reset_button#connect#clicked ~callback:reset in () @@ -724,6 +740,7 @@ let configure ?(apply=(fun () -> ())) parent = ("Background color", background_color); ("Background color of processed text", processed_color); ("Background color of text being processed", processing_color); + ("Background color of incompletely processed Qed", incompletely_processed_color); ("Background color of errors", error_color); ("Foreground color of errors", error_fg_color); ] in @@ -740,7 +757,7 @@ let configure ?(apply=(fun () -> ())) parent = ~packing:(box#pack ~expand:true) () in - let table = GPack.table + let grid = GPack.grid ~row_spacings:5 ~col_spacings:5 ~border_width:2 @@ -750,13 +767,13 @@ let configure ?(apply=(fun () -> ())) parent = let cb = ref [] in let iter text tag = let label = GMisc.label - ~text ~packing:(table#attach ~expand:`X ~left:0 ~top:!i) () + ~text ~packing:(grid#attach (*~expand:`X*) ~left:0 ~top:!i) () in let () = label#set_xalign 0. in let button = tag_button () in let callback () = tag#set button#tag in button#set_tag tag#get; - table#attach ~left:1 ~top:!i button#coerce; + grid#attach ~left:1 ~top:!i button#coerce; incr i; cb := callback :: !cb; in @@ -921,6 +938,7 @@ let configure ?(apply=(fun () -> ())) parent = else cmd_browse#get]) cmd_browse#get in +(* let automatic_tactics = strings ~f:automatic_tactics#set @@ -929,12 +947,14 @@ let configure ?(apply=(fun () -> ())) parent = automatic_tactics#get in +*) let contextual_menus_on_goal = pbool "Contextual menus on goal" contextual_menus_on_goal in let misc = [contextual_menus_on_goal;stop_before;reset_on_tab_switch; vertical_tabs;opposite_tabs] in +(* let add_user_query () = let input_string l v = match GToolbox.input_string ~title:l v with @@ -964,6 +984,7 @@ let configure ?(apply=(fun () -> ())) parent = user_queries#get in +*) (* ATTENTION !!!!! L'onglet Fonts doit etre en premier pour eviter un bug !!!! (shame on Benjamin) *) @@ -987,12 +1008,14 @@ let configure ?(apply=(fun () -> ())) parent = Section("Externals", None, [cmd_coqtop;cmd_coqc;cmd_make;cmd_coqmakefile; cmd_coqdoc; cmd_print;cmd_editor;cmd_browse]); +(* Section("Tactics Wizard", None, [automatic_tactics]); +*) Section("Shortcuts", Some `PREFERENCES, [modifiers_valid; modifier_for_tactics; modifier_for_templates; modifier_for_display; modifier_for_navigation; - modifier_for_queries; user_queries]); + modifier_for_queries (*; user_queries *)]); Section("Misc", Some `ADD, misc)] in diff --git a/ide/preferences.mli b/ide/preferences.mli index cf2265781c..d2f1b5ba29 100644 --- a/ide/preferences.mli +++ b/ide/preferences.mli @@ -8,8 +8,8 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -val lang_manager : GSourceView2.source_language_manager -val style_manager : GSourceView2.source_style_scheme_manager +val lang_manager : GSourceView3.source_language_manager +val style_manager : GSourceView3.source_style_scheme_manager type project_behavior = Ignore_args | Append_args | Subst_args type inputenc = Elocale | Eutf8 | Emanual of string @@ -47,6 +47,10 @@ end val list_tags : unit -> tag preference Util.String.Map.t +val get_unicode_bindings_local_file : unit -> string option +val get_unicode_bindings_default_file : unit -> string option + + val cmd_coqtop : string option preference val cmd_coqc : string preference val cmd_make : string preference @@ -108,6 +112,6 @@ val load_pref : unit -> unit val configure : ?apply:(unit -> unit) -> GWindow.window -> unit val stick : 'a preference -> - (#GObj.widget as 'obj) -> ('a -> unit) -> unit + < connect : #GObj.widget_signals ; .. > -> ('a -> unit) -> unit val use_default_doc_url : string diff --git a/ide/session.ml b/ide/session.ml index e2427a9b51..fd21515ca5 100644 --- a/ide/session.ml +++ b/ide/session.ml @@ -47,7 +47,7 @@ type session = { } let create_buffer () = - let buffer = GSourceView2.source_buffer + let buffer = GSourceView3.source_buffer ~tag_table:Tags.Script.table ~highlight_matching_brackets:true ?language:(lang_manager#language source_language#get) @@ -257,7 +257,7 @@ let make_table_widget ?sort cd cb = ~model:store ~packing:frame#add () in let () = data#set_headers_visible true in let () = data#set_headers_clickable true in - let refresh clr = data#misc#modify_base [`NORMAL, `NAME clr] in + let refresh clr = data#misc#modify_bg [`NORMAL, `NAME clr] in let _ = background_color#connect#changed ~callback:refresh in let _ = data#misc#connect#realize ~callback:(fun () -> refresh background_color#get) in let mk_rend c = GTree.cell_renderer_text [], ["text",c] in @@ -442,11 +442,11 @@ let build_layout (sn:session) = let eval_paned = GPack.paned `HORIZONTAL ~border_width:5 ~packing:(session_box#pack ~expand:true) () in let script_frame = GBin.frame ~shadow_type:`IN - ~packing:eval_paned#add1 () in + ~packing:(eval_paned#pack1 ~shrink:false) () in let script_scroll = GBin.scrolled_window ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC ~packing:script_frame#add () in let state_paned = GPack.paned `VERTICAL - ~packing:eval_paned#add2 () in + ~packing:(eval_paned#pack2 ~shrink:false) () in (* Proof buffer. *) diff --git a/ide/tags.ml b/ide/tags.ml index 60195e8acb..e9dbcb9e67 100644 --- a/ide/tags.ml +++ b/ide/tags.ml @@ -24,7 +24,7 @@ struct let error_bg = make_tag table ~name:"error_bg" [] let to_process = make_tag table ~name:"to_process" [] let processed = make_tag table ~name:"processed" [] - let incomplete = make_tag table ~name:"incomplete" [`BACKGROUND_STIPPLE_SET true] + let incomplete = make_tag table ~name:"incomplete" [] let unjustified = make_tag table ~name:"unjustified" [`BACKGROUND "gold"] let tooltip = make_tag table ~name:"tooltip" [] (* debug:`BACKGROUND "blue" *) let ephemere = @@ -48,13 +48,3 @@ struct let warning = make_tag table ~name:"warning" [`FOREGROUND "orange"] let item = make_tag table ~name:"item" [`WEIGHT `BOLD] end - -let string_of_color clr = - let r = Gdk.Color.red clr in - let g = Gdk.Color.green clr in - let b = Gdk.Color.blue clr in - Printf.sprintf "#%04X%04X%04X" r g b - -let color_of_string s = - let colormap = Gdk.Color.get_system_colormap () in - Gdk.Color.alloc ~colormap (`NAME s) diff --git a/ide/tags.mli b/ide/tags.mli index 3194f87971..1df934fddf 100644 --- a/ide/tags.mli +++ b/ide/tags.mli @@ -41,6 +41,3 @@ sig val warning : GText.tag val item : GText.tag end - -val string_of_color : Gdk.color -> string -val color_of_string : string -> Gdk.color diff --git a/ide/unicode_bindings.ml b/ide/unicode_bindings.ml new file mode 100644 index 0000000000..e2f98302ea --- /dev/null +++ b/ide/unicode_bindings.ml @@ -0,0 +1,131 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + + +let all_bindings = ref [] + (* example unicode bindings table: + [ ("\\pi", "π", None); + ("\\lambdas", "λs", Some 4); + ("\\lambda", "λ", Some 3); + ("\\lake", "0", Some 2); + ("\\lemma", "Lemma foo : x. Proof. Qed", Some 1); ] *) + +(** Auxiliary function used by [load_files]. + Takes as argument a valid path. *) + +let process_file filename = + if not (Sys.file_exists filename) then begin + Ideutils.warning (Printf.sprintf "Warning: unicode bindings file '%s' was not found." filename) + end else begin + let ch = open_in filename in + begin try while true do + let line = input_line ch in + begin try + let chline = Scanf.Scanning.from_string line in + let (key,value) = + Scanf.bscanf chline "%s %s" (fun x y -> (x,y)) in + let prio = + try Scanf.bscanf chline " %d" (fun x -> Some x) + with Scanf.Scan_failure _ | Failure _ | End_of_file -> None + in + all_bindings := (key,value,prio)::!all_bindings; + (* Note: storing bindings in reverse order, flipping is done later *) + Scanf.Scanning.close_in chline; + with End_of_file -> () end; + done with End_of_file -> () end; + close_in ch + end + +let load_files filenames = + let selected_filenames = ref [] in + let add f = + selected_filenames := f::!selected_filenames in + let warn_default_not_found () = + Ideutils.warning (Printf.sprintf + "Warning: the file 'ide/default.bindings' was not found in %s." + (Envars.coqlib())) in + let warn_local_not_found () = + Ideutils.warning (Printf.sprintf + "Warning: the local configuration file 'coqide.bindings' was not found.") in + if filenames = [] then begin + (* If no argument is provided using [-unicode-bindings], + then use the default file and the local file, if it exists *) + begin match Preferences.get_unicode_bindings_default_file() with + | Some f -> add f + | None -> warn_default_not_found() + end; + begin match Preferences.get_unicode_bindings_local_file() with + | Some f -> add f + | None -> () + end; + end else begin + (* If [-unicode-bindings] is used with a list of file, consider + these files in order, with a special treatment for the tokens + "default" and "local", which are replaced by the appropriate path. *) + let add_arg f = + match f with + | "default" -> + begin match Preferences.get_unicode_bindings_default_file() with + | Some f -> add f + | None -> warn_default_not_found() + end + | "local" -> + begin match Preferences.get_unicode_bindings_local_file() with + | Some f -> add f + | None -> warn_local_not_found() + end + | _ -> add f + in + List.iter add_arg filenames + end; + (* Files must be processed in order, to build the list of bindings + by iteratively consing entry to its head, the list being reversed + at the very end *) + let real_filenames = List.rev !selected_filenames in + List.iter process_file real_filenames; + all_bindings := List.rev !all_bindings + (* For debugging the list of unicode files loaded: + List.iter (fun f -> Printf.eprintf "%s\n" f) real_filenames; *) + +(** Auxiliary function to test whether [s] is a prefix of [str]; + Note that there might be overlap with wg_Completion::is_substring *) + +let string_is_prefix s str = + let n = String.length s in + let m = String.length str in + if m < n + then false + else (s = String.sub str 0 n) + +let lookup prefix = + let max_priority = 100000000 in + let cur_word = ref None in + let cur_prio = ref (max_priority+1) in + let test_binding (key, word, prio_opt) = + let prio = + match prio_opt with + | None -> max_priority + | Some p -> p + in + if string_is_prefix prefix key && prio < !cur_prio then begin + cur_word := Some word; + cur_prio := prio; + end in + List.iter test_binding !all_bindings; + !cur_word + + +(* For debugging the list of unicode bindings loaded: + let print_unicode_bindings () = + List.iter (fun (x,y,p) -> + Printf.eprintf "%s %s %d\n" x y (match p with None -> -1 | Some n -> n)) + !all_bindings; + prerr_newline() +*) diff --git a/ide/unicode_bindings.mli b/ide/unicode_bindings.mli new file mode 100644 index 0000000000..5b38eeb920 --- /dev/null +++ b/ide/unicode_bindings.mli @@ -0,0 +1,48 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + + +(** Latex to unicode bindings. + See also the documentation in doc/sphinx/practical-tools/coqide.rst. + + Text description of the unicode bindings, in a file with one item per line, + each item consists of: + - a leading backslahs + - a ascii word next to it + - a unicode word (or possibly a full sentence in-between doube-quotes, + the sentence may include spaces and \n tokens), + - optionally, an integer indicating the "priority" (lower is higher priority), + technically the length of the prefix that suffices to obtain this word. + Ex. if "\lambda" has priority 3, then "\lam" always decodes as "\lambda". + + \pi π + \lambda λ 3 + \lambdas λs 4 + \lake Ο 2 + \lemma "Lemma foo : x. Proof. Qed." 1 ---currently not supported by the parser + + - In case of equality between two candidates (same ascii word, or same + priorities for two words with similar prefix), the first binding is considered. + + - Note that if a same token is bound in several bindings file, + the one with the lowest priority number will be considered. + In case of same priority, the binding from the first file loaded + is considered. +*) + + +(** [load_files] takes a list of filenames and load them as binding files. + Filenames may include "default" and "local" as items. *) + +val load_files : string list -> unit + +(** [lookup] takes a prefix and returns the corresponding unicode value *) + +val lookup : string -> string option diff --git a/ide/wg_Command.ml b/ide/wg_Command.ml index 06281d6287..be400a5f2d 100644 --- a/ide/wg_Command.ml +++ b/ide/wg_Command.ml @@ -100,10 +100,10 @@ object(self) router#register_route route_id result; r_bin#add_with_viewport (result :> GObj.widget); views <- (frame#coerce, result, combo#entry) :: views; - let cb clr = result#misc#modify_base [`NORMAL, `NAME clr] in + let cb clr = result#misc#modify_bg [`NORMAL, `NAME clr] in let _ = background_color#connect#changed ~callback:cb in let _ = result#misc#connect#realize ~callback:(fun () -> cb background_color#get) in - let cb ft = result#misc#modify_font (Pango.Font.from_string ft) in + let cb ft = result#misc#modify_font (GPango.font_description_from_string ft) in stick text_font result cb; result#misc#set_can_focus true; (* false causes problems for selection *) let callback () = @@ -163,8 +163,8 @@ object(self) frame#visible method private refresh_color clr = - let clr = Tags.color_of_string clr in - let iter (_,view,_) = view#misc#modify_base [`NORMAL, `COLOR clr] in + let clr = Gdk.Color.color_parse clr in + let iter (_,view,_) = view#misc#modify_bg [`NORMAL, `COLOR clr] in List.iter iter views initializer diff --git a/ide/wg_Detachable.ml b/ide/wg_Detachable.ml index d753687077..755a42eadd 100644 --- a/ide/wg_Detachable.ml +++ b/ide/wg_Detachable.ml @@ -15,6 +15,9 @@ class type detachable_signals = method detached : callback:(GObj.widget -> unit) -> unit end +(* Cannot do a local warning in 4.05.0, fixme when we use a newer + OCaml to avoid the warning in the method itself. *) +[@@@ocaml.warning "-7"] class detachable (obj : ([> Gtk.box] as 'a) Gobject.obj) = object(self) diff --git a/ide/wg_Find.ml b/ide/wg_Find.ml index 7d2d7da570..fe079e8a9e 100644 --- a/ide/wg_Find.ml +++ b/ide/wg_Find.ml @@ -14,10 +14,10 @@ class finder name (view : GText.view) = let widget = Wg_Detachable.detachable ~title:(Printf.sprintf "Find & Replace (%s)" name) () in - let replace_box = GPack.table ~columns:4 ~rows:2 ~homogeneous:false + let replace_box = GPack.grid (* ~columns:4 ~rows:2 *) ~col_homogeneous:false ~row_homogeneous:false ~packing:widget#add () in let hb = GPack.hbox ~packing:(replace_box#attach - ~left:1 ~top:0 ~expand:`X ~fill:`X) () in + ~left:1 ~top:0 (*~expand:`X ~fill:`X*)) () in let use_regex = GButton.check_button ~label:"Regular expression" ~packing:(hb#pack ~expand:false ~fill:true ~padding:3) () in @@ -26,25 +26,25 @@ class finder name (view : GText.view) = ~packing:(hb#pack ~expand:false ~fill:true ~padding:3) () in let _ = GMisc.label ~text:"Find:" ~xalign:1.0 ~packing:(replace_box#attach - ~xpadding:3 ~ypadding:3 ~left:0 ~top:1 ~fill:`X) () in + (*~xpadding:3 ~ypadding:3*) ~left:0 ~top:1 (*~fill:`X*)) () in let _ = GMisc.label ~text:"Replace:" ~xalign:1.0 ~packing:(replace_box#attach - ~xpadding:3 ~ypadding:3 ~left:0 ~top:2 ~fill:`X) () in + (* ~xpadding:3 ~ypadding:3*) ~left:0 ~top:2 (*~fill:`X*)) () in let find_entry = GEdit.entry ~editable:true ~packing:(replace_box#attach - ~xpadding:3 ~ypadding:3 ~left:1 ~top:1 ~expand:`X ~fill:`X) () in + (*~xpadding:3 ~ypadding:3*) ~left:1 ~top:1 (*~expand:`X ~fill:`X*)) () in let replace_entry = GEdit.entry ~editable:true ~packing:(replace_box#attach - ~xpadding:3 ~ypadding:3 ~left:1 ~top:2 ~expand:`X ~fill:`X) () in + (*~xpadding:3 ~ypadding:3*) ~left:1 ~top:2 (*~expand:`X ~fill:`X*)) () in let next_button = GButton.button ~label:"_Next" ~use_mnemonic:true - ~packing:(replace_box#attach ~xpadding:3 ~ypadding:3 ~left:2 ~top:1) () in + ~packing:(replace_box#attach (*~xpadding:3 ~ypadding:3*) ~left:2 ~top:1) () in let previous_button = GButton.button ~label:"_Previous" ~use_mnemonic:true - ~packing:(replace_box#attach ~xpadding:3 ~ypadding:3 ~left:3 ~top:1) () in + ~packing:(replace_box#attach (*~xpadding:3 ~ypadding:3*) ~left:3 ~top:1) () in let replace_button = GButton.button ~label:"_Replace" ~use_mnemonic:true - ~packing:(replace_box#attach ~xpadding:3 ~ypadding:3 ~left:2 ~top:2) () in + ~packing:(replace_box#attach (*~xpadding:3 ~ypadding:3*) ~left:2 ~top:2) () in let replace_all_button = GButton.button ~label:"Replace _All" ~use_mnemonic:true - ~packing:(replace_box#attach ~xpadding:3 ~ypadding:3 ~left:3 ~top:2) () in + ~packing:(replace_box#attach (*~xpadding:3 ~ypadding:3*) ~left:3 ~top:2) () in object (self) val mutable last_found = None @@ -135,13 +135,13 @@ class finder name (view : GText.view) = view#buffer#end_user_action () method private set_not_found () = - find_entry#misc#modify_base [`NORMAL, `NAME "#F7E6E6"]; + find_entry#misc#modify_bg [`NORMAL, `NAME "#F7E6E6"]; method private set_found () = - find_entry#misc#modify_base [`NORMAL, `NAME "#BAF9CE"] + find_entry#misc#modify_bg [`NORMAL, `NAME "#BAF9CE"] method private set_normal () = - find_entry#misc#modify_base [`NORMAL, `NAME "white"] + find_entry#misc#modify_bg [`NORMAL, `NAME "white"] method private find_from backward ?(wrapped=false) (starti : GText.iter) = let found = diff --git a/ide/wg_MessageView.ml b/ide/wg_MessageView.ml index 6b09b344b5..7943b099fc 100644 --- a/ide/wg_MessageView.ml +++ b/ide/wg_MessageView.ml @@ -42,7 +42,7 @@ class type message_view = end let message_view () : message_view = - let buffer = GSourceView2.source_buffer + let buffer = GSourceView3.source_buffer ~highlight_matching_brackets:true ~tag_table:Tags.Message.table () in @@ -50,7 +50,7 @@ let message_view () : message_view = let box = GPack.vbox () in let scroll = GBin.scrolled_window ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC ~packing:(box#pack ~expand:true) () in - let view = GSourceView2.source_view + let view = GSourceView3.source_view ~source_buffer:buffer ~packing:scroll#add ~editable:false ~cursor_visible:false ~wrap_mode:`WORD () in @@ -59,10 +59,10 @@ let message_view () : message_view = let _ = buffer#add_selection_clipboard default_clipboard in let () = view#set_left_margin 2 in view#misc#show (); - let cb clr = view#misc#modify_base [`NORMAL, `NAME clr] in + let cb clr = view#misc#modify_bg [`NORMAL, `NAME clr] 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 + let cb ft = view#misc#modify_font (GPango.font_description_from_string ft) in stick text_font view cb; (* Inserts at point, advances the mark *) diff --git a/ide/wg_Notebook.mli b/ide/wg_Notebook.mli index 85ecdf6cdd..9447b21c0b 100644 --- a/ide/wg_Notebook.mli +++ b/ide/wg_Notebook.mli @@ -28,11 +28,10 @@ val create : ('a -> GObj.widget option * GObj.widget option * GObj.widget) -> ('a -> unit) -> ?enable_popup:bool -> - ?homogeneous_tabs:bool -> + ?group_name:string -> ?scrollable:bool -> ?show_border:bool -> ?show_tabs:bool -> - ?tab_border:int -> ?tab_pos:Gtk.Tags.position -> ?border_width:int -> ?width:int -> diff --git a/ide/wg_ProofView.ml b/ide/wg_ProofView.ml index 9be562d3ed..596df227b7 100644 --- a/ide/wg_ProofView.ml +++ b/ide/wg_ProofView.ml @@ -193,21 +193,21 @@ let display mode (view : #GText.view_skel) goals hints evars = let proof_view () = - let buffer = GSourceView2.source_buffer + let buffer = GSourceView3.source_buffer ~highlight_matching_brackets:true ~tag_table:Tags.Proof.table () in let text_buffer = new GText.buffer buffer#as_buffer in - let view = GSourceView2.source_view + let view = GSourceView3.source_view ~source_buffer:buffer ~editable:false ~wrap_mode:`WORD () in let () = Gtk_parsing.fix_double_click view in let default_clipboard = GData.clipboard Gdk.Atom.primary in let _ = buffer#add_selection_clipboard default_clipboard in - let cb clr = view#misc#modify_base [`NORMAL, `NAME clr] in + let cb clr = view#misc#modify_bg [`NORMAL, `NAME clr] 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 + let cb ft = view#misc#modify_font (GPango.font_description_from_string ft) in stick text_font view cb; let pf = object diff --git a/ide/wg_ScriptView.ml b/ide/wg_ScriptView.ml index 5e26c50797..8802eb0f1c 100644 --- a/ide/wg_ScriptView.ml +++ b/ide/wg_ScriptView.ml @@ -10,6 +10,8 @@ open Preferences +exception Abort + type insert_action = { ins_val : string; ins_off : int; @@ -284,12 +286,12 @@ end class script_view (tv : source_view) (ct : Coq.coqtop) = -let view = new GSourceView2.source_view (Gobject.unsafe_cast tv) in +let view = new GSourceView3.source_view (Gobject.unsafe_cast tv) in let completion = new Wg_Completion.complete_model ct view#buffer in let popup = new Wg_Completion.complete_popup completion (view :> GText.view) in object (self) - inherit GSourceView2.source_view (Gobject.unsafe_cast tv) + inherit GSourceView3.source_view (Gobject.unsafe_cast tv) val undo_manager = new undo_manager view#buffer @@ -405,6 +407,49 @@ object (self) self#buffer#delete_mark (`MARK stop_mark) | _ -> () + method apply_unicode_binding () = + (* Auxiliary method to reach the beginning of line or the + nearest space before the iterator. *) + let rec get_line_start iter = + if iter#starts_line || Glib.Unichar.isspace iter#char then iter + else get_line_start iter#backward_char + in + (* Main action *) + let buffer = self#buffer in + let insert = buffer#get_iter `INSERT in + let insert_mark = buffer#create_mark ~left_gravity:false insert in + let () = buffer#begin_user_action () in + let word_to_insert = + try + let line_start = get_line_start insert in + let prev_backslash_search = insert#backward_search ~limit:line_start "\\" in + let backslash = + match prev_backslash_search with + | None -> raise Abort + | Some (backslash_start,backslash_stop) -> backslash_start + in + let prefix = backslash#get_text ~stop:insert in + let word = + match Unicode_bindings.lookup prefix with + | None -> raise Abort + | Some word -> word + in + let was_deleted = buffer#delete_interactive ~start:backslash ~stop:insert () in + if not was_deleted then raise Abort; + word + with Abort -> " " + (* Insert a space if no binding applies. This is to make sure that the user + gets some visual feedback that the keystroke was taken into account. + And also avoid slowing down users who press "Shift" for capitalizing the + first letter of a sentence just before typing the "Space" that comes in + front of that first letter. *) + in + let insert2 = buffer#get_iter_at_mark (`MARK insert_mark) in + let _was_inserted = buffer#insert_interactive ~iter:insert2 word_to_insert in + let () = self#buffer#end_user_action () in + self#buffer#delete_mark (`MARK insert_mark) + + method complete_popup = popup method undo = undo_manager#undo @@ -461,7 +506,7 @@ object (self) in let _ = GtkSignal.connect ~sgn:move_line_signal ~callback obj in (* Plug on preferences *) - let cb clr = self#misc#modify_base [`NORMAL, `NAME clr] in + let cb clr = self#misc#modify_bg [`NORMAL, `NAME clr] in let _ = background_color#connect#changed ~callback:cb in let _ = self#misc#connect#realize ~callback:(fun () -> cb background_color#get) in @@ -484,24 +529,24 @@ object (self) stick tab_length self self#set_tab_width; stick auto_complete self self#set_auto_complete; - let cb ft = self#misc#modify_font (Pango.Font.from_string ft) in + let cb ft = self#misc#modify_font (GPango.font_description_from_string ft) in stick text_font self cb; () end -let script_view ct ?(source_buffer:GSourceView2.source_buffer option) ?draw_spaces = - GtkSourceView2.SourceView.make_params [] ~cont:( +let script_view ct ?(source_buffer:GSourceView3.source_buffer option) ?draw_spaces = + GtkSourceView3.SourceView.make_params [] ~cont:( GtkText.View.make_params ~cont:( GContainer.pack_container ~create: (fun pl -> let w = match source_buffer with - | None -> GtkSourceView2.SourceView.new_ () - | Some buf -> GtkSourceView2.SourceView.new_with_buffer + | None -> GtkSourceView3.SourceView.new_ () + | Some buf -> GtkSourceView3.SourceView.new_with_buffer (Gobject.try_cast buf#as_buffer "GtkSourceBuffer") in let w = Gobject.unsafe_cast w in Gobject.set_params (Gobject.try_cast w "GtkSourceView") pl; - Gaux.may ~f:(GtkSourceView2.SourceView.set_draw_spaces w) draw_spaces; + Gaux.may ~f:(GtkSourceView3.SourceView.set_draw_spaces w) draw_spaces; ((new script_view w ct) : script_view)))) diff --git a/ide/wg_ScriptView.mli b/ide/wg_ScriptView.mli index be6510dbe2..a2e341c128 100644 --- a/ide/wg_ScriptView.mli +++ b/ide/wg_ScriptView.mli @@ -14,7 +14,7 @@ type source_view = [ Gtk.text_view | `sourceview ] Gtk.obj class script_view : source_view -> Coq.coqtop -> object - inherit GSourceView2.source_view + inherit GSourceView3.source_view method undo : unit -> unit method redo : unit -> unit method clear_undo : unit -> unit @@ -26,13 +26,14 @@ object method set_show_right_margin : bool -> unit method comment : unit -> unit method uncomment : unit -> unit + method apply_unicode_binding : unit -> unit method recenter_insert : unit method complete_popup : Wg_Completion.complete_popup end val script_view : Coq.coqtop -> - ?source_buffer:GSourceView2.source_buffer -> - ?draw_spaces:SourceView2Enums.source_draw_spaces_flags list -> + ?source_buffer:GSourceView3.source_buffer -> + ?draw_spaces:SourceView3Enums.source_draw_spaces_flags list -> ?auto_indent:bool -> ?highlight_current_line:bool -> ?indent_on_tab:bool -> @@ -42,7 +43,7 @@ val script_view : Coq.coqtop -> ?show_line_marks:bool -> ?show_line_numbers:bool -> ?show_right_margin:bool -> - ?smart_home_end:SourceView2Enums.source_smart_home_end_type -> + ?smart_home_end:SourceView3Enums.source_smart_home_end_type -> ?tab_width:int -> ?editable:bool -> ?cursor_visible:bool -> diff --git a/ide/wg_Segment.ml b/ide/wg_Segment.ml index 3b2572f9d2..b62c0a2190 100644 --- a/ide/wg_Segment.ml +++ b/ide/wg_Segment.ml @@ -33,6 +33,12 @@ let color_eq (c1 : GDraw.color) (c2 : GDraw.color) = match c1, c2 with | `WHITE, `WHITE -> true | _ -> false +let set_cairo_color ctx c = + let open Gdk.Color in + let c = GDraw.color c in + let cast i = i2f i /. 65536. in + Cairo.set_source_rgb ctx (cast @@ red c) (cast @@ green c) (cast @@ blue c) + class type segment_signals = object inherit GObj.misc_signals @@ -50,8 +56,8 @@ end class segment () = let box = GBin.frame () in -let eventbox = GBin.event_box ~packing:box#add () in -let draw = GMisc.image ~packing:eventbox#add () in +let draw = GMisc.drawing_area ~packing:box#add () in + object (self) inherit GObj.widget box#as_widget @@ -60,53 +66,40 @@ object (self) val mutable height = 20 val mutable model : model option = None val mutable default : color = `WHITE - val mutable pixmap : GDraw.pixmap = GDraw.pixmap ~width:1 ~height:1 () val clicked = new GUtil.signal () - val mutable need_refresh = false - val refresh_timer = Ideutils.mktimer () initializer box#misc#set_size_request ~height (); let cb rect = let w = rect.Gtk.width in let h = rect.Gtk.height in - (* Only refresh when size actually changed, otherwise loops *) - if self#misc#visible && (width <> w || height <> h) then begin - width <- w; - height <- h; - self#redraw (); - end + width <- w; + height <- h in let _ = box#misc#connect#size_allocate ~callback:cb in + let () = draw#event#add [`BUTTON_PRESS] in let clicked_cb ev = match model with | None -> true | Some md -> let x = GdkEvent.Button.x ev in - let (width, _) = pixmap#size in let len = md#length in let idx = f2i ((x *. i2f len) /. i2f width) in let () = clicked#call idx in true in - let _ = eventbox#event#connect#button_press ~callback:clicked_cb in + let _ = draw#event#connect#button_press ~callback:clicked_cb in let cb show = if show then self#misc#show () else self#misc#hide () in stick show_progress_bar self cb; - (* Initial pixmap *) - draw#set_pixmap pixmap; - refresh_timer.Ideutils.run ~ms:300 - ~callback:(fun () -> if need_refresh then self#refresh (); true) + let cb ctx = self#refresh ctx; false in + let _ = draw#misc#connect#draw ~callback:cb in + () method set_model md = model <- Some md; - let changed_cb = function - | `INSERT | `REMOVE -> - if self#misc#visible then need_refresh <- true - | `SET (i, color) -> - if self#misc#visible then self#fill_range color i (i + 1) - in + let changed_cb _ = self#misc#queue_draw () in md#changed ~callback:changed_cb - method private fill_range color i j = match model with + method private fill_range ctx color i j = match model with | None -> () | Some md -> let i = i2f i in @@ -116,24 +109,19 @@ object (self) let x = f2i ((i *. width) /. len) in let x' = f2i ((j *. width) /. len) in let w = x' - x in - pixmap#set_foreground color; - pixmap#rectangle ~x ~y:0 ~width:w ~height ~filled:true (); - draw#set_mask None; + set_cairo_color ctx color; + Cairo.rectangle ctx (i2f x) 0. ~w:(i2f w) ~h:(i2f height); + Cairo.fill ctx method set_default_color color = default <- color method default_color = default - method private redraw () = - pixmap <- GDraw.pixmap ~width ~height (); - draw#set_pixmap pixmap; - self#refresh (); - - method private refresh () = match model with + method private refresh ctx = match model with | None -> () | Some md -> - need_refresh <- false; - pixmap#set_foreground default; - pixmap#rectangle ~x:0 ~y:0 ~width ~height ~filled:true (); + set_cairo_color ctx default; + Cairo.rectangle ctx 0. 0. ~w:(i2f width) ~h:(i2f height); + Cairo.fill ctx; let make (k, cur, accu) v = match cur with | None -> pred k, Some (k, k, v), accu | Some (i, j, w) -> @@ -145,8 +133,7 @@ object (self) | None -> segments | Some p -> p :: segments in - List.iter (fun (i, j, v) -> self#fill_range v i (j + 1)) segments; - draw#set_mask None; + List.iter (fun (i, j, v) -> self#fill_range ctx v i (j + 1)) segments method connect = new segment_signals_impl box#as_widget clicked diff --git a/interp/constrextern.ml b/interp/constrextern.ml index d5cb25d1fb..c2afa097bb 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -1314,7 +1314,10 @@ let rec glob_of_pat avoid env sigma pat = DAst.make @@ match pat with Array.map (fun (bl,_,_) -> bl) v, Array.map (fun (_,_,ty) -> ty) v, Array.map (fun (_,bd,_) -> bd) v) - | PSort s -> GSort s + | PSort Sorts.InSProp -> GSort GSProp + | PSort Sorts.InProp -> GSort GProp + | PSort Sorts.InSet -> GSort GSet + | PSort Sorts.InType -> GSort (GType []) | PInt i -> GInt i let extern_constr_pattern env sigma pat = diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 5ede9d6a99..349402035c 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -956,7 +956,7 @@ let intern_var env (ltacvars,ntnvars) namedctx loc id us = (str "variable " ++ Id.print id ++ str " should be bound to a term.") else (* Is [id] a goal or section variable *) - let _ = Context.Named.lookup id namedctx in + let _ = Environ.lookup_named_ctxt id namedctx in try (* [id] a section variable *) (* Redundant: could be done in intern_qualid *) @@ -1095,7 +1095,8 @@ let interp_reference vars r = let (r,_,_,_),_ = intern_applied_reference (fun _ -> error_not_enough_arguments ?loc:None) {ids = Id.Set.empty; unb = false ; - tmp_scope = None; scopes = []; impls = empty_internalization_env} [] + tmp_scope = None; scopes = []; impls = empty_internalization_env} + Environ.empty_named_context_val (vars, Id.Map.empty) None [] r in r @@ -1826,7 +1827,7 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = let rec intern env = CAst.with_loc_val (fun ?loc -> function | CRef (ref,us) -> let (c,imp,subscopes,l),_ = - intern_applied_reference intern env (Environ.named_context globalenv) + intern_applied_reference intern env (Environ.named_context_val globalenv) lvar us [] ref in apply_impargs c env imp subscopes l loc @@ -1932,7 +1933,7 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = | CAppExpl ((isproj,ref,us), args) -> let (f,_,args_scopes,_),args = let args = List.map (fun a -> (a,None)) args in - intern_applied_reference intern env (Environ.named_context globalenv) + intern_applied_reference intern env (Environ.named_context_val globalenv) lvar us args ref in (* Rem: GApp(_,f,[]) stands for @f *) @@ -1950,7 +1951,7 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = match f.CAst.v with | CRef (ref,us) -> intern_applied_reference intern env - (Environ.named_context globalenv) lvar us args ref + (Environ.named_context_val globalenv) lvar us args ref | CNotation (ntn,([],[],[],[])) -> let c = intern_notation intern env ntnvars loc ntn ([],[],[],[]) in let x, impl, scopes, l = find_appl_head_data c in diff --git a/kernel/constr.ml b/kernel/constr.ml index 11958c9108..d74c96af84 100644 --- a/kernel/constr.ml +++ b/kernel/constr.ml @@ -860,7 +860,7 @@ let compare_head_gen_leq_with kind1 kind2 leq_universes leq_sorts eq leq nargs t | App (c1, l1), App (c2, l2) -> let len = Array.length l1 in Int.equal len (Array.length l2) && - eq (nargs+len) c1 c2 && Array.equal_norefl (eq 0) l1 l2 + leq (nargs+len) c1 c2 && Array.equal_norefl (eq 0) l1 l2 | Proj (p1,c1), Proj (p2,c2) -> Projection.equal p1 p2 && eq 0 c1 c2 | Evar (e1,l1), Evar (e2,l2) -> Evar.equal e1 e2 && Array.equal (eq 0) l1 l2 | Const (c1,u1), Const (c2,u2) -> diff --git a/kernel/dune b/kernel/dune index a8a87a3e95..5b23a705ae 100644 --- a/kernel/dune +++ b/kernel/dune @@ -4,7 +4,7 @@ (public_name coq.kernel) (wrapped false) (modules (:standard \ genOpcodeFiles uint63_x86 uint63_amd64 write_uint63)) - (libraries lib byterun)) + (libraries lib byterun dynlink)) (executable (name genOpcodeFiles) diff --git a/kernel/inductive.ml b/kernel/inductive.ml index 7452038ba5..d9335d39b5 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -934,16 +934,30 @@ let check_one_fix renv recpos trees def = end | Case (ci,p,c_0,lrest) -> - List.iter (check_rec_call renv []) (c_0::p::l); - (* compute the recarg information for the arguments of - each branch *) - let case_spec = branches_specif renv - (lazy_subterm_specif renv [] c_0) ci in - let stack' = push_stack_closures renv l stack in - let stack' = filter_stack_domain renv.env p stack' in - Array.iteri (fun k br' -> - let stack_br = push_stack_args case_spec.(k) stack' in - check_rec_call renv stack_br br') lrest + begin try + List.iter (check_rec_call renv []) (c_0::p::l); + (* compute the recarg info for the arguments of each branch *) + let case_spec = + branches_specif renv (lazy_subterm_specif renv [] c_0) ci in + let stack' = push_stack_closures renv l stack in + let stack' = filter_stack_domain renv.env p stack' in + lrest |> Array.iteri (fun k br' -> + let stack_br = push_stack_args case_spec.(k) stack' in + check_rec_call renv stack_br br') + with (FixGuardError _ as exn) -> + let exn = CErrors.push exn in + (* we try hard to reduce the match away by looking for a + constructor in c_0 (we unfold definitions too) *) + let c_0 = whd_all renv.env c_0 in + let hd, _ = decompose_app c_0 in + match kind hd with + | Construct _ -> + (* the call to whd_betaiotazeta will reduce the + apparent iota redex away *) + check_rec_call renv [] + (Term.applist (mkCase (ci,p,c_0,lrest), l)) + | _ -> Exninfo.iraise exn + end (* Enables to traverse Fixpoint definitions in a more intelligent way, ie, the rule : @@ -958,19 +972,33 @@ let check_one_fix renv recpos trees def = then f is guarded with respect to S in (g a1 ... am). Eduardo 7/9/98 *) | Fix ((recindxs,i),(_,typarray,bodies as recdef)) -> - List.iter (check_rec_call renv []) l; - Array.iter (check_rec_call renv []) typarray; let decrArg = recindxs.(i) in - let renv' = push_fix_renv renv recdef in - let stack' = push_stack_closures renv l stack in - Array.iteri - (fun j body -> - if Int.equal i j && (List.length stack' > decrArg) then - let recArg = List.nth stack' decrArg in - let arg_sp = stack_element_specif recArg in - check_nested_fix_body renv' (decrArg+1) arg_sp body - else check_rec_call renv' [] body) - bodies + begin try + List.iter (check_rec_call renv []) l; + Array.iter (check_rec_call renv []) typarray; + let renv' = push_fix_renv renv recdef in + let stack' = push_stack_closures renv l stack in + bodies |> Array.iteri (fun j body -> + if Int.equal i j && (List.length stack' > decrArg) then + let recArg = List.nth stack' decrArg in + let arg_sp = stack_element_specif recArg in + check_nested_fix_body renv' (decrArg+1) arg_sp body + else check_rec_call renv' [] body) + with (FixGuardError _ as exn) -> + let exn = CErrors.push exn in + (* we try hard to reduce the fix away by looking for a + constructor in l[decrArg] (we unfold definitions too) *) + if List.length l <= decrArg then Exninfo.iraise exn; + let recArg = List.nth l decrArg in + let recArg = whd_all renv.env recArg in + let hd, _ = decompose_app recArg in + match kind hd with + | Construct _ -> + let before, after = CList.(firstn decrArg l, skipn (decrArg+1) l) in + check_rec_call renv [] + (Term.applist (mkFix ((recindxs,i),recdef), (before @ recArg :: after))) + | _ -> Exninfo.iraise exn + end | Const (kn,_u as cu) -> if evaluable_constant kn renv.env then @@ -1000,9 +1028,22 @@ let check_one_fix renv recpos trees def = | (Ind _ | Construct _) -> List.iter (check_rec_call renv []) l - | Proj (_p, c) -> - List.iter (check_rec_call renv []) l; - check_rec_call renv [] c + | Proj (p, c) -> + begin try + List.iter (check_rec_call renv []) l; + check_rec_call renv [] c + with (FixGuardError _ as exn) -> + let exn = CErrors.push exn in + (* we try hard to reduce the proj away by looking for a + constructor in c (we unfold definitions too) *) + let c = whd_all renv.env c in + let hd, _ = decompose_app c in + match kind hd with + | Construct _ -> + check_rec_call renv [] + (Term.applist (mkProj(Projection.unfold p,c), l)) + | _ -> Exninfo.iraise exn + end | Var id -> begin diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index edb1d0a02e..673f025c75 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -842,7 +842,7 @@ let check_mind mie lab = let add_mind l mie senv = let () = check_mind mie l in let kn = MutInd.make2 senv.modpath l in - let mib = Term_typing.translate_mind senv.env kn mie in + let mib = Indtypes.check_inductive senv.env kn mie in let mib = match mib.mind_hyps with [] -> Declareops.hcons_mind mib | _ -> mib in diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index f773f800c6..faa4411e92 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -371,7 +371,3 @@ let translate_local_def env _id centry = | Undef _ | Primitive _ -> assert false in c, decl.cook_relevance, typ - -(* Insertion of inductive types. *) - -let translate_mind env kn mie = Indtypes.check_inductive env kn mie diff --git a/kernel/term_typing.mli b/kernel/term_typing.mli index d34c28138e..1fa5eca2e3 100644 --- a/kernel/term_typing.mli +++ b/kernel/term_typing.mli @@ -35,9 +35,6 @@ val translate_constant : 'a trust -> env -> Constant.t -> 'a constant_entry -> constant_body -val translate_mind : - env -> MutInd.t -> mutual_inductive_entry -> mutual_inductive_body - val translate_recipe : hcons:bool -> env -> Constant.t -> Cooking.recipe -> constant_body (** Internal functions, mentioned here for debug purpose only *) diff --git a/lib/cWarnings.ml b/lib/cWarnings.ml index 0cf989e494..f199e2e608 100644 --- a/lib/cWarnings.ml +++ b/lib/cWarnings.ml @@ -8,8 +8,6 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Pp - type status = Disabled | Enabled | AsError @@ -158,6 +156,10 @@ let set_flags s = warning flags string, because the warning being created might have been set already. *) let create ~name ~category ?(default=Enabled) pp = + let pp x = let open Pp in + pp x ++ spc () ++ str "[" ++ str name ++ str "," ++ + str category ++ str "]" + in Hashtbl.replace warnings name { default; category; status = default }; add_warning_in_category ~name ~category; if default <> Disabled then @@ -166,13 +168,8 @@ let create ~name ~category ?(default=Enabled) pp = new warning is now known. *) set_flags !flags; fun ?loc x -> - let w = Hashtbl.find warnings name in - match w.status with - | Disabled -> () - | AsError -> CErrors.user_err ?loc (pp x) - | Enabled -> - let msg = - pp x ++ spc () ++ str "[" ++ str name ++ str "," ++ - str category ++ str "]" - in - Feedback.msg_warning ?loc msg + let w = Hashtbl.find warnings name in + match w.status with + | Disabled -> () + | AsError -> CErrors.user_err ?loc (pp x) + | Enabled -> Feedback.msg_warning ?loc (pp x) @@ -4,4 +4,4 @@ (public_name coq.lib) (wrapped false) (modules_without_implementation xml_datatype) - (libraries dynlink coq.clib coq.config)) + (libraries coq.clib coq.config)) diff --git a/lib/loc.ml b/lib/loc.ml index 66b7a7da70..6bcdcc0341 100644 --- a/lib/loc.ml +++ b/lib/loc.ml @@ -29,6 +29,8 @@ let create fname line_nb bol_pos bp ep = { line_nb_last = line_nb; bol_pos_last = bol_pos; bp = bp; ep = ep; } +let initial source = create source 1 0 0 0 + let make_loc (bp, ep) = { fname = ToplevelInput; line_nb = -1; bol_pos = 0; line_nb_last = -1; bol_pos_last = 0; bp = bp; ep = ep; diff --git a/lib/loc.mli b/lib/loc.mli index 23df1ebd9a..1eb3cc49e8 100644 --- a/lib/loc.mli +++ b/lib/loc.mli @@ -32,6 +32,9 @@ val create : source -> int -> int -> int -> int -> t (** Create a location from a filename, a line number, a position of the beginning of the line, a start and end position *) +val initial : source -> t +(** Create a location corresponding to the beginning of the given source *) + val unloc : t -> int * int (** Return the start and end position of a location *) diff --git a/lib/system.ml b/lib/system.ml index fd6579dd69..c408061852 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -304,7 +304,7 @@ let with_time ~batch ~header f x = raise e (* We use argv.[0] as we don't want to resolve symlinks *) -let get_toplevel_path ?(byte=not Dynlink.is_native) top = +let get_toplevel_path ?(byte=Sys.(backend_type = Bytecode)) top = let open Filename in let dir = if String.equal (basename Sys.argv.(0)) Sys.argv.(0) then "" else dirname Sys.argv.(0) ^ dir_sep in diff --git a/parsing/cLexer.ml b/parsing/cLexer.ml index 49d6cf01d9..503cfcdb4f 100644 --- a/parsing/cLexer.ml +++ b/parsing/cLexer.ml @@ -383,9 +383,6 @@ let rec string loc ~comm_level bp len s = match Stream.peek s with let loc = set_loc_pos loc bp ep in err loc Unterminated_string -(* To associate locations to a file name *) -let current_file = ref Loc.ToplevelInput - (* Utilities for comments in beautify *) let comment_begin = ref None let comm_loc bp = match !comment_begin with @@ -397,21 +394,20 @@ let current_comment = Buffer.create 8192 let between_commands = ref true (* The state of the lexer visible from outside *) -type lexer_state = int option * string * bool * ((int * int) * string) list * Loc.source +type lexer_state = int option * string * bool * ((int * int) * string) list -let init_lexer_state f = (None,"",true,[],f) -let set_lexer_state (o,s,b,c,f) = +let init_lexer_state () = (None,"",true,[]) +let set_lexer_state (o,s,b,c) = comment_begin := o; Buffer.clear current_comment; Buffer.add_string current_comment s; between_commands := b; - comments := c; - current_file := f + comments := c let get_lexer_state () = - (!comment_begin, Buffer.contents current_comment, !between_commands, !comments, !current_file) + (!comment_begin, Buffer.contents current_comment, !between_commands, !comments) let drop_lexer_state () = - set_lexer_state (init_lexer_state Loc.ToplevelInput) + set_lexer_state (init_lexer_state ()) -let get_comment_state (_,_,_,c,_) = c +let get_comment_state (_,_,_,c) = c let real_push_char c = Buffer.add_char current_comment c @@ -754,9 +750,9 @@ let token_text = function | (con, "") -> con | (con, prm) -> con ^ " \"" ^ prm ^ "\"" -let func next_token cs = +let func next_token ?loc cs = let loct = loct_create () in - let cur_loc = ref (Loc.create !current_file 1 0 0 0) in + let cur_loc = ref (Option.default Loc.(initial ToplevelInput) loc) in let ts = Stream.from (fun i -> diff --git a/parsing/cLexer.mli b/parsing/cLexer.mli index af3fd7f318..807f37a1a4 100644 --- a/parsing/cLexer.mli +++ b/parsing/cLexer.mli @@ -51,7 +51,7 @@ end (* Mainly for comments state, etc... *) type lexer_state -val init_lexer_state : Loc.source -> lexer_state +val init_lexer_state : unit -> lexer_state val set_lexer_state : lexer_state -> unit val get_lexer_state : unit -> lexer_state val drop_lexer_state : unit -> unit diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 759e60fbca..9241205755 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -59,7 +59,7 @@ module type S = type coq_parsable - val coq_parsable : ?file:Loc.source -> char Stream.t -> coq_parsable + val coq_parsable : ?loc:Loc.t -> char Stream.t -> coq_parsable val entry_create : string -> 'a entry val entry_parse : 'a entry -> coq_parsable -> 'a @@ -71,10 +71,10 @@ end with type 'a Entry.e = 'a Extend.entry = struct type coq_parsable = parsable * CLexer.lexer_state ref - let coq_parsable ?(file=Loc.ToplevelInput) c = - let state = ref (CLexer.init_lexer_state file) in + let coq_parsable ?loc c = + let state = ref (CLexer.init_lexer_state ()) in CLexer.set_lexer_state !state; - let a = parsable c in + let a = parsable ?loc c in state := CLexer.get_lexer_state (); (a,state) @@ -320,8 +320,9 @@ let map_entry f en = (* Parse a string, does NOT check if the entire string was read (use eoi_entry) *) -let parse_string f x = - let strm = Stream.of_string x in Gram.entry_parse f (Gram.coq_parsable strm) +let parse_string f ?loc x = + let strm = Stream.of_string x in + Gram.entry_parse f (Gram.coq_parsable ?loc strm) type gram_universe = string diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 3203a25b46..0418249e42 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -19,7 +19,7 @@ open Libnames module Parsable : sig type t - val make : ?file:Loc.source -> char Stream.t -> t + val make : ?loc:Loc.t -> char Stream.t -> t (* Get comment parsing information from the Lexer *) val comment_state : t -> ((int * int) * string) list end @@ -121,7 +121,7 @@ end (** Parse a string *) -val parse_string : 'a Entry.t -> string -> 'a +val parse_string : 'a Entry.t -> ?loc:Loc.t -> string -> 'a val eoi_entry : 'a Entry.t -> 'a Entry.t val map_entry : ('a -> 'b) -> 'a Entry.t -> 'b Entry.t diff --git a/plugins/btauto/refl_btauto.ml b/plugins/btauto/refl_btauto.ml index 4d817625f5..1bdedcaf26 100644 --- a/plugins/btauto/refl_btauto.ml +++ b/plugins/btauto/refl_btauto.ml @@ -196,7 +196,7 @@ module Btauto = struct let assign = List.combine penv var in let map_msg (key, v) = let b = if v then str "true" else str "false" in - let sigma, env = Pfedit.get_current_context () in + let sigma, env = Tacmach.project gl, Tacmach.pf_env gl in let term = Printer.pr_constr_env env sigma key in term ++ spc () ++ str ":=" ++ spc () ++ b in diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml index 23cdae7883..048ec56dee 100644 --- a/plugins/cc/ccalgo.ml +++ b/plugins/cc/ccalgo.ml @@ -27,10 +27,6 @@ let init_size=5 let cc_verbose=ref false -let print_constr t = - let sigma, env = Pfedit.get_current_context () in - Printer.pr_econstr_env env sigma t - let debug x = if !cc_verbose then Feedback.msg_debug (x ()) @@ -484,11 +480,11 @@ let rec inst_pattern subst = function (fun spat f -> Appli (f,inst_pattern subst spat)) args t -let pr_idx_term uf i = str "[" ++ int i ++ str ":=" ++ - print_constr (EConstr.of_constr (constr_of_term (term uf i))) ++ str "]" +let pr_idx_term env sigma uf i = str "[" ++ int i ++ str ":=" ++ + Printer.pr_econstr_env env sigma (EConstr.of_constr (constr_of_term (term uf i))) ++ str "]" -let pr_term t = str "[" ++ - print_constr (EConstr.of_constr (constr_of_term t)) ++ str "]" +let pr_term env sigma t = str "[" ++ + Printer.pr_econstr_env env sigma (EConstr.of_constr (constr_of_term t)) ++ str "]" let rec add_term state t= let uf=state.uf in @@ -603,16 +599,16 @@ let add_inst state (inst,int_subst) = begin debug (fun () -> (str "Adding new equality, depth="++ int state.rew_depth) ++ fnl () ++ - (str " [" ++ print_constr (EConstr.of_constr prf) ++ str " : " ++ - pr_term s ++ str " == " ++ pr_term t ++ str "]")); + (str " [" ++ Printer.pr_econstr_env state.env state.sigma (EConstr.of_constr prf) ++ str " : " ++ + pr_term state.env state.sigma s ++ str " == " ++ pr_term state.env state.sigma t ++ str "]")); add_equality state prf s t end else begin debug (fun () -> (str "Adding new disequality, depth="++ int state.rew_depth) ++ fnl () ++ - (str " [" ++ print_constr (EConstr.of_constr prf) ++ str " : " ++ - pr_term s ++ str " <> " ++ pr_term t ++ str "]")); + (str " [" ++ Printer.pr_econstr_env state.env state.sigma (EConstr.of_constr prf) ++ str " : " ++ + pr_term state.env state.sigma s ++ str " <> " ++ pr_term state.env state.sigma t ++ str "]")); add_disequality state (Hyp prf) s t end end @@ -640,8 +636,8 @@ let join_path uf i j= min_path (down_path uf i [],down_path uf j []) let union state i1 i2 eq= - debug (fun () -> str "Linking " ++ pr_idx_term state.uf i1 ++ - str " and " ++ pr_idx_term state.uf i2 ++ str "."); + debug (fun () -> str "Linking " ++ pr_idx_term state.env state.sigma state.uf i1 ++ + str " and " ++ pr_idx_term state.env state.sigma state.uf i2 ++ str "."); let r1= get_representative state.uf i1 and r2= get_representative state.uf i2 in link state.uf i1 i2 eq; @@ -681,8 +677,8 @@ let union state i1 i2 eq= let merge eq state = (* merge and no-merge *) debug - (fun () -> str "Merging " ++ pr_idx_term state.uf eq.lhs ++ - str " and " ++ pr_idx_term state.uf eq.rhs ++ str "."); + (fun () -> str "Merging " ++ pr_idx_term state.env state.sigma state.uf eq.lhs ++ + str " and " ++ pr_idx_term state.env state.sigma state.uf eq.rhs ++ str "."); let uf=state.uf in let i=find uf eq.lhs and j=find uf eq.rhs in @@ -694,7 +690,7 @@ let merge eq state = (* merge and no-merge *) let update t state = (* update 1 and 2 *) debug - (fun () -> str "Updating term " ++ pr_idx_term state.uf t ++ str "."); + (fun () -> str "Updating term " ++ pr_idx_term state.env state.sigma state.uf t ++ str "."); let (i,j) as sign = signature state.uf t in let (u,v) = subterms state.uf t in let rep = get_representative state.uf i in @@ -756,7 +752,7 @@ let process_constructor_mark t i rep pac state = let process_mark t m state = debug - (fun () -> str "Processing mark for term " ++ pr_idx_term state.uf t ++ str "."); + (fun () -> str "Processing mark for term " ++ pr_idx_term state.env state.sigma state.uf t ++ str "."); let i=find state.uf t in let rep=get_representative state.uf i in match m with @@ -777,8 +773,8 @@ let check_disequalities state = else (str "No", check_aux q) in let _ = debug - (fun () -> str "Checking if " ++ pr_idx_term state.uf dis.lhs ++ str " = " ++ - pr_idx_term state.uf dis.rhs ++ str " ... " ++ info) in + (fun () -> str "Checking if " ++ pr_idx_term state.env state.sigma state.uf dis.lhs ++ str " = " ++ + pr_idx_term state.env state.sigma state.uf dis.rhs ++ str " ... " ++ info) in ans | [] -> None in diff --git a/plugins/cc/ccalgo.mli b/plugins/cc/ccalgo.mli index d52e83dc31..5066c3931d 100644 --- a/plugins/cc/ccalgo.mli +++ b/plugins/cc/ccalgo.mli @@ -169,7 +169,7 @@ val find_instances : state -> (quant_eq * int array) list val execute : bool -> state -> explanation option -val pr_idx_term : forest -> int -> Pp.t +val pr_idx_term : Environ.env -> Evd.evar_map -> forest -> int -> Pp.t val empty_forest: unit -> forest @@ -255,5 +255,3 @@ val find_contradiction : UF.t -> (Names.Id.t * (int * int)) list -> (Names.Id.t * (int * int)) *) - - diff --git a/plugins/cc/ccproof.ml b/plugins/cc/ccproof.ml index 1f1fa9c99a..4f46f8327a 100644 --- a/plugins/cc/ccproof.ml +++ b/plugins/cc/ccproof.ml @@ -94,65 +94,65 @@ let pinject p c n a = p_rhs=nth_arg p.p_rhs (n-a); p_rule=Inject(p,c,n,a)} -let rec equal_proof uf i j= - debug (fun () -> str "equal_proof " ++ pr_idx_term uf i ++ brk (1,20) ++ pr_idx_term uf j); +let rec equal_proof env sigma uf i j= + debug (fun () -> str "equal_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20) ++ pr_idx_term env sigma uf j); if i=j then prefl (term uf i) else let (li,lj)=join_path uf i j in - ptrans (path_proof uf i li) (psym (path_proof uf j lj)) + ptrans (path_proof env sigma uf i li) (psym (path_proof env sigma uf j lj)) -and edge_proof uf ((i,j),eq)= - debug (fun () -> str "edge_proof " ++ pr_idx_term uf i ++ brk (1,20) ++ pr_idx_term uf j); - let pi=equal_proof uf i eq.lhs in - let pj=psym (equal_proof uf j eq.rhs) in +and edge_proof env sigma uf ((i,j),eq)= + debug (fun () -> str "edge_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20) ++ pr_idx_term env sigma uf j); + let pi=equal_proof env sigma uf i eq.lhs in + let pj=psym (equal_proof env sigma uf j eq.rhs) in let pij= match eq.rule with Axiom (s,reversed)-> if reversed then psymax (axioms uf) s else pax (axioms uf) s - | Congruence ->congr_proof uf eq.lhs eq.rhs + | Congruence ->congr_proof env sigma uf eq.lhs eq.rhs | Injection (ti,ipac,tj,jpac,k) -> (* pi_k ipac = p_k jpac *) - let p=ind_proof uf ti ipac tj jpac in + let p=ind_proof env sigma uf ti ipac tj jpac in let cinfo= get_constructor_info uf ipac.cnode in pinject p cinfo.ci_constr cinfo.ci_nhyps k in ptrans (ptrans pi pij) pj -and constr_proof uf i ipac= - debug (fun () -> str "constr_proof " ++ pr_idx_term uf i ++ brk (1,20)); +and constr_proof env sigma uf i ipac= + debug (fun () -> str "constr_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20)); let t=find_oldest_pac uf i ipac in - let eq_it=equal_proof uf i t in + let eq_it=equal_proof env sigma uf i t in if ipac.args=[] then eq_it else let fipac=tail_pac ipac in let (fi,arg)=subterms uf t in let targ=term uf arg in - let p=constr_proof uf fi fipac in + let p=constr_proof env sigma uf fi fipac in ptrans eq_it (pcongr p (prefl targ)) -and path_proof uf i l= - debug (fun () -> str "path_proof " ++ pr_idx_term uf i ++ brk (1,20) ++ str "{" ++ +and path_proof env sigma uf i l= + debug (fun () -> str "path_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20) ++ str "{" ++ (prlist_with_sep (fun () -> str ",") (fun ((_,j),_) -> int j) l) ++ str "}"); match l with | [] -> prefl (term uf i) - | x::q->ptrans (path_proof uf (snd (fst x)) q) (edge_proof uf x) + | x::q->ptrans (path_proof env sigma uf (snd (fst x)) q) (edge_proof env sigma uf x) -and congr_proof uf i j= - debug (fun () -> str "congr_proof " ++ pr_idx_term uf i ++ brk (1,20) ++ pr_idx_term uf j); +and congr_proof env sigma uf i j= + debug (fun () -> str "congr_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20) ++ pr_idx_term env sigma uf j); let (i1,i2) = subterms uf i and (j1,j2) = subterms uf j in - pcongr (equal_proof uf i1 j1) (equal_proof uf i2 j2) + pcongr (equal_proof env sigma uf i1 j1) (equal_proof env sigma uf i2 j2) -and ind_proof uf i ipac j jpac= - debug (fun () -> str "ind_proof " ++ pr_idx_term uf i ++ brk (1,20) ++ pr_idx_term uf j); - let p=equal_proof uf i j - and p1=constr_proof uf i ipac - and p2=constr_proof uf j jpac in +and ind_proof env sigma uf i ipac j jpac= + debug (fun () -> str "ind_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20) ++ pr_idx_term env sigma uf j); + let p=equal_proof env sigma uf i j + and p1=constr_proof env sigma uf i ipac + and p2=constr_proof env sigma uf j jpac in ptrans (psym p1) (ptrans p p2) -let build_proof uf= +let build_proof env sigma uf= function - | `Prove (i,j) -> equal_proof uf i j - | `Discr (i,ci,j,cj)-> ind_proof uf i ci j cj + | `Prove (i,j) -> equal_proof env sigma uf i j + | `Discr (i,ci,j,cj)-> ind_proof env sigma uf i ci j cj diff --git a/plugins/cc/ccproof.mli b/plugins/cc/ccproof.mli index bebef241e1..9ea31259c1 100644 --- a/plugins/cc/ccproof.mli +++ b/plugins/cc/ccproof.mli @@ -41,20 +41,20 @@ val pinject : proof -> pconstructor -> int -> int -> proof (** Proof building functions *) -val equal_proof : forest -> int -> int -> proof +val equal_proof : Environ.env -> Evd.evar_map -> forest -> int -> int -> proof -val edge_proof : forest -> (int*int)*equality -> proof +val edge_proof : Environ.env -> Evd.evar_map -> forest -> (int*int)*equality -> proof -val path_proof : forest -> int -> ((int*int)*equality) list -> proof +val path_proof : Environ.env -> Evd.evar_map -> forest -> int -> ((int*int)*equality) list -> proof -val congr_proof : forest -> int -> int -> proof +val congr_proof : Environ.env -> Evd.evar_map -> forest -> int -> int -> proof -val ind_proof : forest -> int -> pa_constructor -> int -> pa_constructor -> proof +val ind_proof : Environ.env -> Evd.evar_map -> forest -> int -> pa_constructor -> int -> pa_constructor -> proof (** Main proof building function *) val build_proof : - forest -> + Environ.env -> Evd.evar_map -> forest -> [ `Discr of int * pa_constructor * int * pa_constructor | `Prove of int * int ] -> proof diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 5778acce0a..50fc2448fc 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -433,7 +433,7 @@ let cc_tactic depth additionnal_terms = debug (fun () -> Pp.str "Goal solved, generating proof ..."); match reason with Discrimination (i,ipac,j,jpac) -> - let p=build_proof uf (`Discr (i,ipac,j,jpac)) in + let p=build_proof (Tacmach.New.pf_env gl) sigma uf (`Discr (i,ipac,j,jpac)) in let cstr=(get_constructor_info uf ipac.cnode).ci_constr in discriminate_tac cstr p | Incomplete -> @@ -462,7 +462,8 @@ let cc_tactic depth additionnal_terms = Pp.str " replacing metavariables by arbitrary terms."); Tacticals.New.tclFAIL 0 (str "Incomplete") | Contradiction dis -> - let p=build_proof uf (`Prove (dis.lhs,dis.rhs)) in + let env = Proofview.Goal.env gl in + let p=build_proof env sigma uf (`Prove (dis.lhs,dis.rhs)) in let ta=term uf dis.lhs and tb=term uf dis.rhs in match dis.rule with Goal -> proof_tac p diff --git a/plugins/derive/derive.ml b/plugins/derive/derive.ml index afdbfa1999..4425e41652 100644 --- a/plugins/derive/derive.ml +++ b/plugins/derive/derive.ml @@ -101,8 +101,7 @@ let start_deriving f suchthat lemma = in let terminator = Proof_global.make_terminator terminator in - let () = Proof_global.start_dependent_proof lemma kind goals terminator in - let _ = Proof_global.with_current_proof begin fun _ p -> + let pstate = Proof_global.start_dependent_proof ~ontop:None lemma kind goals terminator in + fst @@ Proof_global.with_current_proof begin fun _ p -> Proof.run_tactic env Proofview.(tclFOCUS 1 2 shelve) p - end in - () + end pstate diff --git a/plugins/derive/derive.mli b/plugins/derive/derive.mli index 06ff9c48cf..6bb923118e 100644 --- a/plugins/derive/derive.mli +++ b/plugins/derive/derive.mli @@ -12,4 +12,4 @@ (which can contain references to [f]) in the context extended by [f:=?x]. When the proof ends, [f] is defined as the value of [?x] and [lemma] as the proof. *) -val start_deriving : Names.Id.t -> Constrexpr.constr_expr -> Names.Id.t -> unit +val start_deriving : Names.Id.t -> Constrexpr.constr_expr -> Names.Id.t -> Proof_global.t diff --git a/plugins/derive/g_derive.mlg b/plugins/derive/g_derive.mlg index 0cdf8fb5d8..214a9d8bb5 100644 --- a/plugins/derive/g_derive.mlg +++ b/plugins/derive/g_derive.mlg @@ -23,6 +23,6 @@ let classify_derive_command _ = Vernacextend.(VtStartProof (Doesn'tGuaranteeOpac } VERNAC COMMAND EXTEND Derive CLASSIFIED BY { classify_derive_command } -| [ "Derive" ident(f) "SuchThat" constr(suchthat) "As" ident(lemma) ] -> - { Derive.start_deriving f suchthat lemma } +| ![ proof ] [ "Derive" ident(f) "SuchThat" constr(suchthat) "As" ident(lemma) ] -> + { fun ~pstate -> Some Derive.(start_deriving f suchthat lemma) } END diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index 0fa9be21c9..8f17f7b2dd 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -750,16 +750,19 @@ let extract_and_compile l = Feedback.msg_notice (str "Extracted code successfully compiled") (* Show the extraction of the current ongoing proof *) - -let show_extraction () = +let show_extraction ~pstate = + let pstate = match pstate with + | None -> CErrors.user_err Pp.(str "No ongoing proof") + | Some pstate -> pstate + in init ~inner:true false false; - let prf = Proof_global.give_me_the_proof () in - let sigma, env = Pfedit.get_current_context () in + let prf = Proof_global.give_me_the_proof pstate in + let sigma, env = Pfedit.get_current_context pstate in let trms = Proof.partial_proof prf in let extr_term t = let ast, ty = extract_constr env sigma t in let mp = Lib.current_mp () in - let l = Label.of_id (Proof_global.get_current_proof_name ()) in + let l = Label.of_id (Proof_global.get_current_proof_name pstate) in let fake_ref = ConstRef (Constant.make2 mp l) in let decl = Dterm (fake_ref, ast, ty) in print_one_decl [] mp decl diff --git a/plugins/extraction/extract_env.mli b/plugins/extraction/extract_env.mli index 54fde2ca46..7ba7e05019 100644 --- a/plugins/extraction/extract_env.mli +++ b/plugins/extraction/extract_env.mli @@ -40,4 +40,4 @@ val structure_for_compute : (* Show the extraction of the current ongoing proof *) -val show_extraction : unit -> unit +val show_extraction : pstate:Proof_global.t option -> unit diff --git a/plugins/extraction/g_extraction.mlg b/plugins/extraction/g_extraction.mlg index 1445dffefa..d7bb27f121 100644 --- a/plugins/extraction/g_extraction.mlg +++ b/plugins/extraction/g_extraction.mlg @@ -178,6 +178,6 @@ END (* Show the extraction of the current proof *) VERNAC COMMAND EXTEND ShowExtraction CLASSIFIED AS QUERY -| [ "Show" "Extraction" ] - -> { show_extraction () } +| ![ proof ] [ "Show" "Extraction" ] + -> { fun ~pstate -> let () = show_extraction ~pstate in pstate } END diff --git a/plugins/firstorder/sequent.ml b/plugins/firstorder/sequent.ml index 5958fe8203..01b18e2f30 100644 --- a/plugins/firstorder/sequent.ml +++ b/plugins/firstorder/sequent.ml @@ -235,7 +235,7 @@ let print_cmap map= str "| " ++ prlist Printer.pr_global l ++ str " : " ++ - Ppconstr.pr_constr_expr xc ++ + Ppconstr.pr_constr_expr env sigma xc ++ cut () ++ s in (v 0 diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 34283c49c3..287a374ab1 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -45,10 +45,6 @@ let observe_tac s tac g = observe_tac_stream (str s) tac g *) -let pr_leconstr_fp = - let sigma, env = Pfedit.get_current_context () in - Printer.pr_leconstr_env env sigma - let debug_queue = Stack.create () let rec print_debug_queue e = @@ -164,7 +160,7 @@ let rec incompatible_constructor_terms sigma t1 t2 = List.exists2 (incompatible_constructor_terms sigma) arg1 arg2 ) -let is_incompatible_eq sigma t = +let is_incompatible_eq env sigma t = let res = try match EConstr.kind sigma t with @@ -176,7 +172,7 @@ let is_incompatible_eq sigma t = | _ -> false with e when CErrors.noncritical e -> false in - if res then observe (str "is_incompatible_eq " ++ pr_leconstr_fp t); + if res then observe (str "is_incompatible_eq " ++ pr_leconstr_env env sigma t); res let change_hyp_with_using msg hyp_id t tac : tactic = @@ -480,7 +476,7 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = (* ); *) raise TOREMOVE; (* False -> .. useless *) end - else if is_incompatible_eq sigma t_x then raise TOREMOVE (* t_x := C1 ... = C2 ... *) + else if is_incompatible_eq env sigma t_x then raise TOREMOVE (* t_x := C1 ... = C2 ... *) else if eq_constr sigma t_x coq_True (* Trivial => we remove this precons *) then (* observe (str "In "++Ppconstr.pr_id hyp_id++ *) @@ -726,7 +722,7 @@ let build_proof (treat_new_case ptes_infos nb_instantiate_partial - (build_proof do_finalize) + (build_proof do_finalize) t dyn_infos) g' @@ -737,7 +733,7 @@ let build_proof ] g in - build_proof do_finalize_t {dyn_infos with info = t} g + build_proof do_finalize_t {dyn_infos with info = t} g | Lambda(n,t,b) -> begin match EConstr.kind sigma (pf_concl g) with @@ -753,7 +749,7 @@ let build_proof in let new_infos = {dyn_infos with info = new_term} in let do_prove new_hyps = - build_proof do_finalize + build_proof do_finalize {new_infos with rec_hyps = new_hyps; nb_rec_hyps = List.length new_hyps @@ -766,7 +762,7 @@ let build_proof do_finalize dyn_infos g end | Cast(t,_,_) -> - build_proof do_finalize {dyn_infos with info = t} g + build_proof do_finalize {dyn_infos with info = t} g | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ | Int _ -> do_finalize dyn_infos g | App(_,_) -> @@ -782,7 +778,7 @@ let build_proof info = (f,args) } in - build_proof_args do_finalize new_infos g + build_proof_args env sigma do_finalize new_infos g | Const (c,_) when not (List.mem_f Constant.equal c fnames) -> let new_infos = { dyn_infos with @@ -790,13 +786,13 @@ let build_proof } in (* Pp.msgnl (str "proving in " ++ pr_lconstr_env (pf_env g) dyn_infos.info); *) - build_proof_args do_finalize new_infos g + build_proof_args env sigma do_finalize new_infos g | Const _ -> do_finalize dyn_infos g | Lambda _ -> let new_term = Reductionops.nf_beta env sigma dyn_infos.info in - build_proof do_finalize {dyn_infos with info = new_term} + build_proof do_finalize {dyn_infos with info = new_term} g | LetIn _ -> let new_infos = @@ -809,11 +805,11 @@ let build_proof h_reduce_with_zeta (Locusops.onHyp hyp_id)) dyn_infos.rec_hyps; h_reduce_with_zeta Locusops.onConcl; - build_proof do_finalize new_infos + build_proof do_finalize new_infos ] g | Cast(b,_,_) -> - build_proof do_finalize {dyn_infos with info = b } g + build_proof do_finalize {dyn_infos with info = b } g | Case _ | Fix _ | CoFix _ -> let new_finalize dyn_infos = let new_infos = @@ -821,9 +817,9 @@ let build_proof info = dyn_infos.info,args } in - build_proof_args do_finalize new_infos + build_proof_args env sigma do_finalize new_infos in - build_proof new_finalize {dyn_infos with info = f } g + build_proof new_finalize {dyn_infos with info = f } g end | Fix _ | CoFix _ -> user_err Pp.(str ( "Anonymous local (co)fixpoints are not handled yet")) @@ -843,13 +839,13 @@ let build_proof (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) dyn_infos.rec_hyps; h_reduce_with_zeta Locusops.onConcl; - build_proof do_finalize new_infos + build_proof do_finalize new_infos ] g | Rel _ -> anomaly (Pp.str "Free var in goal conclusion!") and build_proof do_finalize dyn_infos g = (* observe (str "proving with "++Printer.pr_lconstr dyn_infos.info++ str " on goal " ++ pr_gls g); *) - observe_tac_stream (str "build_proof with " ++ pr_leconstr_fp dyn_infos.info ) (build_proof_aux do_finalize dyn_infos) g - and build_proof_args do_finalize dyn_infos (* f_args' args *) :tactic = + observe_tac_stream (str "build_proof with " ++ pr_leconstr_env (pf_env g) (project g) dyn_infos.info ) (build_proof_aux do_finalize dyn_infos) g + and build_proof_args env sigma do_finalize dyn_infos (* f_args' args *) :tactic = fun g -> let (f_args',args) = dyn_infos.info in let tac : tactic = @@ -865,12 +861,12 @@ let build_proof let do_finalize dyn_infos = let new_arg = dyn_infos.info in (* tclTRYD *) - (build_proof_args + (build_proof_args env sigma do_finalize {dyn_infos with info = (mkApp(f_args',[|new_arg|])), args} ) in - build_proof do_finalize + build_proof do_finalize {dyn_infos with info = arg } g in @@ -882,17 +878,8 @@ let build_proof finish_proof dyn_infos) in (* observe_tac "build_proof" *) - (build_proof (clean_goal_with_heq ptes_infos do_finish_proof) dyn_infos) - - - - - - - - - - + fun g -> + build_proof (clean_goal_with_heq ptes_infos do_finish_proof) dyn_infos g (* Proof of principles from structural functions *) @@ -1003,19 +990,18 @@ let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num ] in (* Pp.msgnl (str "lemma type (2) " ++ Printer.pr_lconstr_env (Global.env ()) evd lemma_type); *) - Lemmas.start_proof + let pstate = Lemmas.start_proof ~ontop:None (*i The next call to mk_equation_id is valid since we are constructing the lemma Ensures by: obvious i*) (mk_equation_id f_id) (Decl_kinds.Global, false, (Decl_kinds.Proof Decl_kinds.Theorem)) evd - lemma_type; - ignore (Pfedit.by (Proofview.V82.tactic prove_replacement)); - Lemmas.save_proof (Vernacexpr.(Proved(Proof_global.Transparent,None))); - evd - - + lemma_type + in + let pstate,_ = Pfedit.by (Proofview.V82.tactic prove_replacement) pstate in + let pstate = Lemmas.save_proof_proved ?proof:None ~pstate ~opaque:Proof_global.Transparent ~idopt:None in + pstate, evd let do_replace (evd:Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num all_funs g = @@ -1029,7 +1015,7 @@ let do_replace (evd:Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num a Ensures by: obvious i*) let equation_lemma_id = (mk_equation_id f_id) in - evd := generate_equation_lemma !evd all_funs f fun_num (List.length params) (List.length rev_args_id) rec_arg_num; + evd := snd @@ generate_equation_lemma !evd all_funs f fun_num (List.length params) (List.length rev_args_id) rec_arg_num; let _ = match e with | Option.IsNone -> diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index 1217ba0eba..e9a2c285d0 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -308,31 +308,30 @@ let build_functional_principle (evd:Evd.evar_map ref) interactive_proof old_prin let sigma, _ = Typing.type_of ~refresh:true (Global.env ()) !evd (EConstr.of_constr new_principle_type) in evd := sigma; let hook = Lemmas.mk_hook (hook new_principle_type) in - begin - Lemmas.start_proof + let pstate = + Lemmas.start_proof ~ontop:None new_princ_name (Decl_kinds.Global,false,(Decl_kinds.Proof Decl_kinds.Theorem)) !evd (EConstr.of_constr new_principle_type) - ; - (* let _tim1 = System.get_time () in *) - let map (c, u) = EConstr.mkConstU (c, EConstr.EInstance.make u) in - ignore (Pfedit.by (Proofview.V82.tactic (proof_tac (Array.map map funs) mutr_nparams))); - (* let _tim2 = System.get_time () in *) - (* begin *) - (* let dur1 = System.time_difference tim1 tim2 in *) - (* Pp.msgnl (str ("Time to compute proof: ") ++ str (string_of_float dur1)); *) - (* end; *) + in + (* let _tim1 = System.get_time () in *) + let map (c, u) = EConstr.mkConstU (c, EConstr.EInstance.make u) in + let pstate,_ = Pfedit.by (Proofview.V82.tactic (proof_tac (Array.map map funs) mutr_nparams)) pstate in + (* let _tim2 = System.get_time () in *) + (* begin *) + (* let dur1 = System.time_difference tim1 tim2 in *) + (* Pp.msgnl (str ("Time to compute proof: ") ++ str (string_of_float dur1)); *) + (* end; *) - let open Proof_global in - let { id; entries; persistence } = fst @@ close_proof ~opaque:Transparent ~keep_body_ucst_separate:false (fun x -> x) in - match entries with - | [entry] -> - discard_current (); - (id,(entry,persistence)), hook - | _ -> - CErrors.anomaly Pp.(str "[build_functional_principle] close_proof returned more than one proof term") - end + let open Proof_global in + let { id; entries; persistence } = fst @@ close_proof ~opaque:Transparent ~keep_body_ucst_separate:false (fun x -> x) pstate in + match entries with + | [entry] -> + let pstate = discard_current pstate in + (id,(entry,persistence)), hook, pstate + | _ -> + CErrors.anomaly Pp.(str "[build_functional_principle] close_proof returned more than one proof term") let generate_functional_principle (evd: Evd.evar_map ref) interactive_proof @@ -382,7 +381,7 @@ let generate_functional_principle (evd: Evd.evar_map ref) register_with_sort InProp; register_with_sort InSet in - let ((id,(entry,g_kind)),hook) = + let ((id,(entry,g_kind)),hook,pstate) = build_functional_principle evd interactive_proof old_princ_type new_sorts funs i proof_tac hook in @@ -390,25 +389,9 @@ let generate_functional_principle (evd: Evd.evar_map ref) Don't forget to close the goal if an error is raised !!!! *) let uctx = Evd.evar_universe_context sigma in - save false new_princ_name entry ~hook uctx g_kind + save new_princ_name entry ~hook uctx g_kind with e when CErrors.noncritical e -> - begin - begin - try - let id = Proof_global.get_current_proof_name () in - let s = Id.to_string id in - let n = String.length "___________princ_________" in - if String.length s >= n - then if String.equal (String.sub s 0 n) "___________princ_________" - then Proof_global.discard_current () - else () - else () - with e when CErrors.noncritical e -> () - end; - raise (Defining_principle e) - end -(* defined () *) - + raise (Defining_principle e) exception Not_Rec @@ -537,7 +520,7 @@ let make_scheme evd (fas : (pconstant*Sorts.family) list) : Safe_typing.private_ s::l_schemes -> s,l_schemes | _ -> anomaly (Pp.str "") in - let ((_,(const,_)),_) = + let ((_,(const,_)),_,pstate) = try build_functional_principle evd false first_type @@ -547,21 +530,7 @@ let make_scheme evd (fas : (pconstant*Sorts.family) list) : Safe_typing.private_ (prove_princ_for_struct evd false 0 (Array.of_list (List.map fst funs))) (fun _ _ _ _ _ -> ()) with e when CErrors.noncritical e -> - begin - begin - try - let id = Proof_global.get_current_proof_name () in - let s = Id.to_string id in - let n = String.length "___________princ_________" in - if String.length s >= n - then if String.equal (String.sub s 0 n) "___________princ_________" - then Proof_global.discard_current () - else () - else () - with e when CErrors.noncritical e -> () - end; - raise (Defining_principle e) - end + raise (Defining_principle e) in incr i; @@ -611,7 +580,7 @@ let make_scheme evd (fas : (pconstant*Sorts.family) list) : Safe_typing.private_ (* If we reach this point, the two principle are not mutually recursive We fall back to the previous method *) - let ((_,(const,_)),_) = + let ((_,(const,_)),_,pstate) = build_functional_principle evd false diff --git a/plugins/funind/g_indfun.mlg b/plugins/funind/g_indfun.mlg index c4f8843e51..4e8cf80ed2 100644 --- a/plugins/funind/g_indfun.mlg +++ b/plugins/funind/g_indfun.mlg @@ -29,10 +29,10 @@ DECLARE PLUGIN "recdef_plugin" { -let pr_fun_ind_using prc prlc _ opt_c = +let pr_fun_ind_using env sigma prc prlc _ opt_c = match opt_c with | None -> mt () - | Some b -> spc () ++ hov 2 (str "using" ++ spc () ++ Miscprint.pr_with_bindings prc prlc b) + | Some b -> spc () ++ hov 2 (str "using" ++ spc () ++ Miscprint.pr_with_bindings (prc env sigma) (prlc env sigma) b) (* Duplication of printing functions because "'a with_bindings" is (internally) not uniform in 'a: indeed constr_with_bindings at the @@ -47,15 +47,15 @@ let pr_fun_ind_using_typed prc prlc _ opt_c = let env = Global.env () in let evd = Evd.from_env env in let (_, b) = b env evd in - spc () ++ hov 2 (str "using" ++ spc () ++ Miscprint.pr_with_bindings prc prlc b) + spc () ++ hov 2 (str "using" ++ spc () ++ Miscprint.pr_with_bindings (prc env evd) (prlc env evd) b) } ARGUMENT EXTEND fun_ind_using TYPED AS constr_with_bindings option PRINTED BY { pr_fun_ind_using_typed } - RAW_PRINTED BY { pr_fun_ind_using } - GLOB_PRINTED BY { pr_fun_ind_using } + RAW_PRINTED BY { pr_fun_ind_using env sigma } + GLOB_PRINTED BY { pr_fun_ind_using env sigma } | [ "using" constr_with_bindings(c) ] -> { Some c } | [ ] -> { None } END @@ -119,26 +119,26 @@ END { -let pr_constr_comma_sequence prc _ _ = prlist_with_sep pr_comma prc +let pr_constr_comma_sequence env sigma prc _ _ = prlist_with_sep pr_comma (prc env sigma) } ARGUMENT EXTEND constr_comma_sequence' TYPED AS constr list - PRINTED BY { pr_constr_comma_sequence } + PRINTED BY { pr_constr_comma_sequence env sigma } | [ constr(c) "," constr_comma_sequence'(l) ] -> { c::l } | [ constr(c) ] -> { [c] } END { -let pr_auto_using prc _prlc _prt = Pptactic.pr_auto_using prc +let pr_auto_using env sigma prc _prlc _prt = Pptactic.pr_auto_using (prc env sigma) } ARGUMENT EXTEND auto_using' TYPED AS constr list - PRINTED BY { pr_auto_using } + PRINTED BY { pr_auto_using env sigma } | [ "using" constr_comma_sequence'(l) ] -> { l } | [ ] -> { [] } END @@ -170,14 +170,14 @@ END { let () = - let raw_printer _ _ _ (loc,body) = Ppvernac.pr_rec_definition body in + let raw_printer env sigma _ _ _ (loc,body) = Ppvernac.pr_rec_definition body in Pptactic.declare_extra_vernac_genarg_pprule wit_function_rec_definition_loc raw_printer } (* TASSI: n'importe quoi ! *) VERNAC COMMAND EXTEND Function -| ["Function" ne_function_rec_definition_loc_list_sep(recsl,"with")] +| ![ proof ] ["Function" ne_function_rec_definition_loc_list_sep(recsl,"with")] => { let hard = List.exists (function | _,((_,(_,(CMeasureRec _|CWfRec _)),_,_,_),_) -> true | _,((_,(_,CStructRec),_,_,_),_) -> false) recsl in @@ -223,37 +223,34 @@ let warning_error names e = } VERNAC COMMAND EXTEND NewFunctionalScheme -| ["Functional" "Scheme" ne_fun_scheme_arg_list_sep(fas,"with") ] +| ![ proof ] ["Functional" "Scheme" ne_fun_scheme_arg_list_sep(fas,"with") ] => { Vernacextend.(VtSideff(List.map pi1 fas), VtLater) } -> - { + { fun ~pstate -> begin - try - Functional_principles_types.build_scheme fas - with Functional_principles_types.No_graph_found -> - begin - match fas with - | (_,fun_name,_)::_ -> - begin - begin - make_graph (Smartlocate.global_with_alias fun_name) - end - ; - try Functional_principles_types.build_scheme fas - with Functional_principles_types.No_graph_found -> - CErrors.user_err Pp.(str "Cannot generate induction principle(s)") - | e when CErrors.noncritical e -> - let names = List.map (fun (_,na,_) -> na) fas in - warning_error names e - - end + try + Functional_principles_types.build_scheme fas; pstate + with + | Functional_principles_types.No_graph_found -> + begin + match fas with + | (_,fun_name,_)::_ -> + begin + let pstate = make_graph ~pstate (Smartlocate.global_with_alias fun_name) in + try Functional_principles_types.build_scheme fas; pstate + with + | Functional_principles_types.No_graph_found -> + CErrors.user_err Pp.(str "Cannot generate induction principle(s)") + | e when CErrors.noncritical e -> + let names = List.map (fun (_,na,_) -> na) fas in + warning_error names e; pstate + end | _ -> assert false (* we can only have non empty list *) - end - | e when CErrors.noncritical e -> - let names = List.map (fun (_,na,_) -> na) fas in - warning_error names e + end + | e when CErrors.noncritical e -> + let names = List.map (fun (_,na,_) -> na) fas in + warning_error names e; pstate end - } END (***** debug only ***) @@ -266,5 +263,6 @@ END (***** debug only ***) VERNAC COMMAND EXTEND GenerateGraph CLASSIFIED AS QUERY -| ["Generate" "graph" "for" reference(c)] -> { make_graph (Smartlocate.global_with_alias c) } +| ![ proof ] ["Generate" "graph" "for" reference(c)] -> + { make_graph (Smartlocate.global_with_alias c) } END diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 8611dcaf83..275b58f0aa 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -353,7 +353,7 @@ let raw_push_named (na,raw_value,raw_typ) env = EConstr.push_named (NamedDecl.LocalDef (na, value, typ)) env) -let add_pat_variables pat typ env : Environ.env = +let add_pat_variables sigma pat typ env : Environ.env = let rec add_pat_variables env pat typ : Environ.env = observe (str "new rel env := " ++ Printer.pr_rel_context_of env (Evd.from_env env)); @@ -369,13 +369,12 @@ let add_pat_variables pat typ env : Environ.env = 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 + let new_env = add_pat_variables env pat typ in let res = fst ( Context.Rel.fold_outside (fun decl (env,ctxt) -> let open Context.Rel.Declaration in - let sigma, _ = Pfedit.get_current_context () in match decl with | LocalAssum ({binder_name=Anonymous},_) | LocalDef ({binder_name=Anonymous},_,_) -> assert false | LocalAssum ({binder_name=Name id} as na, t) -> @@ -476,7 +475,7 @@ let rec pattern_to_term_and_type env typ = DAst.with_val (function *) -let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = +let rec build_entry_lc env sigma funnames avoid rt : glob_constr build_entry_return = observe (str " Entering : " ++ Printer.pr_glob_constr_env env rt); let open CAst in match DAst.get rt with @@ -488,7 +487,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = let args_res : (glob_constr list) build_entry_return = List.fold_right (* create the arguments lists of constructors and combine them *) (fun arg ctxt_argsl -> - let arg_res = build_entry_lc env funnames ctxt_argsl.to_avoid arg in + let arg_res = build_entry_lc env sigma funnames ctxt_argsl.to_avoid arg in combine_results combine_args arg_res ctxt_argsl ) args @@ -507,7 +506,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = | _ -> GApp(t,l) in - build_entry_lc env funnames avoid (aux f args) + build_entry_lc env sigma funnames avoid (aux f args) | GVar id when Id.Set.mem id funnames -> (* if we have [f t1 ... tn] with [f]$\in$[fnames] then we create a fresh variable [res], @@ -571,7 +570,8 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = in build_entry_lc env - funnames + sigma + funnames avoid (mkGLetIn(new_n,v,t,mkGApp(new_b,args))) | GCases _ | GIf _ | GLetTuple _ -> @@ -579,7 +579,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = we first compute the result from the case and then combine each of them with each of args one *) - let f_res = build_entry_lc env funnames args_res.to_avoid f in + let f_res = build_entry_lc env sigma funnames args_res.to_avoid f in combine_results combine_app f_res args_res | GCast(b,_) -> (* for an applied cast we just trash the cast part @@ -587,7 +587,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = WARNING: We need to restart since [b] itself should be an application term *) - build_entry_lc env funnames avoid (mkGApp(b,args)) + build_entry_lc env sigma funnames avoid (mkGApp(b,args)) | GRec _ -> user_err Pp.(str "Not handled GRec") | GProd _ -> user_err Pp.(str "Cannot apply a type") | GInt _ -> user_err Pp.(str "Cannot apply an integer") @@ -599,14 +599,14 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = then the one corresponding to the type and combine the two result *) - let t_res = build_entry_lc env funnames avoid t in + let t_res = build_entry_lc env sigma funnames avoid t in let new_n = match n with | Name _ -> n | Anonymous -> Name (Indfun_common.fresh_id [] "_x") in let new_env = raw_push_named (new_n,None,t) env in - let b_res = build_entry_lc new_env funnames avoid b in + let b_res = build_entry_lc new_env sigma funnames avoid b in combine_results (combine_lam new_n) t_res b_res | GProd(n,_,t,b) -> (* we first compute the list of constructor @@ -614,9 +614,9 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = then the one corresponding to the type and combine the two result *) - let t_res = build_entry_lc env funnames avoid t in + let t_res = build_entry_lc env sigma funnames avoid t in let new_env = raw_push_named (n,None,t) env in - let b_res = build_entry_lc new_env funnames avoid b in + let b_res = build_entry_lc new_env sigma funnames avoid b in if List.length t_res.result = 1 && List.length b_res.result = 1 then combine_results (combine_prod2 n) t_res b_res else combine_results (combine_prod n) t_res b_res @@ -627,7 +627,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = and combine the two result *) let v = match typ with None -> v | Some t -> DAst.make ?loc:rt.loc @@ GCast (v,CastConv t) in - let v_res = build_entry_lc env funnames avoid v in + let v_res = build_entry_lc env sigma funnames avoid v in 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 v_r = Sorts.Relevant in (* TODO relevance *) @@ -636,14 +636,14 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = Anonymous -> env | Name id -> EConstr.push_named (NamedDecl.LocalDef (make_annot id v_r,v_as_constr,v_type)) env in - let b_res = build_entry_lc new_env funnames avoid b in + let b_res = build_entry_lc new_env sigma funnames avoid b in combine_results (combine_letin n) v_res b_res | GCases(_,_,el,brl) -> (* we create the discrimination function and treat the case itself *) let make_discr = make_discr_match brl in - build_entry_lc_from_case env funnames make_discr el brl avoid + build_entry_lc_from_case env sigma funnames make_discr el brl avoid | GIf(b,(na,e_option),lhs,rhs) -> let b_as_constr,ctx = Pretyping.understand env (Evd.from_env env) b in let b_typ = Typing.unsafe_type_of env (Evd.from_env env) b_as_constr in @@ -666,7 +666,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = mkGCases(None,[(b,(Anonymous,None))],brl) in (* Pp.msgnl (str "new case := " ++ Printer.pr_glob_constr match_expr); *) - build_entry_lc env funnames avoid match_expr + build_entry_lc env sigma funnames avoid match_expr | GLetTuple(nal,_,b,e) -> begin let nal_as_glob_constr = @@ -690,13 +690,13 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = assert (Int.equal (Array.length case_pats) 1); let br = CAst.make ([],[case_pats.(0)],e) in let match_expr = mkGCases(None,[b,(Anonymous,None)],[br]) in - build_entry_lc env funnames avoid match_expr + build_entry_lc env sigma funnames avoid match_expr end | GRec _ -> user_err Pp.(str "Not handled GRec") | GCast(b,_) -> - build_entry_lc env funnames avoid b -and build_entry_lc_from_case env funname make_discr + build_entry_lc env sigma funnames avoid b +and build_entry_lc_from_case env sigma funname make_discr (el:tomatch_tuples) (brl:Glob_term.cases_clauses) avoid : glob_constr build_entry_return = @@ -714,7 +714,7 @@ and build_entry_lc_from_case env funname make_discr let case_resl = List.fold_right (fun (case_arg,_) ctxt_argsl -> - let arg_res = build_entry_lc env funname ctxt_argsl.to_avoid case_arg in + let arg_res = build_entry_lc env sigma funname ctxt_argsl.to_avoid case_arg in combine_results combine_args arg_res ctxt_argsl ) el @@ -731,7 +731,7 @@ and build_entry_lc_from_case env funname make_discr List.map (fun ca -> let res = build_entry_lc_from_case_term - env types + env sigma types funname (make_discr) [] brl case_resl.to_avoid @@ -748,7 +748,7 @@ and build_entry_lc_from_case env funname make_discr [] results } -and build_entry_lc_from_case_term env types funname make_discr patterns_to_prevent brl avoid +and build_entry_lc_from_case_term env sigma types funname make_discr patterns_to_prevent brl avoid matched_expr = match brl with | [] -> (* computed_branches *) {result = [];to_avoid = avoid} @@ -759,14 +759,14 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve (* building a list of precondition stating that we are not in this branch (will be used in the following recursive calls) *) - let new_env = List.fold_right2 add_pat_variables patl types env in + let new_env = List.fold_right2 (add_pat_variables sigma) patl types env in let not_those_patterns : (Id.t list -> glob_constr -> glob_constr) list = List.map2 (fun pat typ -> fun avoid pat'_as_term -> let renamed_pat,_,_ = alpha_pat avoid pat in let pat_ids = get_pattern_id renamed_pat in - let env_with_pat_ids = add_pat_variables pat typ new_env in + let env_with_pat_ids = add_pat_variables sigma pat typ new_env in List.fold_right (fun id acc -> let typ_of_id = @@ -798,6 +798,7 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve let brl'_res = build_entry_lc_from_case_term env + sigma types funname make_discr @@ -862,7 +863,7 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve ) in (* We compute the result of the value returned by the branch*) - let return_res = build_entry_lc new_env funname new_avoid return in + let return_res = build_entry_lc new_env sigma funname new_avoid return in (* and combine it with the preconds computed for this branch *) let this_branch_res = List.map @@ -895,8 +896,7 @@ let same_raw_term rt1 rt2 = | GRef(r1,_), GRef (r2,_) -> GlobRef.equal r1 r2 | GHole _, GHole _ -> true | _ -> false -let decompose_raw_eq lhs rhs = - let _, env = Pfedit.get_current_context () in +let decompose_raw_eq env lhs rhs = let rec decompose_raw_eq lhs rhs acc = observe (str "decomposing eq for " ++ pr_glob_constr_env env lhs ++ str " " ++ pr_glob_constr_env env rhs); let (rhd,lrhs) = glob_decompose_app rhs in @@ -1086,7 +1086,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = -> begin try - let l = decompose_raw_eq rt1 rt2 in + let l = decompose_raw_eq env rt1 rt2 in if List.length l > 1 then let new_rt = @@ -1346,7 +1346,7 @@ let do_build_inductive resolve_and_replace_implicits ~expected_type:(Pretyping.OfType t) env evd rt ) rta in - let resa = Array.map (build_entry_lc env funnames_as_set []) rta in + let resa = Array.map (build_entry_lc env evd funnames_as_set []) rta in let env_with_graphs = let rel_arity i funargs = (* Rebuilding arities (with parameters) *) let rel_first_args :(Name.t * Glob_term.glob_constr * Glob_term.glob_constr option ) list = diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index b69ca7080c..a5c19f3217 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -410,11 +410,11 @@ let generate_principle (evd:Evd.evar_map ref) pconstants on_error with e when CErrors.noncritical e -> on_error names e -let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) = +let register_struct ~pstate is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) = match fixpoint_exprl with | [(({CAst.v=fname},pl),_,bl,ret_type,body),_] when not is_rec -> let body = match body with | Some body -> body | None -> user_err ~hdr:"Function" (str "Body of Function must be given") in - ComDefinition.do_definition + ComDefinition.do_definition ~ontop:pstate ~program_mode:false fname (Decl_kinds.Global,false,Decl_kinds.Definition) pl @@ -432,9 +432,9 @@ let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexp (Evd.from_env (Global.env ()),[]) fixpoint_exprl in - evd,List.rev rev_pconstants + pstate, evd,List.rev rev_pconstants | _ -> - ComFixpoint.do_fixpoint Global false fixpoint_exprl; + let pstate = ComFixpoint.do_fixpoint ~ontop:pstate Global false fixpoint_exprl in let evd,rev_pconstants = List.fold_left (fun (evd,l) ((({CAst.v=fname},_),_,_,_,_),_) -> @@ -448,8 +448,8 @@ let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexp (Evd.from_env (Global.env ()),[]) fixpoint_exprl in - evd,List.rev rev_pconstants - + pstate,evd,List.rev rev_pconstants + let generate_correction_proof_wf f_ref tcc_lemma_ref is_mes functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation @@ -638,10 +638,10 @@ let recompute_binder_list (fixpoint_exprl : (Vernacexpr.fixpoint_expr * Vernacex fixpoint_exprl_with_new_bl -let do_generate_principle pconstants on_error register_built interactive_proof - (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) :unit = +let do_generate_principle ~pstate pconstants on_error register_built interactive_proof + (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) : Proof_global.t option = List.iter (fun (_,l) -> if not (List.is_empty l) then error "Function does not support notations for now") fixpoint_exprl; - let _is_struct = + let pstate, _is_struct = match fixpoint_exprl with | [((_,(wf_x,Constrexpr.CWfRec wf_rel),_,_,_),_) as fixpoint_expr] -> let (((({CAst.v=name},pl),_,args,types,body)),_) as fixpoint_expr = @@ -665,8 +665,8 @@ let do_generate_principle pconstants on_error register_built interactive_proof true in if register_built - then register_wf name rec_impls wf_rel (map_option (fun x -> x.CAst.v) wf_x) using_lemmas args types body pre_hook; - false + then register_wf name rec_impls wf_rel (map_option (fun x -> x.CAst.v) wf_x) using_lemmas args types body pre_hook, false + else pstate, false |[((_,(wf_x,Constrexpr.CMeasureRec(wf_mes,wf_rel_opt)),_,_,_),_) as fixpoint_expr] -> let (((({CAst.v=name},_),_,args,types,body)),_) as fixpoint_expr = match recompute_binder_list [fixpoint_expr] with @@ -689,8 +689,8 @@ let do_generate_principle pconstants on_error register_built interactive_proof true in if register_built - then register_mes name rec_impls wf_mes wf_rel_opt (map_option (fun x -> x.CAst.v) wf_x) using_lemmas args types body pre_hook; - true + then register_mes name rec_impls wf_mes wf_rel_opt (map_option (fun x -> x.CAst.v) wf_x) using_lemmas args types body pre_hook, true + else pstate, true | _ -> List.iter (function ((_na,(_,ord),_args,_body,_type),_not) -> match ord with @@ -707,10 +707,10 @@ let do_generate_principle pconstants on_error register_built interactive_proof (* ok all the expressions are structural *) let recdefs,rec_impls = build_newrecursive fixpoint_exprl in let is_rec = List.exists (is_rec fix_names) recdefs in - let evd,pconstants = + let pstate,evd,pconstants = if register_built - then register_struct is_rec fixpoint_exprl - else (Evd.from_env (Global.env ()),pconstants) + then register_struct ~pstate is_rec fixpoint_exprl + else pstate, Evd.from_env (Global.env ()), pconstants in let evd = ref evd in generate_principle @@ -723,10 +723,11 @@ let do_generate_principle pconstants on_error register_built interactive_proof recdefs interactive_proof (Functional_principles_proofs.prove_princ_for_struct evd interactive_proof); - if register_built then begin derive_inversion fix_names; end; - true; + if register_built then + begin derive_inversion fix_names; end; + pstate, true in - () + pstate let rec add_args id new_args = CAst.map (function | CRef (qid,_) as b -> @@ -843,13 +844,14 @@ let rec get_args b t : Constrexpr.local_binder_expr list * | _ -> [],b,t -let make_graph (f_ref : GlobRef.t) = +let make_graph ~pstate (f_ref : GlobRef.t) = + let sigma, env = Option.cata Pfedit.get_current_context + (let e = Global.env () in Evd.from_env e, e) pstate in let c,c_body = match f_ref with | ConstRef c -> begin try c,Global.lookup_constant c with Not_found -> - let sigma, env = Pfedit.get_current_context () in raise (UserError (None,str "Cannot find " ++ Printer.pr_leconstr_env env sigma (mkConst c)) ) end | _ -> raise (UserError (None, str "Not a function reference") ) @@ -857,8 +859,7 @@ let make_graph (f_ref : GlobRef.t) = (match Global.body_of_constant_body c_body with | None -> error "Cannot build a graph over an axiom!" | Some (body, _) -> - let env = Global.env () in - let sigma = Evd.from_env env in + let env = Global.env () in let extern_body,extern_type = with_full_print (fun () -> (Constrextern.extern_constr false env sigma (EConstr.of_constr body), @@ -902,12 +903,11 @@ let make_graph (f_ref : GlobRef.t) = [((CAst.make id,None),(None,Constrexpr.CStructRec),nal_tas,t,Some b),[]] in let mp = Constant.modpath c in - do_generate_principle [c,Univ.Instance.empty] error_error false false expr_list; + let pstate = do_generate_principle ~pstate [c,Univ.Instance.empty] error_error false false expr_list in (* We register the infos *) List.iter (fun ((({CAst.v=id},_),_,_,_,_),_) -> add_Function false (Constant.make2 mp (Label.of_id id))) - expr_list) + expr_list; + pstate) let do_generate_principle = do_generate_principle [] warning_error true - - diff --git a/plugins/funind/indfun.mli b/plugins/funind/indfun.mli index f209fb19fd..acf85f539e 100644 --- a/plugins/funind/indfun.mli +++ b/plugins/funind/indfun.mli @@ -5,18 +5,16 @@ val warn_cannot_define_graph : ?loc:Loc.t -> Pp.t * Pp.t -> unit val warn_cannot_define_principle : ?loc:Loc.t -> Pp.t * Pp.t -> unit -val do_generate_principle : - bool -> - (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list -> - unit - +val do_generate_principle : pstate:Proof_global.t option -> + bool -> + (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list -> + Proof_global.t option -val functional_induction : +val functional_induction : bool -> EConstr.constr -> (EConstr.constr * EConstr.constr bindings) option -> Ltac_plugin.Tacexpr.or_and_intro_pattern option -> Goal.goal Evd.sigma -> Goal.goal list Evd.sigma - -val make_graph : GlobRef.t -> unit +val make_graph : pstate:Proof_global.t option -> GlobRef.t -> Proof_global.t option diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index 88546e9ae8..40f66ce5eb 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -129,7 +129,7 @@ let get_locality = function | Local -> true | Global -> false -let save with_clean id const ?hook uctx (locality,_,kind) = +let save id const ?hook uctx (locality,_,kind) = let fix_exn = Future.fix_exn_of const.const_entry_body in let l,r = match locality with | Discharge when Lib.sections_are_opened () -> @@ -143,7 +143,6 @@ let save with_clean id const ?hook uctx (locality,_,kind) = let kn = declare_constant id ~local (DefinitionEntry const, k) in (locality, ConstRef kn) in - if with_clean then Proof_global.discard_current (); Lemmas.call_hook ?hook ~fix_exn uctx [] l r; definition_message id @@ -276,12 +275,10 @@ let subst_Function (subst,finfos) = let discharge_Function (_,finfos) = Some finfos -let pr_ocst c = - let sigma, env = Pfedit.get_current_context () in +let pr_ocst env sigma c = Option.fold_right (fun v acc -> Printer.pr_lconstr_env env sigma (mkConst v)) c (mt ()) -let pr_info f_info = - let sigma, env = Pfedit.get_current_context () in +let pr_info env sigma f_info = str "function_constant := " ++ Printer.pr_lconstr_env env sigma (mkConst f_info.function_constant)++ fnl () ++ str "function_constant_type := " ++ @@ -289,17 +286,17 @@ let pr_info f_info = Printer.pr_lconstr_env env sigma (fst (Typeops.type_of_global_in_context env (ConstRef f_info.function_constant))) with e when CErrors.noncritical e -> mt ()) ++ fnl () ++ - str "equation_lemma := " ++ pr_ocst f_info.equation_lemma ++ fnl () ++ - str "completeness_lemma :=" ++ pr_ocst f_info.completeness_lemma ++ fnl () ++ - str "correctness_lemma := " ++ pr_ocst f_info.correctness_lemma ++ fnl () ++ - str "rect_lemma := " ++ pr_ocst f_info.rect_lemma ++ fnl () ++ - str "rec_lemma := " ++ pr_ocst f_info.rec_lemma ++ fnl () ++ - str "prop_lemma := " ++ pr_ocst f_info.prop_lemma ++ fnl () ++ + str "equation_lemma := " ++ pr_ocst env sigma f_info.equation_lemma ++ fnl () ++ + str "completeness_lemma :=" ++ pr_ocst env sigma f_info.completeness_lemma ++ fnl () ++ + str "correctness_lemma := " ++ pr_ocst env sigma f_info.correctness_lemma ++ fnl () ++ + str "rect_lemma := " ++ pr_ocst env sigma f_info.rect_lemma ++ fnl () ++ + str "rec_lemma := " ++ pr_ocst env sigma f_info.rec_lemma ++ fnl () ++ + str "prop_lemma := " ++ pr_ocst env sigma f_info.prop_lemma ++ fnl () ++ str "graph_ind := " ++ Printer.pr_lconstr_env env sigma (mkInd f_info.graph_ind) ++ fnl () -let pr_table tb = +let pr_table env sigma tb = let l = Cmap_env.fold (fun k v acc -> v::acc) tb [] in - Pp.prlist_with_sep fnl pr_info l + Pp.prlist_with_sep fnl (pr_info env sigma) l let in_Function : function_info -> Libobject.obj = let open Libobject in @@ -358,7 +355,7 @@ let add_Function is_general f = in update_Function finfos -let pr_table () = pr_table !from_function +let pr_table env sigma = pr_table env sigma !from_function (*********************************) (* Debuging *) let functional_induction_rewrite_dependent_proofs = ref true diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli index 4ec3131518..9670cf1fa7 100644 --- a/plugins/funind/indfun_common.mli +++ b/plugins/funind/indfun_common.mli @@ -43,8 +43,7 @@ val jmeq : unit -> EConstr.constr val jmeq_refl : unit -> EConstr.constr val save - : bool - -> Id.t + : Id.t -> Safe_typing.private_constants Entries.definition_entry -> ?hook:Lemmas.declaration_hook -> UState.t @@ -78,14 +77,11 @@ val find_Function_infos : Constant.t -> function_info val find_Function_of_graph : inductive -> function_info (* WARNING: To be used just after the graph definition !!! *) val add_Function : bool -> Constant.t -> unit - val update_Function : function_info -> unit - (** debugging *) -val pr_info : function_info -> Pp.t -val pr_table : unit -> Pp.t - +val pr_info : Environ.env -> Evd.evar_map -> function_info -> Pp.t +val pr_table : Environ.env -> Evd.evar_map -> Pp.t (* val function_debug : bool ref *) val do_observe : unit -> bool diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index 37dbfec4c9..edb698280f 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -802,16 +802,16 @@ let derive_correctness make_scheme (funs: pconstant list) (graphs:inductive list Ensures by: obvious i*) let lem_id = mk_correct_id f_id in - let (typ,_) = lemmas_types_infos.(i) in - Lemmas.start_proof + let (typ,_) = lemmas_types_infos.(i) in + let pstate = Lemmas.start_proof ~ontop:None lem_id (Decl_kinds.Global,false,((Decl_kinds.Proof Decl_kinds.Theorem))) !evd - typ; - ignore (Pfedit.by + typ in + let pstate = fst @@ Pfedit.by (Proofview.V82.tactic (observe_tac ("prove correctness ("^(Id.to_string f_id)^")") - (proving_tac i)))); - (Lemmas.save_proof (Vernacexpr.(Proved(Proof_global.Transparent,None)))); + (proving_tac i))) pstate in + let _ = Lemmas.save_proof_proved ?proof:None ~pstate ~opaque:Proof_global.Transparent ~idopt:None in let finfo = find_Function_infos (fst f_as_constant) in (* let lem_cst = fst (destConst (Constrintern.global_reference lem_id)) in *) let _,lem_cst_constr = Evd.fresh_global @@ -865,13 +865,13 @@ let derive_correctness make_scheme (funs: pconstant list) (graphs:inductive list Ensures by: obvious i*) let lem_id = mk_complete_id f_id in - Lemmas.start_proof lem_id + let pstate = Lemmas.start_proof ~ontop:None lem_id (Decl_kinds.Global,false,(Decl_kinds.Proof Decl_kinds.Theorem)) sigma - (fst lemmas_types_infos.(i)); - ignore (Pfedit.by + (fst lemmas_types_infos.(i)) in + let pstate = fst (Pfedit.by (Proofview.V82.tactic (observe_tac ("prove completeness ("^(Id.to_string f_id)^")") - (proving_tac i)))) ; - (Lemmas.save_proof (Vernacexpr.(Proved(Proof_global.Transparent,None)))); + (proving_tac i))) pstate) in + let _pstate = Lemmas.save_proof_proved ?proof:None ~pstate ~opaque:Proof_global.Transparent ~idopt:None in let finfo = find_Function_infos (fst f_as_constant) in let _,lem_cst_constr = Evd.fresh_global (Global.env ()) !evd (Constrintern.locate_reference (Libnames.qualid_of_ident lem_id)) in diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 988cae8fbf..3c2b03dfe0 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -58,10 +58,6 @@ let coq_constant m s = EConstr.of_constr @@ UnivGen.constr_of_monomorphic_global let arith_Nat = ["Coq"; "Arith";"PeanoNat";"Nat"] let arith_Lt = ["Coq"; "Arith";"Lt"] -let pr_leconstr_rd = - let sigma, env = Pfedit.get_current_context () in - Printer.pr_leconstr_env env sigma - let coq_init_constant s = EConstr.of_constr ( UnivGen.constr_of_monomorphic_global @@ @@ -76,7 +72,7 @@ let declare_fun f_id kind ?univs value = let ce = definition_entry ?univs value (*FIXME *) in ConstRef(declare_constant f_id (DefinitionEntry ce, kind));; -let defined () = Lemmas.save_proof (Vernacexpr.(Proved (Proof_global.Transparent,None))) +let defined pstate = Lemmas.save_proof_proved ?proof:None ~pstate ~opaque:Proof_global.Transparent ~idopt:None let def_of_const t = match (Constr.kind t) with @@ -232,6 +228,7 @@ let observe strm = let do_observe_tac s tac g = let goal = Printer.pr_goal g in + let s = s (pf_env g) (project g) in let lmsg = (str "recdef : ") ++ s in observe (s++fnl()); Stack.push (lmsg,goal) debug_queue; @@ -256,8 +253,8 @@ let observe_tclTHENLIST s tacl = then let rec aux n = function | [] -> tclIDTAC - | [tac] -> observe_tac (s ++ spc () ++ int n) tac - | tac::tacl -> observe_tac (s ++ spc () ++ int n) (tclTHEN tac (aux (succ n) tacl)) + | [tac] -> observe_tac (fun env sigma -> s env sigma ++ spc () ++ int n) tac + | tac::tacl -> observe_tac (fun env sigma -> s env sigma ++ spc () ++ int n) (tclTHEN tac (aux (succ n) tacl)) in aux 0 tacl else tclTHENLIST tacl @@ -272,11 +269,11 @@ let tclUSER tac is_mes l g = | None -> tclIDTAC | Some l -> tclMAP (fun id -> tclTRY (Proofview.V82.of_tactic (clear [id]))) (List.rev l) in - observe_tclTHENLIST (str "tclUSER1") + observe_tclTHENLIST (fun _ _ -> str "tclUSER1") [ clear_tac; if is_mes - then observe_tclTHENLIST (str "tclUSER2") + then observe_tclTHENLIST (fun _ _ -> str "tclUSER2") [ Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference (delayed_force Indfun_common.ltof_ref))]); @@ -303,7 +300,7 @@ let tclUSER_if_not_mes concl_tac is_mes names_to_suppress = (* [check_not_nested forbidden e] checks that [e] does not contains any variable of [forbidden] *) -let check_not_nested sigma forbidden e = +let check_not_nested env sigma forbidden e = let rec check_not_nested e = match EConstr.kind sigma e with | Rel _ -> () @@ -330,7 +327,6 @@ let check_not_nested sigma forbidden e = try check_not_nested e with UserError(_,p) -> - let _, env = Pfedit.get_current_context () in user_err ~hdr:"_" (str "on expr : " ++ Printer.pr_leconstr_env env sigma e ++ str " " ++ p) (* ['a info] contains the local information for traveling *) @@ -399,12 +395,12 @@ let treat_case forbid_new_ids to_intros finalize_tac nb_lam e infos : tactic = ) [] rev_context in let rev_ids = pf_get_new_ids (List.rev ids) g in let new_b = substl (List.map mkVar rev_ids) b in - observe_tclTHENLIST (str "treat_case1") + observe_tclTHENLIST (fun _ _ -> str "treat_case1") [ h_intros (List.rev rev_ids); Proofview.V82.of_tactic (intro_using teq_id); onLastHypId (fun heq -> - observe_tclTHENLIST (str "treat_case2")[ + observe_tclTHENLIST (fun _ _ -> str "treat_case2")[ Proofview.V82.of_tactic (clear to_intros); h_intros to_intros; (fun g' -> @@ -431,6 +427,7 @@ let treat_case forbid_new_ids to_intros finalize_tac nb_lam e infos : tactic = let rec travel_aux jinfo continuation_tac (expr_info:constr infos) g = let sigma = project g in + let env = pf_env g in match EConstr.kind sigma expr_info.info with | CoFix _ | Fix _ -> user_err Pp.(str "Function cannot treat local fixpoint or cofixpoint") | Proj _ -> user_err Pp.(str "Function cannot treat projections") @@ -446,18 +443,18 @@ let rec travel_aux jinfo continuation_tac (expr_info:constr infos) g = | Prod _ -> begin try - check_not_nested sigma (expr_info.f_id::expr_info.forbidden_ids) expr_info.info; + check_not_nested env sigma (expr_info.f_id::expr_info.forbidden_ids) expr_info.info; jinfo.otherS () expr_info continuation_tac expr_info g with e when CErrors.noncritical e -> - user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr_env (pf_env g) sigma expr_info.info ++ str " can not contain a recursive call to " ++ Id.print expr_info.f_id) + user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr_env env sigma expr_info.info ++ str " can not contain a recursive call to " ++ Id.print expr_info.f_id) end | Lambda(n,t,b) -> begin try - check_not_nested sigma (expr_info.f_id::expr_info.forbidden_ids) expr_info.info; + check_not_nested env sigma (expr_info.f_id::expr_info.forbidden_ids) expr_info.info; jinfo.otherS () expr_info continuation_tac expr_info g with e when CErrors.noncritical e -> - user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr_env (pf_env g) sigma expr_info.info ++ str " can not contain a recursive call to " ++ Id.print expr_info.f_id) + user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr_env env sigma expr_info.info ++ str " can not contain a recursive call to " ++ Id.print expr_info.f_id) end | Case(ci,t,a,l) -> begin @@ -485,8 +482,8 @@ let rec travel_aux jinfo continuation_tac (expr_info:constr infos) g = jinfo.apP (f,args) expr_info continuation_tac in travel_args jinfo expr_info.is_main_branch new_continuation_tac new_infos g - | Case _ -> user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr_env (pf_env g) sigma 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_leconstr_env (pf_env g) sigma expr_info.info ++ Pp.str ".") + | Case _ -> user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr_env env sigma 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_leconstr_env env sigma expr_info.info ++ Pp.str ".") end | Cast(t,_,_) -> travel jinfo continuation_tac {expr_info with info=t} g | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ | Int _ -> @@ -507,9 +504,9 @@ and travel_args jinfo is_final continuation_tac infos = in travel jinfo new_continuation_tac {infos with info=arg;is_final=false} -and travel jinfo continuation_tac expr_info = - observe_tac - (str jinfo.message ++ pr_leconstr_rd expr_info.info) +and travel jinfo continuation_tac expr_info = + observe_tac + (fun env sigma -> str jinfo.message ++ Printer.pr_leconstr_env env sigma expr_info.info) (travel_aux jinfo continuation_tac expr_info) (* Termination proof *) @@ -531,16 +528,16 @@ let rec prove_lt hyple g = in let y = List.hd (List.tl (snd (decompose_app sigma (pf_unsafe_type_of g (mkVar h))))) in - observe_tclTHENLIST (str "prove_lt1")[ + observe_tclTHENLIST (fun _ _ -> str "prove_lt1")[ Proofview.V82.of_tactic (apply (mkApp(le_lt_trans (),[|varx;y;varz;mkVar h|]))); - observe_tac (str "prove_lt") (prove_lt hyple) + observe_tac (fun _ _ -> str "prove_lt") (prove_lt hyple) ] with Not_found -> ( ( - observe_tclTHENLIST (str "prove_lt2")[ + observe_tclTHENLIST (fun _ _ -> str "prove_lt2")[ Proofview.V82.of_tactic (apply (delayed_force lt_S_n)); - (observe_tac (str "assumption: " ++ Printer.pr_goal g) (Proofview.V82.of_tactic assumption)) + (observe_tac (fun _ _ -> str "assumption: " ++ Printer.pr_goal g) (Proofview.V82.of_tactic assumption)) ]) ) end @@ -556,26 +553,26 @@ let rec destruct_bounds_aux infos (bound,hyple,rechyps) lbounds g = let h' = next_ident_away_in_goal (h'_id) ids in let ids = h'::ids in let def = next_ident_away_in_goal def_id ids in - observe_tclTHENLIST (str "destruct_bounds_aux1")[ + observe_tclTHENLIST (fun _ _ -> str "destruct_bounds_aux1")[ Proofview.V82.of_tactic (split (ImplicitBindings [s_max])); Proofview.V82.of_tactic (intro_then (fun id -> Proofview.V82.tactic begin - observe_tac (str "destruct_bounds_aux") + observe_tac (fun _ _ -> str "destruct_bounds_aux") (tclTHENS (Proofview.V82.of_tactic (simplest_case (mkVar id))) [ - observe_tclTHENLIST (str "")[Proofview.V82.of_tactic (intro_using h_id); + observe_tclTHENLIST (fun _ _ -> str "")[Proofview.V82.of_tactic (intro_using h_id); Proofview.V82.of_tactic (simplest_elim(mkApp(delayed_force lt_n_O,[|s_max|]))); Proofview.V82.of_tactic default_full_auto]; - observe_tclTHENLIST (str "destruct_bounds_aux2")[ - observe_tac (str "clearing k ") (Proofview.V82.of_tactic (clear [id])); + observe_tclTHENLIST (fun _ _ -> str "destruct_bounds_aux2")[ + observe_tac (fun _ _ -> str "clearing k ") (Proofview.V82.of_tactic (clear [id])); h_intros [k;h';def]; - observe_tac (str "simple_iter") (Proofview.V82.of_tactic (simpl_iter Locusops.onConcl)); - observe_tac (str "unfold functional") + observe_tac (fun _ _ -> str "simple_iter") (Proofview.V82.of_tactic (simpl_iter Locusops.onConcl)); + observe_tac (fun _ _ -> str "unfold functional") (Proofview.V82.of_tactic (unfold_in_concl[(Locus.OnlyOccurrences [1], evaluable_of_global_reference infos.func)])); ( - observe_tclTHENLIST (str "test")[ + observe_tclTHENLIST (fun _ _ -> str "test")[ list_rewrite true (List.fold_right (fun e acc -> (mkVar e,true)::acc) @@ -586,16 +583,16 @@ let rec destruct_bounds_aux infos (bound,hyple,rechyps) lbounds g = (* (List.map (fun e -> (mkVar e,true)) infos.eqs) *) (* ; *) - (observe_tac (str "finishing") + (observe_tac (fun _ _ -> str "finishing") (tclORELSE (Proofview.V82.of_tactic intros_reflexivity) - (observe_tac (str "calling prove_lt") (prove_lt hyple))))]) + (observe_tac (fun _ _ -> str "calling prove_lt") (prove_lt hyple))))]) ] ] )end)) ] g | (_,v_bound)::l -> - observe_tclTHENLIST (str "destruct_bounds_aux3")[ + observe_tclTHENLIST (fun _ _ -> str "destruct_bounds_aux3")[ Proofview.V82.of_tactic (simplest_elim (mkVar v_bound)); Proofview.V82.of_tactic (clear [v_bound]); tclDO 2 (Proofview.V82.of_tactic intro); @@ -603,7 +600,7 @@ let rec destruct_bounds_aux infos (bound,hyple,rechyps) lbounds g = (fun p_hyp -> (onNthHypId 2 (fun p -> - observe_tclTHENLIST (str "destruct_bounds_aux4")[ + observe_tclTHENLIST (fun _ _ -> str "destruct_bounds_aux4")[ Proofview.V82.of_tactic (simplest_elim (mkApp(delayed_force max_constr, [| bound; mkVar p|]))); tclDO 3 (Proofview.V82.of_tactic intro); @@ -627,32 +624,33 @@ let destruct_bounds infos = let terminate_app f_and_args expr_info continuation_tac infos = if expr_info.is_final && expr_info.is_main_branch then - observe_tclTHENLIST (str "terminate_app1")[ + observe_tclTHENLIST (fun _ _ -> str "terminate_app1")[ continuation_tac infos; - observe_tac (str "first split") + observe_tac (fun _ _ -> str "first split") (Proofview.V82.of_tactic (split (ImplicitBindings [infos.info]))); - observe_tac (str "destruct_bounds (1)") (destruct_bounds infos) + observe_tac (fun _ _ -> str "destruct_bounds (1)") (destruct_bounds infos) ] else continuation_tac infos let terminate_others _ expr_info continuation_tac infos = if expr_info.is_final && expr_info.is_main_branch then - observe_tclTHENLIST (str "terminate_others")[ + observe_tclTHENLIST (fun _ _ -> str "terminate_others")[ continuation_tac infos; - observe_tac (str "first split") + observe_tac (fun _ _ -> str "first split") (Proofview.V82.of_tactic (split (ImplicitBindings [infos.info]))); - observe_tac (str "destruct_bounds") (destruct_bounds infos) + observe_tac (fun _ _ -> str "destruct_bounds") (destruct_bounds infos) ] else continuation_tac infos let terminate_letin (na,b,t,e) expr_info continuation_tac info g = let sigma = project g in + let env = pf_env g in let new_e = subst1 info.info e in let new_forbidden = let forbid = try - check_not_nested sigma (expr_info.f_id::expr_info.forbidden_ids) b; + check_not_nested env sigma (expr_info.f_id::expr_info.forbidden_ids) b; true with e when CErrors.noncritical e -> false in @@ -697,7 +695,7 @@ let mkDestructEq : let new_hyps = mkApp(Lazy.force refl_equal, [|type_of_expr; expr|]):: to_revert_constr in pf_typel new_hyps (fun _ -> - observe_tclTHENLIST (str "mkDestructEq") + observe_tclTHENLIST (fun _ _ -> str "mkDestructEq") [Proofview.V82.of_tactic (generalize new_hyps); (fun g2 -> let changefun patvars env sigma = @@ -709,9 +707,10 @@ let mkDestructEq : let terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos g = let sigma = project g in + let env = pf_env g in let f_is_present = try - check_not_nested sigma (expr_info.f_id::expr_info.forbidden_ids) a; + check_not_nested env sigma (expr_info.f_id::expr_info.forbidden_ids) a; false with e when CErrors.noncritical e -> true @@ -725,45 +724,46 @@ let terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos g = let destruct_tac,rev_to_thin_intro = mkDestructEq [expr_info.rec_arg_id] a' g in let to_thin_intro = List.rev rev_to_thin_intro in - observe_tac (str "treating cases (" ++ int (Array.length l) ++ str")" ++ spc () ++ Printer.pr_leconstr_env (pf_env g) sigma a') + observe_tac (fun _ _ -> str "treating cases (" ++ int (Array.length l) ++ str")" ++ spc () ++ Printer.pr_leconstr_env (pf_env g) sigma a') (try (tclTHENS destruct_tac - (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) + (List.map_i (fun i e -> observe_tac (fun _ _ -> 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(Some "Refiner.thensn_tac3",_) | UserError(Some "Refiner.tclFAIL_s",_) -> - (observe_tac (str "is computable " ++ Printer.pr_leconstr_env (pf_env g) sigma new_info.info) (next_step continuation_tac {new_info with info = Reductionops.nf_betaiotazeta (pf_env g) sigma new_info.info} ) + (observe_tac (fun _ _ -> str "is computable " ++ Printer.pr_leconstr_env env sigma new_info.info) (next_step continuation_tac {new_info with info = Reductionops.nf_betaiotazeta (pf_env g) sigma new_info.info} ) )) g let terminate_app_rec (f,args) expr_info continuation_tac _ g = let sigma = project g in - List.iter (check_not_nested sigma (expr_info.f_id::expr_info.forbidden_ids)) + let env = pf_env g in + List.iter (check_not_nested env sigma (expr_info.f_id::expr_info.forbidden_ids)) args; begin try let v = List.assoc_f (List.equal (EConstr.eq_constr sigma)) args expr_info.args_assoc in let new_infos = {expr_info with info = v} in - observe_tclTHENLIST (str "terminate_app_rec")[ + observe_tclTHENLIST (fun _ _ -> str "terminate_app_rec")[ continuation_tac new_infos; if expr_info.is_final && expr_info.is_main_branch then - observe_tclTHENLIST (str "terminate_app_rec1")[ - observe_tac (str "first split") + observe_tclTHENLIST (fun _ _ -> str "terminate_app_rec1")[ + observe_tac (fun _ _ -> str "first split") (Proofview.V82.of_tactic (split (ImplicitBindings [new_infos.info]))); - observe_tac (str "destruct_bounds (3)") + observe_tac (fun _ _ -> str "destruct_bounds (3)") (destruct_bounds new_infos) ] else tclIDTAC ] g with Not_found -> - observe_tac (str "terminate_app_rec not found") (tclTHENS + observe_tac (fun _ _ -> str "terminate_app_rec not found") (tclTHENS (Proofview.V82.of_tactic (simplest_elim (mkApp(mkVar expr_info.ih,Array.of_list args)))) [ - observe_tclTHENLIST (str "terminate_app_rec2")[ + observe_tclTHENLIST (fun _ _ -> str "terminate_app_rec2")[ Proofview.V82.of_tactic (intro_using rec_res_id); Proofview.V82.of_tactic intro; onNthHypId 1 @@ -776,14 +776,14 @@ let terminate_app_rec (f,args) expr_info continuation_tac _ g = (v,v_bound)::expr_info.values_and_bounds; args_assoc=(args,mkVar v)::expr_info.args_assoc } in - observe_tclTHENLIST (str "terminate_app_rec3")[ + observe_tclTHENLIST (fun _ _ -> str "terminate_app_rec3")[ continuation_tac new_infos; if expr_info.is_final && expr_info.is_main_branch then - observe_tclTHENLIST (str "terminate_app_rec4")[ - observe_tac (str "first split") + observe_tclTHENLIST (fun _ _ -> str "terminate_app_rec4")[ + observe_tac (fun _ _ -> str "first split") (Proofview.V82.of_tactic (split (ImplicitBindings [new_infos.info]))); - observe_tac (str "destruct_bounds (2)") + observe_tac (fun _ _ -> str "destruct_bounds (2)") (destruct_bounds new_infos) ] else @@ -793,12 +793,12 @@ let terminate_app_rec (f,args) expr_info continuation_tac _ g = ) ) ]; - observe_tac (str "proving decreasing") ( + observe_tac (fun _ _ -> str "proving decreasing") ( tclTHENS (* proof of args < formal args *) (Proofview.V82.of_tactic (apply (Lazy.force expr_info.acc_inv))) [ - observe_tac (str "assumption") (Proofview.V82.of_tactic assumption); - observe_tclTHENLIST (str "terminate_app_rec5") + observe_tac (fun _ _ -> str "assumption") (Proofview.V82.of_tactic assumption); + observe_tclTHENLIST (fun _ _ -> str "terminate_app_rec5") [ tclTRY(list_rewrite true (List.map @@ -834,7 +834,7 @@ let prove_terminate = travel terminate_info (* Equation proof *) let equation_case next_step (ci,a,t,l) expr_info continuation_tac infos = - observe_tac (str "equation case") (terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos) + observe_tac (fun _ _ -> str "equation case") (terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos) let rec prove_le g = let sigma = project g in @@ -860,9 +860,9 @@ let rec prove_le g = let _,args = decompose_app sigma t in List.hd (List.tl args) in - observe_tclTHENLIST (str "prove_le")[ + observe_tclTHENLIST (fun _ _ -> str "prove_le")[ Proofview.V82.of_tactic (apply(mkApp(le_trans (),[|x;y;z;mkVar h|]))); - observe_tac (str "prove_le (rec)") (prove_le) + observe_tac (fun _ _ -> str "prove_le (rec)") (prove_le) ] with Not_found -> tclFAIL 0 (mt()) end; @@ -872,8 +872,8 @@ let rec prove_le g = let rec make_rewrite_list expr_info max = function | [] -> tclIDTAC | (_,p,hp)::l -> - observe_tac (str "make_rewrite_list") (tclTHENS - (observe_tac (str "rewrite heq on " ++ Id.print p ) ( + observe_tac (fun _ _ -> str "make_rewrite_list") (tclTHENS + (observe_tac (fun _ _ -> str "rewrite heq on " ++ Id.print p ) ( (fun g -> let sigma = project g in let t_eq = compute_renamed_type g (mkVar hp) in @@ -890,16 +890,16 @@ let rec make_rewrite_list expr_info max = function CAst.make @@ (NamedHyp k, f_S max)]) false) g) ) ) [make_rewrite_list expr_info max l; - observe_tclTHENLIST (str "make_rewrite_list")[ (* x < S max proof *) + observe_tclTHENLIST (fun _ _ -> str "make_rewrite_list")[ (* x < S max proof *) Proofview.V82.of_tactic (apply (delayed_force le_lt_n_Sm)); - observe_tac (str "prove_le(2)") prove_le + observe_tac (fun _ _ -> str "prove_le(2)") prove_le ] ] ) let make_rewrite expr_info l hp max = tclTHENFIRST - (observe_tac (str "make_rewrite") (make_rewrite_list expr_info max l)) - (observe_tac (str "make_rewrite") (tclTHENS + (observe_tac (fun _ _ -> str "make_rewrite") (make_rewrite_list expr_info max l)) + (observe_tac (fun _ _ -> str "make_rewrite") (tclTHENS (fun g -> let sigma = project g in let t_eq = compute_renamed_type g (mkVar hp) in @@ -909,30 +909,30 @@ let make_rewrite expr_info l hp max = let def_na,_,_ = destProd sigma t in Nameops.Name.get_id k_na.binder_name,Nameops.Name.get_id def_na.binder_name in - observe_tac (str "general_rewrite_bindings") + observe_tac (fun _ _ -> str "general_rewrite_bindings") (Proofview.V82.of_tactic (general_rewrite_bindings false Locus.AllOccurrences true (* dep proofs also: *) true (mkVar hp, ExplicitBindings[CAst.make @@ (NamedHyp def, expr_info.f_constr); CAst.make @@ (NamedHyp k, f_S (f_S max))]) false)) g) - [observe_tac(str "make_rewrite finalize") ( + [observe_tac(fun _ _ -> str "make_rewrite finalize") ( (* tclORELSE( h_reflexivity) *) - (observe_tclTHENLIST (str "make_rewrite")[ + (observe_tclTHENLIST (fun _ _ -> str "make_rewrite")[ Proofview.V82.of_tactic (simpl_iter Locusops.onConcl); - observe_tac (str "unfold functional") + observe_tac (fun _ _ -> str "unfold functional") (Proofview.V82.of_tactic (unfold_in_concl[(Locus.OnlyOccurrences [1], evaluable_of_global_reference expr_info.func)])); (list_rewrite true (List.map (fun e -> mkVar e,true) expr_info.eqs)); - (observe_tac (str "h_reflexivity") + (observe_tac (fun _ _ -> str "h_reflexivity") (Proofview.V82.of_tactic intros_reflexivity) ) ])) ; - observe_tclTHENLIST (str "make_rewrite1")[ (* x < S (S max) proof *) + observe_tclTHENLIST (fun _ _ -> str "make_rewrite1")[ (* x < S (S max) proof *) Proofview.V82.of_tactic (apply (EConstr.of_constr (delayed_force le_lt_SS))); - observe_tac (str "prove_le (3)") prove_le + observe_tac (fun _ _ -> str "prove_le (3)") prove_le ] ]) ) @@ -941,7 +941,7 @@ let rec compute_max rew_tac max l = match l with | [] -> rew_tac max | (_,p,_)::l -> - observe_tclTHENLIST (str "compute_max")[ + observe_tclTHENLIST (fun _ _ -> str "compute_max")[ Proofview.V82.of_tactic (simplest_elim (mkApp(delayed_force max_constr, [| max; mkVar p|]))); tclDO 3 (Proofview.V82.of_tactic intro); @@ -958,17 +958,17 @@ let rec destruct_hex expr_info acc l = match List.rev acc with | [] -> tclIDTAC | (_,p,hp)::tl -> - observe_tac (str "compute max ") (compute_max (make_rewrite expr_info tl hp) (mkVar p) tl) + observe_tac (fun _ _ -> str "compute max ") (compute_max (make_rewrite expr_info tl hp) (mkVar p) tl) end | (v,hex)::l -> - observe_tclTHENLIST (str "destruct_hex")[ + observe_tclTHENLIST (fun _ _ -> str "destruct_hex")[ Proofview.V82.of_tactic (simplest_case (mkVar hex)); Proofview.V82.of_tactic (clear [hex]); tclDO 2 (Proofview.V82.of_tactic intro); onNthHypId 1 (fun hp -> onNthHypId 2 (fun p -> observe_tac - (str "destruct_hex after " ++ Id.print hp ++ spc () ++ Id.print p) + (fun _ _ -> str "destruct_hex after " ++ Id.print hp ++ spc () ++ Id.print p) (destruct_hex expr_info ((v,p,hp)::acc) l) ) ) @@ -976,7 +976,7 @@ let rec destruct_hex expr_info acc l = let rec intros_values_eq expr_info acc = tclORELSE( - observe_tclTHENLIST (str "intros_values_eq")[ + observe_tclTHENLIST (fun _ _ -> str "intros_values_eq")[ tclDO 2 (Proofview.V82.of_tactic intro); onNthHypId 1 (fun hex -> (onNthHypId 2 (fun v -> intros_values_eq expr_info ((v,hex)::acc))) @@ -988,16 +988,16 @@ let rec intros_values_eq expr_info acc = let equation_others _ expr_info continuation_tac infos = if expr_info.is_final && expr_info.is_main_branch - then - observe_tac (str "equation_others (cont_tac +intros) " ++ pr_leconstr_rd expr_info.info) + then + observe_tac (fun env sigma -> str "equation_others (cont_tac +intros) " ++ Printer.pr_leconstr_env env sigma expr_info.info) (tclTHEN (continuation_tac infos) - (observe_tac (str "intros_values_eq equation_others " ++ pr_leconstr_rd expr_info.info) (intros_values_eq expr_info []))) - else observe_tac (str "equation_others (cont_tac) " ++ pr_leconstr_rd expr_info.info) (continuation_tac infos) + (observe_tac (fun env sigma -> str "intros_values_eq equation_others " ++ Printer.pr_leconstr_env env sigma expr_info.info) (intros_values_eq expr_info []))) + else observe_tac (fun env sigma -> str "equation_others (cont_tac) " ++ Printer.pr_leconstr_env env sigma expr_info.info) (continuation_tac infos) let equation_app f_and_args expr_info continuation_tac infos = if expr_info.is_final && expr_info.is_main_branch - then ((observe_tac (str "intros_values_eq equation_app") (intros_values_eq expr_info []))) + then ((observe_tac (fun _ _ -> str "intros_values_eq equation_app") (intros_values_eq expr_info []))) else continuation_tac infos let equation_app_rec (f,args) expr_info continuation_tac info g = @@ -1006,19 +1006,19 @@ let equation_app_rec (f,args) expr_info continuation_tac info g = try let v = List.assoc_f (List.equal (EConstr.eq_constr sigma)) args expr_info.args_assoc in let new_infos = {expr_info with info = v} in - observe_tac (str "app_rec found") (continuation_tac new_infos) g + observe_tac (fun _ _ -> str "app_rec found") (continuation_tac new_infos) g with Not_found -> if expr_info.is_final && expr_info.is_main_branch then - observe_tclTHENLIST (str "equation_app_rec") + observe_tclTHENLIST (fun _ _ -> str "equation_app_rec") [ Proofview.V82.of_tactic (simplest_case (mkApp (expr_info.f_terminate,Array.of_list args))); continuation_tac {expr_info with args_assoc = (args,delayed_force coq_O)::expr_info.args_assoc}; - observe_tac (str "app_rec intros_values_eq") (intros_values_eq expr_info []) + observe_tac (fun _ _ -> str "app_rec intros_values_eq") (intros_values_eq expr_info []) ] g else - observe_tclTHENLIST (str "equation_app_rec1")[ + observe_tclTHENLIST (fun _ _ -> str "equation_app_rec1")[ Proofview.V82.of_tactic (simplest_case (mkApp (expr_info.f_terminate,Array.of_list args))); - observe_tac (str "app_rec not_found") (continuation_tac {expr_info with args_assoc = (args,delayed_force coq_O)::expr_info.args_assoc}) + observe_tac (fun _ _ -> str "app_rec not_found") (continuation_tac {expr_info with args_assoc = (args,delayed_force coq_O)::expr_info.args_assoc}) ] g end @@ -1102,7 +1102,7 @@ let termination_proof_header is_mes input_type ids args_id relation (h_intros args_id) (tclTHENS (observe_tac - (str "first assert") + (fun _ _ -> str "first assert") (Proofview.V82.of_tactic (assert_before (Name wf_rec_arg) (mkApp (delayed_force acc_rel, @@ -1114,7 +1114,7 @@ let termination_proof_header is_mes input_type ids args_id relation (* accesibility proof *) tclTHENS (observe_tac - (str "second assert") + (fun _ _ -> str "second assert") (Proofview.V82.of_tactic (assert_before (Name wf_thm) (mkApp (delayed_force well_founded,[|input_type;relation|])) @@ -1122,26 +1122,26 @@ let termination_proof_header is_mes input_type ids args_id relation ) [ (* interactive proof that the relation is well_founded *) - observe_tac (str "wf_tac") (wf_tac is_mes (Some args_id)); + observe_tac (fun _ _ -> str "wf_tac") (wf_tac is_mes (Some args_id)); (* this gives the accessibility argument *) observe_tac - (str "apply wf_thm") + (fun _ _ -> str "apply wf_thm") (Proofview.V82.of_tactic (Simple.apply (mkApp(mkVar wf_thm,[|mkVar rec_arg_id|]))) ) ] ; (* rest of the proof *) - observe_tclTHENLIST (str "rest of proof") - [observe_tac (str "generalize") + observe_tclTHENLIST (fun _ _ -> str "rest of proof") + [observe_tac (fun _ _ -> str "generalize") (onNLastHypsId (nargs+1) (tclMAP (fun id -> tclTHEN (Proofview.V82.of_tactic (Tactics.generalize [mkVar id])) (Proofview.V82.of_tactic (clear [id]))) )) ; - observe_tac (str "fix") (Proofview.V82.of_tactic (fix hrec (nargs+1))); + observe_tac (fun _ _ -> str "fix") (Proofview.V82.of_tactic (fix hrec (nargs+1))); h_intros args_id; Proofview.V82.of_tactic (Simple.intro wf_rec_arg); - observe_tac (str "tac") (tac wf_rec_arg hrec wf_rec_arg acc_inv) + observe_tac (fun _ _ -> str "tac") (tac wf_rec_arg hrec wf_rec_arg acc_inv) ] ] ) g @@ -1220,8 +1220,8 @@ let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_a g end -let get_current_subgoals_types () = - let p = Proof_global.give_me_the_proof () in +let get_current_subgoals_types pstate = + let p = Proof_global.give_me_the_proof pstate in let sgs,_,_,_,sigma = Proof.proof p in sigma, List.map (Goal.V82.abstract_type sigma) sgs @@ -1281,8 +1281,8 @@ let clear_goals sigma = List.map clear_goal -let build_new_goal_type () = - let sigma, sub_gls_types = get_current_subgoals_types () in +let build_new_goal_type pstate = + let sigma, sub_gls_types = get_current_subgoals_types pstate in (* Pp.msgnl (str "sub_gls_types1 := " ++ Util.prlist_with_sep (fun () -> Pp.fnl () ++ Pp.fnl ()) Printer.pr_lconstr sub_gls_types); *) let sub_gls_types = clear_goals sigma sub_gls_types in (* Pp.msgnl (str "sub_gls_types2 := " ++ Pp.prlist_with_sep (fun () -> Pp.fnl () ++ Pp.fnl ()) Printer.pr_lconstr sub_gls_types); *) @@ -1297,9 +1297,9 @@ let is_opaque_constant c = | Declarations.Def _ -> Proof_global.Transparent | Declarations.Primitive _ -> Proof_global.Opaque -let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decompose_and_tac,nb_goal) = +let open_new_goal pstate build_proof sigma using_lemmas ref_ goal_name (gls_type,decompose_and_tac,nb_goal) = (* Pp.msgnl (str "gls_type := " ++ Printer.pr_lconstr gls_type); *) - let current_proof_name = Proof_global.get_current_proof_name () in + let current_proof_name = Proof_global.get_current_proof_name pstate in let name = match goal_name with | Some s -> s | None -> @@ -1323,11 +1323,10 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp let lid = ref [] in let h_num = ref (-1) in let env = Global.env () in - Proof_global.discard_all (); - build_proof (Evd.from_env env) + let pstate = build_proof env (Evd.from_env env) ( fun gls -> let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gls) in - observe_tclTHENLIST (str "") + observe_tclTHENLIST (fun _ _ -> str "") [ Proofview.V82.of_tactic (generalize [lemma]); Proofview.V82.of_tactic (Simple.intro hid); @@ -1351,7 +1350,7 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp Proofview.V82.of_tactic (Auto.h_auto None [] (Some [])) g | _ -> incr h_num; - (observe_tac (str "finishing using") + (observe_tac (fun _ _ -> str "finishing using") ( tclCOMPLETE( tclFIRST[ @@ -1367,20 +1366,19 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp ) ) g) -; - Lemmas.save_proof (Vernacexpr.Proved(opacity,None)); + in + let _pstate = Lemmas.save_proof_proved ?proof:None ~pstate ~opaque:opacity ~idopt:None in + () in - Lemmas.start_proof + let pstate = Lemmas.start_proof ~ontop:(Some pstate) na (Decl_kinds.Global, false (* FIXME *), Decl_kinds.Proof Decl_kinds.Lemma) - sigma gls_type - ~hook:(Lemmas.mk_hook hook); - if Indfun_common.is_strict_tcc () + sigma gls_type ~hook:(Lemmas.mk_hook hook) in + let pstate = if Indfun_common.is_strict_tcc () then - ignore (by (Proofview.V82.tactic (tclIDTAC))) + fst @@ by (Proofview.V82.tactic (tclIDTAC)) pstate else - begin - ignore (by (Proofview.V82.tactic begin + fst @@ by (Proofview.V82.tactic begin fun g -> tclTHEN (decompose_and_tac) @@ -1396,14 +1394,12 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp ) using_lemmas) ) tclIDTAC) - g end)) - end; + g end) pstate + in try - ignore (by (Proofview.V82.tactic tclIDTAC)); (* raises UserError _ if the proof is complete *) + Some (fst @@ by (Proofview.V82.tactic tclIDTAC) pstate) (* raises UserError _ if the proof is complete *) with UserError _ -> - defined () - - + defined pstate let com_terminate tcc_lemma_name @@ -1416,32 +1412,26 @@ let com_terminate thm_name using_lemmas nb_args ctx hook = - let start_proof ctx (tac_start:tactic) (tac_end:tactic) = - let evd, env = Pfedit.get_current_context () in - Lemmas.start_proof thm_name + let start_proof env ctx (tac_start:tactic) (tac_end:tactic) = + let pstate = Lemmas.start_proof ~ontop:None thm_name (Global, false (* FIXME *), Proof Lemma) ~sign:(Environ.named_context_val env) - ctx (EConstr.of_constr (compute_terminate_type nb_args fonctional_ref)) ~hook; - - ignore (by (Proofview.V82.tactic (observe_tac (str "starting_tac") tac_start))); - ignore (by (Proofview.V82.tactic (observe_tac (str "whole_start") (whole_start tac_end nb_args is_mes fonctional_ref - input_type relation rec_arg_num )))) + ctx (EConstr.of_constr (compute_terminate_type nb_args fonctional_ref)) ~hook in + let pstate = fst @@ by (Proofview.V82.tactic (observe_tac (fun _ _ -> str "starting_tac") tac_start)) pstate in + fst @@ by (Proofview.V82.tactic (observe_tac (fun _ _ -> str "whole_start") (whole_start tac_end nb_args is_mes fonctional_ref + input_type relation rec_arg_num ))) pstate in - start_proof ctx tclIDTAC tclIDTAC; + let pstate = start_proof Global.(env ()) ctx tclIDTAC tclIDTAC in try - let sigma, new_goal_type = build_new_goal_type () in + let sigma, new_goal_type = build_new_goal_type pstate in let sigma = Evd.from_ctx (Evd.evar_universe_context sigma) in - open_new_goal start_proof sigma + open_new_goal pstate start_proof sigma using_lemmas tcc_lemma_ref (Some tcc_lemma_name) - (new_goal_type); + (new_goal_type) with EmptySubgoals -> (* a non recursive function declared with measure ! *) tcc_lemma_ref := Not_needed; - defined () - - - - + defined pstate let start_equation (f:GlobRef.t) (term_f:GlobRef.t) (cont_tactic:Id.t list -> tactic) g = @@ -1451,33 +1441,27 @@ let start_equation (f:GlobRef.t) (term_f:GlobRef.t) let terminate_constr = EConstr.of_constr terminate_constr in let nargs = nb_prod (project g) (EConstr.of_constr (type_of_const sigma terminate_constr)) in let x = n_x_id ids nargs in - observe_tac (str "start_equation") (observe_tclTHENLIST (str "start_equation") [ + observe_tac (fun _ _ -> str "start_equation") (observe_tclTHENLIST (fun _ _ -> str "start_equation") [ h_intros x; Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference f)]); - observe_tac (str "simplest_case") + observe_tac (fun _ _ -> str "simplest_case") (Proofview.V82.of_tactic (simplest_case (mkApp (terminate_constr, Array.of_list (List.map mkVar x))))); - observe_tac (str "prove_eq") (cont_tactic x)]) g;; + observe_tac (fun _ _ -> str "prove_eq") (cont_tactic x)]) g;; -let (com_eqn : int -> Id.t -> - GlobRef.t -> GlobRef.t -> GlobRef.t - -> Constr.t -> unit) = - fun nb_arg eq_name functional_ref f_ref terminate_ref equation_lemma_type -> +let com_eqn sign uctx nb_arg eq_name functional_ref f_ref terminate_ref equation_lemma_type = let open CVars in let opacity = match terminate_ref with | ConstRef c -> is_opaque_constant c | _ -> anomaly ~label:"terminate_lemma" (Pp.str "not a constant.") in - let evd, env = Pfedit.get_current_context () in - let evd = Evd.from_ctx (Evd.evar_universe_context evd) in + let evd = Evd.from_ctx uctx in let f_constr = constr_of_global f_ref in let equation_lemma_type = subst1 f_constr equation_lemma_type in - (Lemmas.start_proof eq_name (Global, false, Proof Lemma) - ~sign:(Environ.named_context_val env) - evd - (EConstr.of_constr equation_lemma_type); - ignore (by + let pstate = Lemmas.start_proof ~ontop:None eq_name (Global, false, Proof Lemma) ~sign evd + (EConstr.of_constr equation_lemma_type) in + let pstate = fst @@ by (Proofview.V82.tactic (start_equation f_ref terminate_ref (fun x -> prove_eq (fun _ -> tclIDTAC) @@ -1504,15 +1488,16 @@ let (com_eqn : int -> Id.t -> ih = Id.of_string "______"; } ) - ))); + )) pstate in (* (try Vernacentries.interp (Vernacexpr.VernacShow Vernacexpr.ShowProof) with _ -> ()); *) (* Vernacentries.interp (Vernacexpr.VernacShow Vernacexpr.ShowScript); *) - Flags.silently (fun () -> Lemmas.save_proof (Vernacexpr.Proved(opacity,None))) () ; -(* Pp.msgnl (str "eqn finished"); *) - );; + let _ = Flags.silently (fun () -> Lemmas.save_proof_proved ?proof:None ~pstate ~opaque:opacity ~idopt:None) () in + () +(* Pp.msgnl (fun _ _ -> str "eqn finished"); *) + let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num eq - generate_induction_principle using_lemmas : unit = + generate_induction_principle using_lemmas : Proof_global.t option = let open Term in let open Constr in let open CVars in @@ -1527,15 +1512,15 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num let equation_lemma_type = Reductionops.nf_betaiotazeta env evd (Evarutil.nf_evar evd ty) in let function_type = EConstr.to_constr ~abort_on_undefined_evars:false evd function_type in let equation_lemma_type = EConstr.Unsafe.to_constr equation_lemma_type in - (* Pp.msgnl (str "lemma type := " ++ Printer.pr_lconstr equation_lemma_type ++ fnl ()); *) + (* Pp.msgnl (fun _ _ -> str "lemma type := " ++ Printer.pr_lconstr equation_lemma_type ++ fnl ()); *) let res_vars,eq' = decompose_prod equation_lemma_type in let env_eq' = Environ.push_rel_context (List.map (fun (x,y) -> LocalAssum (x,y)) res_vars) env in let eq' = Reductionops.nf_zeta env_eq' evd (EConstr.of_constr eq') in let eq' = EConstr.Unsafe.to_constr eq' in let res = -(* Pp.msgnl (str "res_var :=" ++ Printer.pr_lconstr_env (push_rel_context (List.map (function (x,t) -> (x,None,t)) res_vars) env) eq'); *) -(* Pp.msgnl (str "rec_arg_num := " ++ str (string_of_int rec_arg_num)); *) -(* Pp.msgnl (str "eq' := " ++ str (string_of_int rec_arg_num)); *) +(* Pp.msgnl (fun _ _ -> str "res_var :=" ++ Printer.pr_lconstr_env (push_rel_context (List.map (function (x,t) -> (x,None,t)) res_vars) env) eq'); *) +(* Pp.msgnl (fun _ _ -> str "rec_arg_num := " ++ str (fun _ _ -> string_of_int rec_arg_num)); *) +(* Pp.msgnl (fun _ _ -> str "eq' := " ++ str (fun _ _ -> string_of_int rec_arg_num)); *) match Constr.kind eq' with | App(e,[|_;_;eq_fix|]) -> mkLambda (make_annot (Name function_name) Sorts.Relevant,function_type,subst_var function_name (compose_lam res_vars eq_fix)) @@ -1560,14 +1545,16 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num let evd = Evd.from_ctx evuctx in let tcc_lemma_name = add_suffix function_name "_tcc" in let tcc_lemma_constr = ref Undefined in - (* let _ = Pp.msgnl (str "relation := " ++ Printer.pr_lconstr_env env_with_pre_rec_args relation) in *) - let hook _ _ _ _ = + (* let _ = Pp.msgnl (fun _ _ -> str "relation := " ++ Printer.pr_lconstr_env env_with_pre_rec_args relation) in *) + let hook uctx _ _ _ = let term_ref = Nametab.locate (qualid_of_ident term_id) in let f_ref = declare_f function_name (IsProof Lemma) arg_types term_ref in let _ = Extraction_plugin.Table.extraction_inline true [qualid_of_ident term_id] in (* message "start second proof"; *) - let stop = - try com_eqn (List.length res_vars) equation_id functional_ref f_ref term_ref (subst_var function_name equation_lemma_type); + let stop = + (* XXX: What is the correct way to get sign at hook time *) + let sign = Environ.named_context_val Global.(env ()) in + try com_eqn sign uctx (List.length res_vars) equation_id functional_ref f_ref term_ref (subst_var function_name equation_lemma_type); false with e when CErrors.noncritical e -> begin @@ -1599,14 +1586,14 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num in (* XXX STATE Why do we need this... why is the toplevel protection not enought *) funind_purify (fun () -> - com_terminate - tcc_lemma_name - tcc_lemma_constr - is_mes functional_ref - (EConstr.of_constr rec_arg_type) - relation rec_arg_num - term_id - using_lemmas - (List.length res_vars) - evd (Lemmas.mk_hook hook)) - () + let pstate = com_terminate + tcc_lemma_name + tcc_lemma_constr + is_mes functional_ref + (EConstr.of_constr rec_arg_type) + relation rec_arg_num + term_id + using_lemmas + (List.length res_vars) + evd (Lemmas.mk_hook hook) + in pstate) () diff --git a/plugins/funind/recdef.mli b/plugins/funind/recdef.mli index 549f1fc0e4..a006c2c354 100644 --- a/plugins/funind/recdef.mli +++ b/plugins/funind/recdef.mli @@ -14,6 +14,6 @@ bool -> int -> Constrexpr.constr_expr -> (pconstant -> Indfun_common.tcc_lemma_value ref -> pconstant -> - pconstant -> int -> EConstr.types -> int -> EConstr.constr -> unit) -> Constrexpr.constr_expr list -> unit + pconstant -> int -> EConstr.types -> int -> EConstr.constr -> unit) -> Constrexpr.constr_expr list -> Proof_global.t option diff --git a/plugins/ltac/extraargs.mlg b/plugins/ltac/extraargs.mlg index 5d5d45c58f..eb9cacb975 100644 --- a/plugins/ltac/extraargs.mlg +++ b/plugins/ltac/extraargs.mlg @@ -145,31 +145,30 @@ END let pr_occurrences = pr_occurrences () () () -let pr_gen prc _prlc _prtac c = prc c +let pr_gen env sigma prc _prlc _prtac x = prc env sigma x -let pr_globc _prc _prlc _prtac (_,glob) = - let _, env = Pfedit.get_current_context () in +let pr_globc env sigma _prc _prlc _prtac (_,glob) = Printer.pr_glob_constr_env env glob let interp_glob ist gl (t,_) = Tacmach.project gl , (ist,t) let glob_glob = Tacintern.intern_constr -let pr_lconstr _ prc _ c = prc c +let pr_lconstr env sigma _ prc _ c = prc env sigma c let subst_glob = Tacsubst.subst_glob_constr_and_expr } ARGUMENT EXTEND glob - PRINTED BY { pr_globc } + PRINTED BY { pr_globc env sigma } INTERPRETED BY { interp_glob } GLOBALIZED BY { glob_glob } SUBSTITUTED BY { subst_glob } - RAW_PRINTED BY { pr_gen } - GLOB_PRINTED BY { pr_gen } + RAW_PRINTED BY { pr_gen env sigma } + GLOB_PRINTED BY { pr_gen env sigma } | [ constr(c) ] -> { c } END @@ -181,20 +180,20 @@ let l_constr = Pcoq.Constr.lconstr ARGUMENT EXTEND lconstr TYPED AS constr - PRINTED BY { pr_lconstr } + PRINTED BY { pr_lconstr env sigma } | [ l_constr(c) ] -> { c } END ARGUMENT EXTEND lglob TYPED AS glob - PRINTED BY { pr_globc } + PRINTED BY { pr_globc env sigma } INTERPRETED BY { interp_glob } GLOBALIZED BY { glob_glob } SUBSTITUTED BY { subst_glob } - RAW_PRINTED BY { pr_gen } - GLOB_PRINTED BY { pr_gen } + RAW_PRINTED BY { pr_gen env sigma } + GLOB_PRINTED BY { pr_gen env sigma } | [ lconstr(c) ] -> { c } END @@ -207,7 +206,7 @@ let interp_casted_constr ist gl c = ARGUMENT EXTEND casted_constr TYPED AS constr - PRINTED BY { pr_gen } + PRINTED BY { pr_gen env sigma } INTERPRETED BY { interp_casted_constr } | [ constr(c) ] -> { c } END @@ -296,23 +295,23 @@ END { -let pr_by_arg_tac _prc _prlc prtac opt_c = +let pr_by_arg_tac env sigma _prc _prlc prtac opt_c = match opt_c with | None -> mt () - | Some t -> hov 2 (str "by" ++ spc () ++ prtac (3,Notation_gram.E) t) + | Some t -> hov 2 (str "by" ++ spc () ++ prtac env sigma (3,Notation_gram.E) t) } ARGUMENT EXTEND by_arg_tac TYPED AS tactic option - PRINTED BY { pr_by_arg_tac } + PRINTED BY { pr_by_arg_tac env sigma } | [ "by" tactic3(c) ] -> { Some c } | [ ] -> { None } END { -let pr_by_arg_tac prtac opt_c = pr_by_arg_tac () () prtac opt_c +let pr_by_arg_tac env sigma prtac opt_c = pr_by_arg_tac env sigma () () prtac opt_c let pr_in_clause _ _ _ cl = Pptactic.pr_in_clause Pputils.pr_lident cl let pr_in_top_clause _ _ _ cl = Pptactic.pr_in_clause Id.print cl diff --git a/plugins/ltac/extraargs.mli b/plugins/ltac/extraargs.mli index 0509d6ae71..7f9eecbef5 100644 --- a/plugins/ltac/extraargs.mli +++ b/plugins/ltac/extraargs.mli @@ -65,8 +65,9 @@ val wit_by_arg_tac : glob_tactic_expr option, Geninterp.Val.t option) Genarg.genarg_type -val pr_by_arg_tac : - (int * Notation_gram.parenRelation -> raw_tactic_expr -> Pp.t) -> +val pr_by_arg_tac : + Environ.env -> Evd.evar_map -> + (Environ.env -> Evd.evar_map -> int * Notation_gram.parenRelation -> raw_tactic_expr -> Pp.t) -> raw_tactic_expr option -> Pp.t val test_lpar_id_colon : unit Pcoq.Entry.t diff --git a/plugins/ltac/extratactics.mlg b/plugins/ltac/extratactics.mlg index 0428f08138..f5098d2a34 100644 --- a/plugins/ltac/extratactics.mlg +++ b/plugins/ltac/extratactics.mlg @@ -53,6 +53,7 @@ let with_delayed_uconstr ist c tac = fail_evar = false; expand_evars = true; program_mode = false; + polymorphic = false; } in let c = Tacinterp.type_uconstr ~flags ist c in Tacticals.New.tclDELAYEDWITHHOLES false c tac @@ -348,6 +349,7 @@ let constr_flags () = { Pretyping.fail_evar = false; Pretyping.expand_evars = true; Pretyping.program_mode = false; + Pretyping.polymorphic = false; } let refine_tac ist simple with_classes c = @@ -813,9 +815,9 @@ END TACTIC EXTEND transparent_abstract | [ "transparent_abstract" tactic3(t) ] -> { Proofview.Goal.enter begin fun gl -> - Abstract.tclABSTRACT ~opaque:false None (Tacinterp.tactic_of_value ist t) end } + Abstract.tclABSTRACT ~opaque:false None (Tacinterp.tactic_of_value ist t) end; } | [ "transparent_abstract" tactic3(t) "using" ident(id) ] -> { Proofview.Goal.enter begin fun gl -> - Abstract.tclABSTRACT ~opaque:false (Some id) (Tacinterp.tactic_of_value ist t) end } + Abstract.tclABSTRACT ~opaque:false (Some id) (Tacinterp.tactic_of_value ist t) end; } END (* ********************************************************************* *) @@ -913,9 +915,9 @@ END the semantics of the LCF-style tactics, hence with the classic tactic mode. *) VERNAC COMMAND EXTEND GrabEvars -| [ "Grab" "Existential" "Variables" ] +| ![ proof ] [ "Grab" "Existential" "Variables" ] => { classify_as_proofstep } - -> { Proof_global.simple_with_current_proof (fun _ p -> Proof.V82.grab_evars p) } + -> { fun ~pstate -> Option.map (Proof_global.simple_with_current_proof (fun _ p -> Proof.V82.grab_evars p)) pstate } END (* Shelves all the goals under focus. *) @@ -945,9 +947,9 @@ END (* Command to add every unshelved variables to the focus *) VERNAC COMMAND EXTEND Unshelve -| [ "Unshelve" ] +| ![ proof ] [ "Unshelve" ] => { classify_as_proofstep } - -> { Proof_global.simple_with_current_proof (fun _ p -> Proof.unshelve p) } + -> { fun ~pstate -> Option.map (Proof_global.simple_with_current_proof (fun _ p -> Proof.unshelve p)) pstate } END (* Gives up on the goals under focus: the goals are considered solved, @@ -1098,8 +1100,8 @@ END VERNAC COMMAND EXTEND OptimizeProof -| [ "Optimize" "Proof" ] => { classify_as_proofstep } -> - { Proof_global.compact_the_proof () } +| ![ proof ] [ "Optimize" "Proof" ] => { classify_as_proofstep } -> + { fun ~pstate -> Option.map Proof_global.compact_the_proof pstate } | [ "Optimize" "Heap" ] => { classify_as_proofstep } -> { Gc.compact () } END diff --git a/plugins/ltac/g_auto.mlg b/plugins/ltac/g_auto.mlg index 663537f3e8..523c7c8305 100644 --- a/plugins/ltac/g_auto.mlg +++ b/plugins/ltac/g_auto.mlg @@ -58,25 +58,24 @@ let eval_uconstrs ist cs = fail_evar = false; expand_evars = true; program_mode = false; + polymorphic = false; } in let map c env sigma = c env sigma in List.map (fun c -> map (Tacinterp.type_uconstr ~flags ist c)) cs -let pr_auto_using_raw _ _ _ = Pptactic.pr_auto_using Ppconstr.pr_constr_expr -let pr_auto_using_glob _ _ _ = Pptactic.pr_auto_using (fun (c,_) -> - let _, env = Pfedit.get_current_context () in +let pr_auto_using_raw env sigma _ _ _ = Pptactic.pr_auto_using @@ Ppconstr.pr_constr_expr env sigma +let pr_auto_using_glob env sigma _ _ _ = Pptactic.pr_auto_using (fun (c,_) -> Printer.pr_glob_constr_env env c) -let pr_auto_using _ _ _ = Pptactic.pr_auto_using - (let sigma, env = Pfedit.get_current_context () in - Printer.pr_closed_glob_env env sigma) +let pr_auto_using env sigma _ _ _ = Pptactic.pr_auto_using @@ + Printer.pr_closed_glob_env env sigma } ARGUMENT EXTEND auto_using TYPED AS uconstr list - PRINTED BY { pr_auto_using } - RAW_PRINTED BY { pr_auto_using_raw } - GLOB_PRINTED BY { pr_auto_using_glob } + PRINTED BY { pr_auto_using env sigma } + RAW_PRINTED BY { pr_auto_using_raw env sigma } + GLOB_PRINTED BY { pr_auto_using_glob env sigma } | [ "using" ne_uconstr_list_sep(l, ",") ] -> { l } | [ ] -> { [] } END diff --git a/plugins/ltac/g_ltac.mlg b/plugins/ltac/g_ltac.mlg index 4c24f51b1e..7eb34158e8 100644 --- a/plugins/ltac/g_ltac.mlg +++ b/plugins/ltac/g_ltac.mlg @@ -374,20 +374,21 @@ let () = declare_int_option { optwrite = fun n -> print_info_trace := n; } -let vernac_solve n info tcom b = +let vernac_solve ~pstate n info tcom b = let open Goal_select in - let status = Proof_global.with_current_proof (fun etac p -> - let with_end_tac = if b then Some etac else None in - let global = match n with SelectAll | SelectList _ -> true | _ -> false in - let info = Option.append info !print_info_trace in - let (p,status) = - Pfedit.solve n info (Tacinterp.hide_interp global tcom None) ?with_end_tac p - in - (* in case a strict subtree was completed, - go back to the top of the prooftree *) - let p = Proof.maximal_unfocus Vernacentries.command_focus p in - p,status) in - if not status then Feedback.feedback Feedback.AddedAxiom + let pstate, status = Proof_global.with_current_proof (fun etac p -> + let with_end_tac = if b then Some etac else None in + let global = match n with SelectAll | SelectList _ -> true | _ -> false in + let info = Option.append info !print_info_trace in + let (p,status) = + Pfedit.solve n info (Tacinterp.hide_interp global tcom None) ?with_end_tac p + in + (* in case a strict subtree was completed, + go back to the top of the prooftree *) + let p = Proof.maximal_unfocus Vernacentries.command_focus p in + p,status) pstate in + if not status then Feedback.feedback Feedback.AddedAxiom; + Some pstate let pr_ltac_selector s = Pptactic.pr_goal_selector ~toplevel:true s @@ -434,12 +435,12 @@ let is_explicit_terminator = function TacSolve _ -> true | _ -> false } VERNAC { tactic_mode } EXTEND VernacSolve -| [ ltac_selector_opt(g) ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => +| ![ proof ] [ ltac_selector_opt(g) ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => { classify_as_proofstep } -> { let g = Option.default (Goal_select.get_default_goal_selector ()) g in - vernac_solve g n t def + Vernacentries.vernac_require_open_proof vernac_solve g n t def } -| [ "par" ":" ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => +| ![ proof ] [ "par" ":" ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => { let anon_abstracting_tac = is_anonymous_abstract t in let solving_tac = is_explicit_terminator t in @@ -449,7 +450,7 @@ VERNAC { tactic_mode } EXTEND VernacSolve VtLater } -> { let t = rm_abstract t in - vernac_solve Goal_select.SelectAll n t def + Vernacentries.vernac_require_open_proof vernac_solve Goal_select.SelectAll n t def } END @@ -514,7 +515,7 @@ END let pr_ltac_ref = Libnames.pr_qualid -let pr_tacdef_body tacdef_body = +let pr_tacdef_body env sigma tacdef_body = let id, redef, body = match tacdef_body with | TacticDefinition ({CAst.v=id}, body) -> Id.print id, false, body @@ -528,12 +529,12 @@ let pr_tacdef_body tacdef_body = prlist (function Name.Anonymous -> str " _" | Name.Name id -> spc () ++ Id.print id) idl ++ (if redef then str" ::=" else str" :=") ++ brk(1,1) - ++ Pptactic.pr_raw_tactic body + ++ Pptactic.pr_raw_tactic env sigma body } VERNAC ARGUMENT EXTEND ltac_tacdef_body -PRINTED BY { pr_tacdef_body } +PRINTED BY { pr_tacdef_body env sigma } | [ tacdef_body(t) ] -> { t } END diff --git a/plugins/ltac/g_obligations.mlg b/plugins/ltac/g_obligations.mlg index cdee012a82..de3a9c9fa9 100644 --- a/plugins/ltac/g_obligations.mlg +++ b/plugins/ltac/g_obligations.mlg @@ -80,25 +80,25 @@ GRAMMAR EXTEND 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 obligation ~pstate obl tac = Some (with_tac (fun t -> Obligations.obligation ~ontop:pstate obl t) tac) +let next_obligation ~pstate obl tac = Some (with_tac (fun t -> Obligations.next_obligation ~ontop:pstate obl t) tac) let classify_obbl _ = Vernacextend.(VtStartProof (Doesn'tGuaranteeOpacity,[]), VtLater) } VERNAC COMMAND EXTEND Obligations CLASSIFIED BY { classify_obbl } -| [ "Obligation" integer(num) "of" ident(name) ":" lglob(t) withtac(tac) ] -> +| ![ proof ] [ "Obligation" integer(num) "of" ident(name) ":" lglob(t) withtac(tac) ] -> { obligation (num, Some name, Some t) tac } -| [ "Obligation" integer(num) "of" ident(name) withtac(tac) ] -> +| ![ proof ] [ "Obligation" integer(num) "of" ident(name) withtac(tac) ] -> { obligation (num, Some name, None) tac } -| [ "Obligation" integer(num) ":" lglob(t) withtac(tac) ] -> +| ![ proof ] [ "Obligation" integer(num) ":" lglob(t) withtac(tac) ] -> { obligation (num, None, Some t) tac } -| [ "Obligation" integer(num) withtac(tac) ] -> +| ![ proof ] [ "Obligation" integer(num) withtac(tac) ] -> { obligation (num, None, None) tac } -| [ "Next" "Obligation" "of" ident(name) withtac(tac) ] -> +| ![ proof ] [ "Next" "Obligation" "of" ident(name) withtac(tac) ] -> { next_obligation (Some name) tac } -| [ "Next" "Obligation" withtac(tac) ] -> { next_obligation None tac } +| ![ proof ] [ "Next" "Obligation" withtac(tac) ] -> { next_obligation None tac } END VERNAC COMMAND EXTEND Solve_Obligation CLASSIFIED AS SIDEFF @@ -162,9 +162,9 @@ END (* Declare a printer for the content of Program tactics *) let () = - let printer _ _ _ = function + let printer env sigma _ _ _ = function | None -> mt () - | Some tac -> str "with" ++ spc () ++ Pptactic.pr_raw_tactic tac + | Some tac -> str "with" ++ spc () ++ Pptactic.pr_raw_tactic env sigma tac in Pptactic.declare_extra_vernac_genarg_pprule wit_withtac printer diff --git a/plugins/ltac/g_rewrite.mlg b/plugins/ltac/g_rewrite.mlg index db8d1b20d8..469551809c 100644 --- a/plugins/ltac/g_rewrite.mlg +++ b/plugins/ltac/g_rewrite.mlg @@ -41,13 +41,11 @@ type constr_expr_with_bindings = constr_expr with_bindings type glob_constr_with_bindings = glob_constr_and_expr with_bindings type glob_constr_with_bindings_sign = interp_sign * glob_constr_and_expr with_bindings -let pr_glob_constr_with_bindings_sign _ _ _ (ge : glob_constr_with_bindings_sign) = - let _, env = Pfedit.get_current_context () in +let pr_glob_constr_with_bindings_sign env sigma _ _ _ (ge : glob_constr_with_bindings_sign) = Printer.pr_glob_constr_env env (fst (fst (snd ge))) -let pr_glob_constr_with_bindings _ _ _ (ge : glob_constr_with_bindings) = - let _, env = Pfedit.get_current_context () in +let pr_glob_constr_with_bindings env sigma _ _ _ (ge : glob_constr_with_bindings) = Printer.pr_glob_constr_env env (fst (fst ge)) -let pr_constr_expr_with_bindings prc _ _ (ge : constr_expr_with_bindings) = prc (fst ge) +let pr_constr_expr_with_bindings env sigma prc _ _ (ge : constr_expr_with_bindings) = prc env sigma (fst ge) let interp_glob_constr_with_bindings ist gl c = Tacmach.project gl , (ist, c) let glob_glob_constr_with_bindings ist l = Tacintern.intern_constr_with_bindings ist l let subst_glob_constr_with_bindings s c = @@ -56,14 +54,14 @@ let subst_glob_constr_with_bindings s c = } ARGUMENT EXTEND glob_constr_with_bindings - PRINTED BY { pr_glob_constr_with_bindings_sign } + PRINTED BY { pr_glob_constr_with_bindings_sign env sigma } INTERPRETED BY { interp_glob_constr_with_bindings } GLOBALIZED BY { glob_glob_constr_with_bindings } SUBSTITUTED BY { subst_glob_constr_with_bindings } - RAW_PRINTED BY { pr_constr_expr_with_bindings } - GLOB_PRINTED BY { pr_glob_constr_with_bindings } + RAW_PRINTED BY { pr_constr_expr_with_bindings env sigma } + GLOB_PRINTED BY { pr_glob_constr_with_bindings env sigma } | [ constr_with_bindings(bl) ] -> { bl } END @@ -80,17 +78,17 @@ let glob_strategy ist s = map_strategy (Tacintern.intern_constr ist) (fun c -> c 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, Pputils.pr_or_by_notation Libnames.pr_qualid, prc) in - Rewrite.pr_strategy prc prr s -let pr_glob_strategy prc prlc _ (s : glob_strategy) = - let prr = Pptactic.pr_red_expr +let pr_raw_strategy env sigma prc prlc _ (s : raw_strategy) = + let prr = Pptactic.pr_red_expr env sigma (prc, prlc, Pputils.pr_or_by_notation Libnames.pr_qualid, prc) in + Rewrite.pr_strategy (prc env sigma) prr s +let pr_glob_strategy env sigma prc prlc _ (s : glob_strategy) = + let prr = Pptactic.pr_red_expr env sigma (Ppconstr.pr_constr_expr, Ppconstr.pr_lconstr_expr, Pputils.pr_or_by_notation Libnames.pr_qualid, Ppconstr.pr_constr_expr) in - Rewrite.pr_strategy prc prr s + Rewrite.pr_strategy (prc env sigma) prr s } @@ -101,8 +99,8 @@ ARGUMENT EXTEND rewstrategy GLOBALIZED BY { glob_strategy } SUBSTITUTED BY { subst_strategy } - RAW_PRINTED BY { pr_raw_strategy } - GLOB_PRINTED BY { pr_glob_strategy } + RAW_PRINTED BY { pr_raw_strategy env sigma } + GLOB_PRINTED BY { pr_glob_strategy env sigma } | [ glob(c) ] -> { StratConstr (c, true) } | [ "<-" constr(c) ] -> { StratConstr (c, false) } @@ -182,34 +180,34 @@ TACTIC EXTEND setoid_rewrite END VERNAC COMMAND EXTEND AddRelation CLASSIFIED AS SIDEFF - | #[ atts = rewrite_attributes; ] [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] -> { declare_relation atts a aeq n (Some lemma1) (Some lemma2) None } - | #[ atts = rewrite_attributes; ] [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "as" ident(n) ] -> { declare_relation atts a aeq n (Some lemma1) None None } - | #[ atts = rewrite_attributes; ] [ "Add" "Relation" constr(a) constr(aeq) "as" ident(n) ] -> + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Relation" constr(a) constr(aeq) "as" ident(n) ] -> { declare_relation atts a aeq n None None None } END VERNAC COMMAND EXTEND AddRelation2 CLASSIFIED AS SIDEFF - | #[ atts = rewrite_attributes; ] [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] -> { declare_relation atts a aeq n None (Some lemma2) None } - | #[ atts = rewrite_attributes; ] [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> { declare_relation atts a aeq n None (Some lemma2) (Some lemma3) } END VERNAC COMMAND EXTEND AddRelation3 CLASSIFIED AS SIDEFF - | #[ atts = rewrite_attributes; ] [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> { declare_relation atts a aeq n (Some lemma1) None (Some lemma3) } - | #[ atts = rewrite_attributes; ] [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> { declare_relation atts a aeq n (Some lemma1) (Some lemma2) (Some lemma3) } - | #[ atts = rewrite_attributes; ] [ "Add" "Relation" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3) + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Relation" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> { declare_relation atts a aeq n None None (Some lemma3) } END @@ -224,7 +222,7 @@ let wit_binders = let binders = Pcoq.create_generic_entry Pcoq.utactic "binders" (Genarg.rawwit wit_binders) let () = - let raw_printer _ _ _ l = Pp.pr_non_empty_arg Ppconstr.pr_binders l in + let raw_printer env sigma _ _ _ l = Pp.pr_non_empty_arg (Ppconstr.pr_binders env sigma) l in Pptactic.declare_extra_vernac_genarg_pprule wit_binders raw_printer } @@ -236,64 +234,64 @@ GRAMMAR EXTEND Gram END VERNAC COMMAND EXTEND AddParametricRelation CLASSIFIED AS SIDEFF - | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] -> { declare_relation atts ~binders:b a aeq n (Some lemma1) (Some lemma2) None } - | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "as" ident(n) ] -> { declare_relation atts ~binders:b a aeq n (Some lemma1) None None } - | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "as" ident(n) ] -> + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "as" ident(n) ] -> { declare_relation atts ~binders:b a aeq n None None None } END VERNAC COMMAND EXTEND AddParametricRelation2 CLASSIFIED AS SIDEFF - | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] -> { declare_relation atts ~binders:b a aeq n None (Some lemma2) None } - | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> { declare_relation atts ~binders:b a aeq n None (Some lemma2) (Some lemma3) } END VERNAC COMMAND EXTEND AddParametricRelation3 CLASSIFIED AS SIDEFF - | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> { declare_relation atts ~binders:b a aeq n (Some lemma1) None (Some lemma3) } - | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> { declare_relation atts ~binders:b a aeq n (Some lemma1) (Some lemma2) (Some lemma3) } - | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3) + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> { declare_relation atts ~binders:b a aeq n None None (Some lemma3) } END VERNAC COMMAND EXTEND AddSetoid1 CLASSIFIED AS SIDEFF - | #[ atts = rewrite_attributes; ] [ "Add" "Setoid" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Setoid" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> { - add_setoid atts [] a aeq t n; + add_setoid atts [] a aeq t n } - | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Setoid" binders(binders) ":" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Parametric" "Setoid" binders(binders) ":" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> { - add_setoid atts binders a aeq t n; + add_setoid atts binders a aeq t n } - | #[ atts = rewrite_attributes; ] [ "Add" "Morphism" constr(m) ":" ident(n) ] + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Morphism" constr(m) ":" ident(n) ] (* This command may or may not open a goal *) => { VtUnknown, VtNow } -> { - add_morphism_infer atts m n; + add_morphism_infer atts m n } - | #[ atts = rewrite_attributes; ] [ "Add" "Morphism" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Morphism" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] => { VtStartProof(GuaranteesOpacity,[n]), VtLater } -> { - add_morphism atts [] m s n; + add_morphism atts [] m s n } - | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Morphism" binders(binders) ":" constr(m) + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Parametric" "Morphism" binders(binders) ":" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] => { VtStartProof(GuaranteesOpacity,[n]), VtLater } -> { - add_morphism atts binders m s n; + add_morphism atts binders m s n } END @@ -312,7 +310,12 @@ TACTIC EXTEND setoid_transitivity END VERNAC COMMAND EXTEND PrintRewriteHintDb CLASSIFIED AS QUERY -| [ "Print" "Rewrite" "HintDb" preident(s) ] -> - { let sigma, env = Pfedit.get_current_context () in - Feedback.msg_notice (Autorewrite.print_rewrite_hintdb env sigma s) } +| ![ proof ] [ "Print" "Rewrite" "HintDb" preident(s) ] -> + { (* This command should not use the proof env, keeping previous + behavior as requested in review. *) + fun ~pstate -> + let sigma, env = Option.cata Pfedit.get_current_context + (let e = Global.env () in Evd.from_env e, e) pstate in + Feedback.msg_notice (Autorewrite.print_rewrite_hintdb env sigma s); + pstate } END diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index e188971f00..80070a7493 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -71,40 +71,46 @@ let declare_notation_tactic_pprule kn pt = prnotation_tab := KNmap.add kn pt !prnotation_tab type 'a raw_extra_genarg_printer = - (constr_expr -> Pp.t) -> - (constr_expr -> Pp.t) -> - (tolerability -> raw_tactic_expr -> Pp.t) -> - 'a -> Pp.t + Environ.env -> Evd.evar_map -> + (Environ.env -> Evd.evar_map -> constr_expr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> constr_expr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> tolerability -> raw_tactic_expr -> Pp.t) -> + 'a -> Pp.t type 'a glob_extra_genarg_printer = - (glob_constr_and_expr -> Pp.t) -> - (glob_constr_and_expr -> Pp.t) -> - (tolerability -> glob_tactic_expr -> Pp.t) -> - 'a -> Pp.t + Environ.env -> Evd.evar_map -> + (Environ.env -> Evd.evar_map -> glob_constr_and_expr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> glob_constr_and_expr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> tolerability -> glob_tactic_expr -> Pp.t) -> + 'a -> Pp.t type 'a extra_genarg_printer = - (EConstr.constr -> Pp.t) -> - (EConstr.constr -> Pp.t) -> - (tolerability -> Val.t -> Pp.t) -> - 'a -> Pp.t + Environ.env -> Evd.evar_map -> + (Environ.env -> Evd.evar_map -> EConstr.constr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> EConstr.constr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> tolerability -> Val.t -> Pp.t) -> + 'a -> Pp.t type 'a raw_extra_genarg_printer_with_level = - (constr_expr -> Pp.t) -> - (constr_expr -> Pp.t) -> - (tolerability -> raw_tactic_expr -> Pp.t) -> - tolerability -> 'a -> Pp.t + Environ.env -> Evd.evar_map -> + (Environ.env -> Evd.evar_map -> constr_expr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> constr_expr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> tolerability -> raw_tactic_expr -> Pp.t) -> + tolerability -> 'a -> Pp.t type 'a glob_extra_genarg_printer_with_level = - (glob_constr_and_expr -> Pp.t) -> - (glob_constr_and_expr -> Pp.t) -> - (tolerability -> glob_tactic_expr -> Pp.t) -> - tolerability -> 'a -> Pp.t + Environ.env -> Evd.evar_map -> + (Environ.env -> Evd.evar_map -> glob_constr_and_expr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> glob_constr_and_expr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> tolerability -> glob_tactic_expr -> Pp.t) -> + tolerability -> 'a -> Pp.t type 'a extra_genarg_printer_with_level = - (EConstr.constr -> Pp.t) -> - (EConstr.constr -> Pp.t) -> - (tolerability -> Val.t -> Pp.t) -> - tolerability -> 'a -> Pp.t + Environ.env -> Evd.evar_map -> + (Environ.env -> Evd.evar_map -> EConstr.constr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> EConstr.constr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> tolerability -> Val.t -> Pp.t) -> + tolerability -> 'a -> Pp.t let string_of_genarg_arg (ArgumentType arg) = let rec aux : type a b c. (a, b, c) genarg_type -> string = function @@ -160,27 +166,27 @@ let string_of_genarg_arg (ArgumentType arg) = | _ -> default let pr_with_occurrences pr c = Ppred.pr_with_occurrences pr keyword c - let pr_red_expr pr c = Ppred.pr_red_expr pr keyword c + let pr_red_expr env sigma pr c = Ppred.pr_red_expr_env env sigma pr keyword c - let pr_may_eval test prc prlc pr2 pr3 = function + let pr_may_eval env sigma test prc prlc pr2 pr3 = function | ConstrEval (r,c) -> hov 0 (keyword "eval" ++ brk (1,1) ++ - pr_red_expr (prc,prlc,pr2,pr3) r ++ spc () ++ - keyword "in" ++ spc() ++ prc c) + pr_red_expr env sigma (prc,prlc,pr2,pr3) r ++ spc () ++ + keyword "in" ++ spc() ++ prc env sigma c) | ConstrContext ({CAst.v=id},c) -> hov 0 (keyword "context" ++ spc () ++ pr_id id ++ spc () ++ - str "[ " ++ prlc c ++ str " ]") + str "[ " ++ prlc env sigma c ++ str " ]") | ConstrTypeOf c -> - hov 1 (keyword "type of" ++ spc() ++ prc c) + hov 1 (keyword "type of" ++ spc() ++ prc env sigma c) | ConstrTerm c when test c -> - h 0 (str "(" ++ prc c ++ str ")") + h 0 (str "(" ++ prc env sigma c ++ str ")") | ConstrTerm c -> - prc c + prc env sigma c - let pr_may_eval a = - pr_may_eval (fun _ -> false) a + let pr_may_eval env sigma a = + pr_may_eval env sigma (fun _ -> false) a let pr_arg pr x = spc () ++ pr x @@ -647,15 +653,15 @@ let pr_goal_selector ~toplevel s = type 'a printer = { pr_tactic : tolerability -> 'tacexpr -> Pp.t; - pr_constr : 'trm -> Pp.t; - pr_lconstr : 'trm -> Pp.t; - pr_dconstr : 'dtrm -> Pp.t; - pr_pattern : 'pat -> Pp.t; - pr_lpattern : 'pat -> Pp.t; + pr_constr : Environ.env -> Evd.evar_map -> 'trm -> Pp.t; + pr_lconstr : Environ.env -> Evd.evar_map -> 'trm -> Pp.t; + pr_dconstr : Environ.env -> Evd.evar_map -> 'dtrm -> Pp.t; + pr_pattern : Environ.env -> Evd.evar_map -> 'pat -> Pp.t; + pr_lpattern : Environ.env -> Evd.evar_map -> 'pat -> Pp.t; pr_constant : 'cst -> Pp.t; pr_reference : 'ref -> Pp.t; pr_name : 'nam -> Pp.t; - pr_generic : 'lev generic_argument -> Pp.t; + pr_generic : Environ.env -> Evd.evar_map -> 'lev generic_argument -> Pp.t; pr_extend : int -> ml_tactic_entry -> 'a gen_tactic_arg list -> Pp.t; pr_alias : int -> KerName.t -> 'a gen_tactic_arg list -> Pp.t; } @@ -671,14 +677,14 @@ let pr_goal_selector ~toplevel s = level :'lev > - let pr_atom pr strip_prod_binders tag_atom = - let pr_with_bindings = pr_with_bindings pr.pr_constr pr.pr_lconstr in + let pr_atom env sigma pr strip_prod_binders tag_atom = + let pr_with_bindings = pr_with_bindings (pr.pr_constr env sigma) (pr.pr_lconstr env sigma) in let pr_with_bindings_arg_full = pr_with_bindings_arg in - let pr_with_bindings_arg = pr_with_bindings_arg pr.pr_constr pr.pr_lconstr in - let pr_red_expr = pr_red_expr (pr.pr_constr,pr.pr_lconstr,pr.pr_constant,pr.pr_pattern) in + let pr_with_bindings_arg = pr_with_bindings_arg (pr.pr_constr env sigma) (pr.pr_lconstr env sigma) in + let pr_red_expr = pr_red_expr env sigma (pr.pr_constr,pr.pr_lconstr,pr.pr_constant,pr.pr_pattern) in - let _pr_constrarg c = spc () ++ pr.pr_constr c in - let pr_lconstrarg c = spc () ++ pr.pr_lconstr c in + let _pr_constrarg c = spc () ++ pr.pr_constr env sigma c in + let pr_lconstrarg c = spc () ++ pr.pr_lconstr env sigma c in let pr_intarg n = spc () ++ int n in (* Some printing combinators *) @@ -688,7 +694,7 @@ let pr_goal_selector ~toplevel s = (* match t with | CHole _ -> spc() ++ prlist_with_sep spc (pr_lname) nal | _ ->*) - let s = prlist_with_sep spc pr_lname nal ++ str ":" ++ pr.pr_lconstr t in + let s = prlist_with_sep spc pr_lname nal ++ str ":" ++ pr.pr_lconstr env sigma t in spc() ++ hov 1 (str"(" ++ s ++ str")") in let pr_fix_tac (id,n,c) = @@ -723,7 +729,7 @@ let pr_goal_selector ~toplevel s = in hov 1 (str"(" ++ pr_id id ++ prlist pr_binder_fix bll ++ annot ++ str" :" ++ - pr_lconstrarg ty ++ str")") in + (pr_lconstrarg ty) ++ str")") in (* spc() ++ hov 0 (pr_id id ++ pr_intarg n ++ str":" ++ _pr_constrarg c) @@ -747,13 +753,13 @@ let pr_goal_selector ~toplevel s = hov 1 (primitive (if ev then "eintros" else "intros") ++ (match p with | [{CAst.v=IntroForthcoming false}] -> mt () - | _ -> spc () ++ prlist_with_sep spc (Miscprint.pr_intro_pattern pr.pr_dconstr) p)) + | _ -> spc () ++ prlist_with_sep spc (Miscprint.pr_intro_pattern @@ pr.pr_dconstr env sigma) p)) | TacApply (a,ev,cb,inhyp) -> hov 1 ( (if a then mt() else primitive "simple ") ++ primitive (with_evars ev "apply") ++ spc () ++ prlist_with_sep pr_comma pr_with_bindings_arg cb ++ - pr_non_empty_arg (pr_in_hyp_as pr.pr_dconstr pr.pr_name) inhyp + pr_non_empty_arg (pr_in_hyp_as (pr.pr_dconstr env sigma) pr.pr_name) inhyp ) | TacElim (ev,cb,cbo) -> hov 1 ( @@ -774,28 +780,28 @@ let pr_goal_selector ~toplevel s = | TacAssert (ev,b,Some tac,ipat,c) -> hov 1 ( primitive (if b then if ev then "eassert" else "assert" else if ev then "eenough" else "enough") ++ - pr_assumption pr.pr_constr pr.pr_dconstr pr.pr_lconstr ipat c ++ + pr_assumption (pr.pr_constr env sigma) (pr.pr_dconstr env sigma) (pr.pr_lconstr env sigma) ipat c ++ pr_non_empty_arg (pr_by_tactic (pr.pr_tactic (ltactical,E))) tac ) | TacAssert (ev,_,None,ipat,c) -> hov 1 ( primitive (if ev then "epose proof" else "pose proof") - ++ pr_assertion pr.pr_constr pr.pr_dconstr pr.pr_lconstr ipat c + ++ pr_assertion (pr.pr_constr env sigma) (pr.pr_dconstr env sigma) (pr.pr_lconstr env sigma) ipat c ) | TacGeneralize l -> hov 1 ( primitive "generalize" ++ spc () ++ prlist_with_sep pr_comma (fun (cl,na) -> - pr_with_occurrences pr.pr_constr cl ++ pr_as_name na) + pr_with_occurrences (pr.pr_constr env sigma) cl ++ pr_as_name na) l ) | TacLetTac (ev,na,c,cl,true,_) when Locusops.is_nowhere cl -> - hov 1 (primitive (if ev then "epose" else "pose") ++ pr_pose pr.pr_constr pr.pr_lconstr na c) + hov 1 (primitive (if ev then "epose" else "pose") ++ pr_pose (pr.pr_constr env sigma) (pr.pr_lconstr env sigma) na c) | TacLetTac (ev,na,c,cl,b,e) -> hov 1 ( primitive (if b then if ev then "eset" else "set" else if ev then "eremember" else "remember") ++ - (if b then pr_pose pr.pr_constr pr.pr_lconstr na c - else pr_pose_as_style pr.pr_constr na c) ++ + (if b then pr_pose (pr.pr_constr env sigma) (pr.pr_lconstr env sigma) na c + else pr_pose_as_style (pr.pr_constr env sigma) na c) ++ pr_opt (fun p -> pr_eqn_ipat p ++ spc ()) e ++ pr_non_empty_arg (pr_clauses (Some b) pr.pr_name) cl) (* | TacInstantiate (n,c,ConclLocation ()) -> @@ -815,8 +821,8 @@ let pr_goal_selector ~toplevel s = primitive (with_evars ev (if isrec then "induction" else "destruct")) ++ spc () ++ prlist_with_sep pr_comma (fun (h,ids,cl) -> - pr_destruction_arg pr.pr_dconstr pr.pr_dconstr h ++ - pr_non_empty_arg (pr_with_induction_names pr.pr_dconstr) ids ++ + pr_destruction_arg (pr.pr_dconstr env sigma) (pr.pr_dconstr env sigma) h ++ + pr_non_empty_arg (pr_with_induction_names (pr.pr_dconstr env sigma)) ids ++ pr_opt (pr_clauses None pr.pr_name) cl) l ++ pr_opt pr_eliminator el ) @@ -835,9 +841,9 @@ let pr_goal_selector ~toplevel s = None -> mt () | Some p -> - pr.pr_pattern p ++ spc () + pr.pr_pattern env sigma p ++ spc () ++ keyword "with" ++ spc () - ) ++ pr.pr_dconstr c ++ pr_non_empty_arg (pr_clauses (Some true) pr.pr_name) h + ) ++ pr.pr_dconstr env sigma c ++ pr_non_empty_arg (pr_clauses (Some true) pr.pr_name) h ) (* Equality and inversion *) @@ -848,7 +854,7 @@ let pr_goal_selector ~toplevel s = (fun () -> str ","++spc()) (fun (b,m,c) -> pr_orient b ++ pr_multi m ++ - pr_with_bindings_arg_full pr.pr_dconstr pr.pr_dconstr c) + pr_with_bindings_arg_full (pr.pr_dconstr env sigma) (pr.pr_dconstr env sigma) c) l ++ pr_non_empty_arg (pr_clauses (Some true) pr.pr_name) cl ++ pr_non_empty_arg (pr_by_tactic (pr.pr_tactic (ltactical,E))) tac @@ -857,28 +863,28 @@ let pr_goal_selector ~toplevel s = hov 1 ( primitive "dependent " ++ pr_inversion_kind k ++ spc () ++ pr_quantified_hypothesis hyp - ++ pr_with_inversion_names pr.pr_dconstr ids - ++ pr_with_constr pr.pr_constr c + ++ pr_with_inversion_names (pr.pr_dconstr env sigma) ids + ++ pr_with_constr (pr.pr_constr env sigma) c ) | TacInversion (NonDepInversion (k,cl,ids),hyp) -> hov 1 ( pr_inversion_kind k ++ spc () ++ pr_quantified_hypothesis hyp - ++ pr_non_empty_arg (pr_with_inversion_names pr.pr_dconstr) ids + ++ pr_non_empty_arg (pr_with_inversion_names @@ pr.pr_dconstr env sigma) ids ++ pr_non_empty_arg (pr_simple_hyp_clause pr.pr_name) cl ) | TacInversion (InversionUsing (c,cl),hyp) -> hov 1 ( primitive "inversion" ++ spc() ++ pr_quantified_hypothesis hyp ++ spc () - ++ keyword "using" ++ spc () ++ pr.pr_constr c + ++ keyword "using" ++ spc () ++ pr.pr_constr env sigma c ++ pr_non_empty_arg (pr_simple_hyp_clause pr.pr_name) cl ) ) in pr_atom1 - let make_pr_tac pr strip_prod_binders tag_atom tag = + let make_pr_tac env sigma pr strip_prod_binders tag_atom tag = let extract_binders = function | Tacexp (TacFun (lvar,body)) -> (lvar,Tacexp body) @@ -898,7 +904,7 @@ let pr_goal_selector ~toplevel s = let llc = List.map (fun (id,t) -> (id,extract_binders t)) llc in v 0 (hv 0 ( - pr_let_clauses recflag pr.pr_generic (pr_tac ltop) llc + pr_let_clauses recflag (pr.pr_generic env sigma) (pr_tac ltop) llc ++ spc () ++ keyword "in" ) ++ fnl () ++ pr_tac (llet,E) u), llet @@ -908,7 +914,7 @@ let pr_goal_selector ~toplevel s = ++ pr_tac ltop t ++ spc () ++ keyword "with" ++ prlist (fun r -> fnl () ++ str "| " - ++ pr_match_rule true (pr_tac ltop) pr.pr_lpattern r + ++ pr_match_rule true (pr_tac ltop) (pr.pr_lpattern env sigma) r ) lrul ++ fnl() ++ keyword "end"), lmatch @@ -918,7 +924,7 @@ let pr_goal_selector ~toplevel s = ++ keyword (if lr then "match reverse goal with" else "match goal with") ++ prlist (fun r -> fnl () ++ str "| " - ++ pr_match_rule false (pr_tac ltop) pr.pr_lpattern r + ++ pr_match_rule false (pr_tac ltop) (pr.pr_lpattern env sigma) r ) lrul ++ fnl() ++ keyword "end"), lmatch | TacFun (lvar,body) -> @@ -1041,17 +1047,17 @@ let pr_goal_selector ~toplevel s = | TacId l -> keyword "idtac" ++ prlist (pr_arg (pr_message_token pr.pr_name)) l, latom | TacAtom { CAst.loc; v=t } -> - pr_with_comments ?loc (hov 1 (pr_atom pr strip_prod_binders tag_atom t)), ltatom + pr_with_comments ?loc (hov 1 (pr_atom env sigma pr strip_prod_binders tag_atom t)), ltatom | TacArg { CAst.v=Tacexp e } -> pr_tac inherited e, latom | TacArg { CAst.v=ConstrMayEval (ConstrTerm c) } -> - keyword "constr:" ++ pr.pr_constr c, latom + keyword "constr:" ++ pr.pr_constr env sigma c, latom | TacArg { CAst.v=ConstrMayEval c } -> - pr_may_eval pr.pr_constr pr.pr_lconstr pr.pr_constant pr.pr_pattern c, leval + pr_may_eval env sigma pr.pr_constr pr.pr_lconstr pr.pr_constant pr.pr_pattern c, leval | TacArg { CAst.v=TacFreshId l } -> primitive "fresh" ++ pr_fresh_ids l, latom | TacArg { CAst.v=TacGeneric arg } -> - pr.pr_generic arg, latom + pr.pr_generic env sigma arg, latom | TacArg { CAst.v=TacCall {CAst.v=(f,[])} } -> pr.pr_reference f, latom | TacArg { CAst.v=TacCall {CAst.loc; v=(f,l)} } -> @@ -1074,11 +1080,11 @@ let pr_goal_selector ~toplevel s = | Reference r -> pr.pr_reference r | ConstrMayEval c -> - pr_may_eval pr.pr_constr pr.pr_lconstr pr.pr_constant pr.pr_pattern c + pr_may_eval env sigma pr.pr_constr pr.pr_lconstr pr.pr_constant pr.pr_pattern c | TacFreshId l -> keyword "fresh" ++ pr_fresh_ids l | TacPretype c -> - keyword "type_term" ++ pr.pr_constr c + keyword "type_term" ++ pr.pr_constr env sigma c | TacNumgoals -> keyword "numgoals" | (TacCall _|Tacexp _ | TacGeneric _) as a -> @@ -1098,9 +1104,9 @@ let pr_goal_selector ~toplevel s = let raw_printers = (strip_prod_binders_expr) - let rec pr_raw_tactic_level n (t:raw_tactic_expr) = + let rec pr_raw_tactic_level env sigma n (t:raw_tactic_expr) = let pr = { - pr_tactic = pr_raw_tactic_level; + pr_tactic = pr_raw_tactic_level env sigma; pr_constr = pr_constr_expr; pr_dconstr = pr_constr_expr; pr_lconstr = pr_lconstr_expr; @@ -1109,16 +1115,16 @@ let pr_goal_selector ~toplevel s = pr_constant = pr_or_by_notation pr_qualid; pr_reference = pr_qualid; pr_name = pr_lident; - pr_generic = (fun arg -> Pputils.pr_raw_generic (Global.env ()) arg); - pr_extend = pr_raw_extend_rec pr_raw_tactic_level; - pr_alias = pr_raw_alias pr_raw_tactic_level; + pr_generic = Pputils.pr_raw_generic; + pr_extend = pr_raw_extend_rec @@ pr_raw_tactic_level env sigma; + pr_alias = pr_raw_alias @@ pr_raw_tactic_level env sigma; } in - make_pr_tac + make_pr_tac env sigma pr raw_printers tag_raw_atomic_tactic_expr tag_raw_tactic_expr n t - let pr_raw_tactic = pr_raw_tactic_level ltop + let pr_raw_tactic env sigma = pr_raw_tactic_level env sigma ltop let pr_and_constr_expr pr (c,_) = pr c @@ -1131,19 +1137,19 @@ let pr_goal_selector ~toplevel s = let rec prtac n (t:glob_tactic_expr) = let pr = { pr_tactic = prtac; - pr_constr = pr_and_constr_expr (pr_glob_constr_env env); - pr_dconstr = pr_and_constr_expr (pr_glob_constr_env env); - pr_lconstr = pr_and_constr_expr (pr_lglob_constr_env env); - pr_pattern = pr_pat_and_constr_expr (pr_glob_constr_env env); - pr_lpattern = pr_pat_and_constr_expr (pr_lglob_constr_env env); + pr_constr = (fun env sigma -> pr_and_constr_expr (pr_glob_constr_env env)); + pr_dconstr = (fun env sigma -> pr_and_constr_expr (pr_glob_constr_env env)); + pr_lconstr = (fun env sigma -> pr_and_constr_expr (pr_lglob_constr_env env)); + pr_pattern = (fun env sigma -> pr_pat_and_constr_expr (pr_glob_constr_env env)); + pr_lpattern = (fun env sigma -> pr_pat_and_constr_expr (pr_lglob_constr_env env)); 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 = (fun arg -> Pputils.pr_glb_generic (Global.env ()) arg); + pr_generic = Pputils.pr_glb_generic; pr_extend = pr_glob_extend_rec prtac; pr_alias = pr_glob_alias prtac; } in - make_pr_tac + make_pr_tac env (Evd.from_env env) pr glob_printers tag_glob_atomic_tactic_expr tag_glob_tactic_expr n t @@ -1166,11 +1172,11 @@ let pr_goal_selector ~toplevel s = let prtac (t:atomic_tactic_expr) = let pr = { pr_tactic = (fun _ _ -> str "<tactic>"); - pr_constr = (fun c -> pr_econstr_env env sigma c); - pr_dconstr = pr_and_constr_expr (pr_glob_constr_env env); - pr_lconstr = (fun c -> pr_leconstr_env env sigma c); - pr_pattern = pr_constr_pattern_env env sigma; - pr_lpattern = pr_lconstr_pattern_env env sigma; + pr_constr = pr_econstr_env; + pr_dconstr = (fun env sigma -> pr_and_constr_expr (pr_glob_constr_env env)); + pr_lconstr = pr_leconstr_env; + pr_pattern = pr_constr_pattern_env; + pr_lpattern = pr_lconstr_pattern_env; pr_constant = pr_evaluable_reference_env env; pr_reference = pr_located pr_ltac_constant; pr_name = pr_id; @@ -1180,7 +1186,7 @@ let pr_goal_selector ~toplevel s = pr_alias = (fun _ _ _ -> assert false); } in - pr_atom pr strip_prod_binders_constr tag_atomic_tactic_expr t + pr_atom env sigma pr strip_prod_binders_constr tag_atomic_tactic_expr t in prtac t @@ -1188,9 +1194,9 @@ let pr_goal_selector ~toplevel s = let pr_glb_generic = Pputils.pr_glb_generic - let pr_raw_extend _ = pr_raw_extend_rec pr_raw_tactic_level + let pr_raw_extend env sigma = pr_raw_extend_rec @@ pr_raw_tactic_level env sigma - let pr_glob_extend env = pr_glob_extend_rec (pr_glob_tactic_level env) + let pr_glob_extend env sigma = pr_glob_extend_rec (pr_glob_tactic_level env) let pr_alias pr lev key args = pr_alias_gen (fun _ arg -> pr arg) lev key args @@ -1209,16 +1215,17 @@ let declare_extra_genarg_pprule wit | _ -> user_err Pp.(str "Can declare a pretty-printing rule only for extra argument types.") end; let f x = - Genprint.PrinterBasic (fun () -> - f pr_constr_expr pr_lconstr_expr pr_raw_tactic_level x) in + Genprint.PrinterBasic (fun env sigma -> + f env sigma pr_constr_expr pr_lconstr_expr pr_raw_tactic_level x) in let g x = - Genprint.PrinterBasic (fun () -> - 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) + Genprint.PrinterBasic (fun env sigma -> + g env sigma (fun env sigma -> pr_and_constr_expr (pr_glob_constr_env env)) + (fun env sigma -> pr_and_constr_expr (pr_lglob_constr_env env)) + (fun env sigma -> pr_glob_tactic_level env) x) in let h x = Genprint.TopPrinterNeedsContext (fun env sigma -> - h (pr_econstr_env env sigma) (pr_leconstr_env env sigma) (fun _ _ -> str "<tactic>") x) + h env sigma pr_econstr_env pr_leconstr_env (fun _env _sigma _ _ -> str "<tactic>") x) in Genprint.register_print0 wit f g h @@ -1235,27 +1242,28 @@ let declare_extra_genarg_pprule_with_level wit PrinterNeedsLevel { default_already_surrounded = default_surrounded; default_ensure_surrounded = default_non_surrounded; - printer = (fun n -> - f pr_constr_expr pr_lconstr_expr pr_raw_tactic_level n x) } in + printer = (fun env sigma n -> + f env sigma pr_constr_expr pr_lconstr_expr pr_raw_tactic_level n x) } in let g x = - let env = Global.env () in PrinterNeedsLevel { default_already_surrounded = default_surrounded; default_ensure_surrounded = default_non_surrounded; - printer = (fun n -> - g (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env)) (pr_glob_tactic_level env) n x) } + printer = (fun env sigma n -> + g env sigma (fun env sigma -> pr_and_constr_expr (pr_glob_constr_env env)) + (fun env sigma -> pr_and_constr_expr (pr_lglob_constr_env env)) + (fun env sigma -> pr_glob_tactic_level env) n x) } in let h x = TopPrinterNeedsContextAndLevel { default_already_surrounded = default_surrounded; default_ensure_surrounded = default_non_surrounded; printer = (fun env sigma n -> - h (pr_econstr_env env sigma) (pr_leconstr_env env sigma) (fun _ _ -> str "<tactic>") n x) } + h env sigma pr_econstr_env pr_leconstr_env (fun _env _sigma _ _ -> str "<tactic>") n x) } in Genprint.register_print0 wit f g h let declare_extra_vernac_genarg_pprule wit f = - let f x = Genprint.PrinterBasic (fun () -> f pr_constr_expr pr_lconstr_expr pr_raw_tactic_level x) in + let f x = Genprint.PrinterBasic (fun env sigma -> f env sigma pr_constr_expr pr_lconstr_expr pr_raw_tactic_level x) in Genprint.register_vernac_print0 wit f (** Registering *) @@ -1265,8 +1273,8 @@ let pr_intro_pattern_env p = Genprint.TopPrinterNeedsContext (fun env sigma -> Miscprint.pr_intro_pattern print_constr p) let pr_red_expr_env r = Genprint.TopPrinterNeedsContext (fun env sigma -> - pr_red_expr (pr_econstr_env env sigma, pr_leconstr_env env sigma, - pr_evaluable_reference_env env, pr_constr_pattern_env env sigma) r) + pr_red_expr env sigma (pr_econstr_env, pr_leconstr_env, + pr_evaluable_reference_env env, pr_constr_pattern_env) r) let pr_bindings_env bl = Genprint.TopPrinterNeedsContext (fun env sigma -> let sigma, bl = bl env sigma in @@ -1292,19 +1300,17 @@ let make_constr_printer f c = Genprint.default_ensure_surrounded = Ppconstr.lsimpleconstr; Genprint.printer = (fun env sigma n -> f env sigma n c)} -let lift f a = Genprint.PrinterBasic (fun () -> f a) +let lift f a = Genprint.PrinterBasic (fun env sigma -> f a) +let lift_env f a = Genprint.PrinterBasic (fun env sigma -> f env sigma a) let lift_top f a = Genprint.TopPrinterBasic (fun () -> f a) let register_basic_print0 wit f g h = Genprint.register_print0 wit (lift f) (lift g) (lift_top h) - -let pr_glob_constr_pptac c = - let _, env = Pfedit.get_current_context () in +let pr_glob_constr_pptac env sigma c = pr_glob_constr_env env c -let pr_lglob_constr_pptac c = - let _, env = Pfedit.get_current_context () in +let pr_lglob_constr_pptac env sigma c = pr_lglob_constr_env env c let () = @@ -1318,8 +1324,8 @@ let () = register_basic_print0 wit_var pr_lident pr_lident pr_id; register_print0 wit_intro_pattern - (lift (Miscprint.pr_intro_pattern pr_constr_expr)) - (lift (Miscprint.pr_intro_pattern (fun (c,_) -> pr_glob_constr_pptac c))) + (lift_env (fun env sigma -> Miscprint.pr_intro_pattern @@ pr_constr_expr env sigma)) + (lift_env (fun env sigma -> Miscprint.pr_intro_pattern (fun (c,_) -> pr_glob_constr_pptac env sigma c))) pr_intro_pattern_env; Genprint.register_print0 wit_clause_dft_concl @@ -1329,47 +1335,55 @@ let () = ; Genprint.register_print0 wit_constr - (lift Ppconstr.pr_lconstr_expr) - (lift (fun (c, _) -> pr_lglob_constr_pptac c)) + (lift_env Ppconstr.pr_lconstr_expr) + (lift_env (fun env sigma (c, _) -> pr_lglob_constr_pptac env sigma c)) (make_constr_printer Printer.pr_econstr_n_env) ; Genprint.register_print0 wit_uconstr - (lift Ppconstr.pr_constr_expr) - (lift (fun (c,_) -> pr_glob_constr_pptac c)) + (lift_env Ppconstr.pr_constr_expr) + (lift_env (fun env sigma (c,_) -> pr_glob_constr_pptac env sigma c)) (make_constr_printer Printer.pr_closed_glob_n_env) ; Genprint.register_print0 wit_open_constr - (lift Ppconstr.pr_constr_expr) - (lift (fun (c, _) -> pr_glob_constr_pptac c)) + (lift_env Ppconstr.pr_constr_expr) + (lift_env (fun env sigma (c, _) -> pr_glob_constr_pptac env sigma c)) (make_constr_printer Printer.pr_econstr_n_env) ; Genprint.register_print0 wit_red_expr - (lift (pr_red_expr (pr_constr_expr, pr_lconstr_expr, pr_or_by_notation pr_qualid, pr_constr_pattern_expr))) - (lift (pr_red_expr (pr_and_constr_expr pr_glob_constr_pptac, pr_and_constr_expr pr_lglob_constr_pptac, pr_or_var (pr_and_short_name pr_evaluable_reference), pr_pat_and_constr_expr pr_glob_constr_pptac))) + (lift_env (fun env sigma -> pr_red_expr env sigma (pr_constr_expr, pr_lconstr_expr, pr_or_by_notation pr_qualid, pr_constr_pattern_expr))) + (lift_env (fun env sigma -> pr_red_expr env sigma + ((fun env sigma -> pr_and_constr_expr @@ pr_glob_constr_pptac env sigma), + (fun env sigma -> pr_and_constr_expr @@ pr_lglob_constr_pptac env sigma), + pr_or_var (pr_and_short_name pr_evaluable_reference), + (fun env sigma -> pr_pat_and_constr_expr @@ pr_glob_constr_pptac env sigma)))) pr_red_expr_env ; register_basic_print0 wit_quant_hyp pr_quantified_hypothesis pr_quantified_hypothesis pr_quantified_hypothesis; register_print0 wit_bindings - (lift (Miscprint.pr_bindings_no_with pr_constr_expr pr_lconstr_expr)) - (lift (Miscprint.pr_bindings_no_with (pr_and_constr_expr pr_glob_constr_pptac) (pr_and_constr_expr pr_lglob_constr_pptac))) + (lift_env (fun env sigma -> Miscprint.pr_bindings_no_with (pr_constr_expr env sigma) + (pr_lconstr_expr env sigma))) + (lift_env (fun env sigma -> Miscprint.pr_bindings_no_with (pr_and_constr_expr @@ pr_glob_constr_pptac env sigma) (pr_and_constr_expr @@ pr_lglob_constr_pptac env sigma))) pr_bindings_env ; register_print0 wit_constr_with_bindings - (lift (pr_with_bindings pr_constr_expr pr_lconstr_expr)) - (lift (pr_with_bindings (pr_and_constr_expr pr_glob_constr_pptac) (pr_and_constr_expr pr_lglob_constr_pptac))) + (lift_env (fun env sigma -> pr_with_bindings (pr_constr_expr env sigma) (pr_lconstr_expr env sigma))) + (lift_env (fun env sigma -> pr_with_bindings (pr_and_constr_expr @@ pr_glob_constr_pptac env sigma) + (pr_and_constr_expr @@ pr_lglob_constr_pptac env sigma))) pr_with_bindings_env ; register_print0 wit_open_constr_with_bindings - (lift (pr_with_bindings pr_constr_expr pr_lconstr_expr)) - (lift (pr_with_bindings (pr_and_constr_expr pr_glob_constr_pptac) (pr_and_constr_expr pr_lglob_constr_pptac))) + (lift_env (fun env sigma -> pr_with_bindings (pr_constr_expr env sigma) (pr_lconstr_expr env sigma))) + (lift_env (fun env sigma -> pr_with_bindings (pr_and_constr_expr @@ pr_glob_constr_pptac env sigma) + (pr_and_constr_expr @@ pr_lglob_constr_pptac env sigma))) pr_with_bindings_env ; register_print0 Tacarg.wit_destruction_arg - (lift (pr_destruction_arg pr_constr_expr pr_lconstr_expr)) - (lift (pr_destruction_arg (pr_and_constr_expr pr_glob_constr_pptac) (pr_and_constr_expr pr_lglob_constr_pptac))) + (lift_env (fun env sigma -> pr_destruction_arg (pr_constr_expr env sigma) (pr_lconstr_expr env sigma))) + (lift_env (fun env sigma -> pr_destruction_arg (pr_and_constr_expr @@ pr_glob_constr_pptac env sigma) + (pr_and_constr_expr @@ pr_lglob_constr_pptac env sigma))) pr_destruction_arg_env ; register_basic_print0 Stdarg.wit_int int int int; @@ -1379,12 +1393,12 @@ let () = register_basic_print0 Stdarg.wit_string qstring qstring qstring let () = - let printer _ _ prtac = prtac in + let printer env sigma _ _ prtac = prtac env sigma in declare_extra_genarg_pprule_with_level wit_tactic printer printer printer ltop (0,E) let () = - let pr_unit _ _ _ _ () = str "()" in - let printer _ _ prtac = prtac in + let pr_unit _env _sigma _ _ _ _ () = str "()" in + let printer env sigma _ _ prtac = prtac env sigma in declare_extra_genarg_pprule_with_level wit_ltac printer printer pr_unit ltop (0,E) diff --git a/plugins/ltac/pptactic.mli b/plugins/ltac/pptactic.mli index bc47036d92..70af09833d 100644 --- a/plugins/ltac/pptactic.mli +++ b/plugins/ltac/pptactic.mli @@ -26,40 +26,46 @@ type 'a grammar_tactic_prod_item_expr = | TacNonTerm of ('a * Names.Id.t option) Loc.located type 'a raw_extra_genarg_printer = - (constr_expr -> Pp.t) -> - (constr_expr -> Pp.t) -> - (tolerability -> raw_tactic_expr -> Pp.t) -> - 'a -> Pp.t + Environ.env -> Evd.evar_map -> + (Environ.env -> Evd.evar_map -> constr_expr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> constr_expr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> tolerability -> raw_tactic_expr -> Pp.t) -> + 'a -> Pp.t type 'a glob_extra_genarg_printer = - (glob_constr_and_expr -> Pp.t) -> - (glob_constr_and_expr -> Pp.t) -> - (tolerability -> glob_tactic_expr -> Pp.t) -> - 'a -> Pp.t + Environ.env -> Evd.evar_map -> + (Environ.env -> Evd.evar_map -> glob_constr_and_expr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> glob_constr_and_expr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> tolerability -> glob_tactic_expr -> Pp.t) -> + 'a -> Pp.t type 'a extra_genarg_printer = - (EConstr.t -> Pp.t) -> - (EConstr.t -> Pp.t) -> - (tolerability -> Val.t -> Pp.t) -> - 'a -> Pp.t + Environ.env -> Evd.evar_map -> + (Environ.env -> Evd.evar_map -> EConstr.constr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> EConstr.constr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> tolerability -> Val.t -> Pp.t) -> + 'a -> Pp.t type 'a raw_extra_genarg_printer_with_level = - (constr_expr -> Pp.t) -> - (constr_expr -> Pp.t) -> - (tolerability -> raw_tactic_expr -> Pp.t) -> - tolerability -> 'a -> Pp.t + Environ.env -> Evd.evar_map -> + (Environ.env -> Evd.evar_map -> constr_expr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> constr_expr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> tolerability -> raw_tactic_expr -> Pp.t) -> + tolerability -> 'a -> Pp.t type 'a glob_extra_genarg_printer_with_level = - (glob_constr_and_expr -> Pp.t) -> - (glob_constr_and_expr -> Pp.t) -> - (tolerability -> glob_tactic_expr -> Pp.t) -> - tolerability -> 'a -> Pp.t + Environ.env -> Evd.evar_map -> + (Environ.env -> Evd.evar_map -> glob_constr_and_expr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> glob_constr_and_expr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> tolerability -> glob_tactic_expr -> Pp.t) -> + tolerability -> 'a -> Pp.t type 'a extra_genarg_printer_with_level = - (EConstr.constr -> Pp.t) -> - (EConstr.constr -> Pp.t) -> - (tolerability -> Val.t -> Pp.t) -> - tolerability -> 'a -> Pp.t + Environ.env -> Evd.evar_map -> + (Environ.env -> Evd.evar_map -> EConstr.constr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> EConstr.constr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> tolerability -> Val.t -> Pp.t) -> + tolerability -> 'a -> Pp.t val declare_extra_genarg_pprule : ('a, 'b, 'c) genarg_type -> @@ -91,12 +97,13 @@ val declare_notation_tactic_pprule : KerName.t -> pp_tactic -> unit val pr_with_occurrences : ('a -> Pp.t) -> 'a Locus.with_occurrences -> Pp.t -val pr_red_expr : - ('a -> Pp.t) * ('a -> Pp.t) * ('b -> Pp.t) * ('c -> Pp.t) -> +val pr_red_expr : env -> Evd.evar_map -> + (env -> Evd.evar_map -> 'a -> Pp.t) * (env -> Evd.evar_map -> 'a -> Pp.t) * ('b -> Pp.t) * (env -> Evd.evar_map -> 'c -> Pp.t) -> ('a,'b,'c) Genredexpr.red_expr_gen -> Pp.t val pr_may_eval : - ('a -> Pp.t) -> ('a -> Pp.t) -> ('b -> Pp.t) -> - ('c -> Pp.t) -> ('a,'b,'c) Genredexpr.may_eval -> Pp.t + env -> Evd.evar_map -> + (env -> Evd.evar_map -> 'a -> Pp.t) -> (env -> Evd.evar_map -> 'a -> Pp.t) -> ('b -> Pp.t) -> + (env -> Evd.evar_map -> 'c -> Pp.t) -> ('a,'b,'c) Genredexpr.may_eval -> Pp.t val pr_and_short_name : ('a -> Pp.t) -> 'a Genredexpr.and_short_name -> Pp.t @@ -111,14 +118,14 @@ val pr_clauses : (* default: *) bool option -> ('a -> Pp.t) -> 'a Locus.clause_expr -> Pp.t (* Some true = default is concl; Some false = default is all; None = no default *) -val pr_raw_generic : env -> rlevel generic_argument -> Pp.t +val pr_raw_generic : env -> Evd.evar_map -> rlevel generic_argument -> Pp.t -val pr_glb_generic : env -> glevel generic_argument -> Pp.t +val pr_glb_generic : env -> Evd.evar_map -> glevel generic_argument -> Pp.t -val pr_raw_extend: env -> int -> +val pr_raw_extend: env -> Evd.evar_map -> int -> ml_tactic_entry -> raw_tactic_arg list -> Pp.t -val pr_glob_extend: env -> int -> +val pr_glob_extend: env -> Evd.evar_map -> int -> ml_tactic_entry -> glob_tactic_arg list -> Pp.t val pr_extend : @@ -131,9 +138,9 @@ val pr_alias : (Val.t -> Pp.t) -> val pr_ltac_constant : ltac_constant -> Pp.t -val pr_raw_tactic : raw_tactic_expr -> Pp.t +val pr_raw_tactic : env -> Evd.evar_map -> raw_tactic_expr -> Pp.t -val pr_raw_tactic_level : tolerability -> raw_tactic_expr -> Pp.t +val pr_raw_tactic_level : env -> Evd.evar_map -> tolerability -> raw_tactic_expr -> Pp.t val pr_glob_tactic : env -> glob_tactic_expr -> Pp.t diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index b1d5c0252f..75565c1a34 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -618,7 +618,9 @@ let solve_remaining_by env sigma holes by = in (* Only solve independent holes *) let indep = List.map_filter map holes in - let ist = { Geninterp.lfun = Id.Map.empty; extra = Geninterp.TacStore.empty } in + let ist = { Geninterp.lfun = Id.Map.empty + ; poly = false + ; extra = Geninterp.TacStore.empty } in let solve_tac = match tac with | Genarg.GenArg (Genarg.Glbwit tag, tac) -> Ftactic.run (Geninterp.interp tag ist tac) (fun _ -> Proofview.tclUNIT ()) @@ -1790,15 +1792,15 @@ let declare_an_instance n s args = let declare_instance a aeq n s = declare_an_instance n s [a;aeq] -let anew_instance atts binders instance fields = +let anew_instance ~pstate atts binders instance fields = let program_mode = atts.program in - new_instance ~program_mode atts.polymorphic + new_instance ~pstate ~program_mode atts.polymorphic binders instance (Some (true, CAst.make @@ CRecord (fields))) ~global:atts.global ~generalize:false ~refine:false Hints.empty_hint_info -let declare_instance_refl atts binders a aeq n lemma = +let declare_instance_refl ~pstate atts binders a aeq n lemma = let instance = declare_instance a aeq (add_suffix n "_Reflexive") "Coq.Classes.RelationClasses.Reflexive" - in anew_instance atts binders instance + in anew_instance ~pstate atts binders instance [(qualid_of_ident (Id.of_string "reflexivity"),lemma)] let declare_instance_sym atts binders a aeq n lemma = @@ -1811,47 +1813,44 @@ let declare_instance_trans atts binders a aeq n lemma = in anew_instance atts binders instance [(qualid_of_ident (Id.of_string "transitivity"),lemma)] -let declare_relation atts ?(binders=[]) a aeq n refl symm trans = +let declare_relation ~pstate atts ?(binders=[]) a aeq n refl symm trans = init_setoid (); - let instance = declare_instance a aeq (add_suffix n "_relation") "Coq.Classes.RelationClasses.RewriteRelation" - in ignore(anew_instance atts binders instance []); + let instance = declare_instance a aeq (add_suffix n "_relation") "Coq.Classes.RelationClasses.RewriteRelation" in + let _, pstate = anew_instance ~pstate atts binders instance [] in match (refl,symm,trans) with - (None, None, None) -> () + (None, None, None) -> pstate | (Some lemma1, None, None) -> - ignore (declare_instance_refl atts binders a aeq n lemma1) + snd @@ declare_instance_refl ~pstate atts binders a aeq n lemma1 | (None, Some lemma2, None) -> - ignore (declare_instance_sym atts binders a aeq n lemma2) + snd @@ declare_instance_sym ~pstate atts binders a aeq n lemma2 | (None, None, Some lemma3) -> - ignore (declare_instance_trans atts binders a aeq n lemma3) + snd @@ declare_instance_trans ~pstate atts binders a aeq n lemma3 | (Some lemma1, Some lemma2, None) -> - ignore (declare_instance_refl atts binders a aeq n lemma1); - ignore (declare_instance_sym atts binders a aeq n lemma2) + let _lemma_refl, pstate = declare_instance_refl ~pstate atts binders a aeq n lemma1 in + snd @@ declare_instance_sym ~pstate atts binders a aeq n lemma2 | (Some lemma1, None, Some lemma3) -> - let _lemma_refl = declare_instance_refl atts binders a aeq n lemma1 in - let _lemma_trans = declare_instance_trans atts binders a aeq n lemma3 in - let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PreOrder" - in ignore( - anew_instance atts binders instance + let _lemma_refl, pstate = declare_instance_refl ~pstate atts binders a aeq n lemma1 in + let _lemma_trans, pstate = declare_instance_trans ~pstate atts binders a aeq n lemma3 in + let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PreOrder" in + snd @@ anew_instance ~pstate atts binders instance [(qualid_of_ident (Id.of_string "PreOrder_Reflexive"), lemma1); - (qualid_of_ident (Id.of_string "PreOrder_Transitive"),lemma3)]) + (qualid_of_ident (Id.of_string "PreOrder_Transitive"),lemma3)] | (None, Some lemma2, Some lemma3) -> - let _lemma_sym = declare_instance_sym atts binders a aeq n lemma2 in - let _lemma_trans = declare_instance_trans atts binders a aeq n lemma3 in - let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PER" - in ignore( - anew_instance atts binders instance + let _lemma_sym, pstate = declare_instance_sym ~pstate atts binders a aeq n lemma2 in + let _lemma_trans, pstate = declare_instance_trans ~pstate atts binders a aeq n lemma3 in + let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PER" in + snd @@ anew_instance ~pstate atts binders instance [(qualid_of_ident (Id.of_string "PER_Symmetric"), lemma2); - (qualid_of_ident (Id.of_string "PER_Transitive"),lemma3)]) + (qualid_of_ident (Id.of_string "PER_Transitive"),lemma3)] | (Some lemma1, Some lemma2, Some lemma3) -> - let _lemma_refl = declare_instance_refl atts binders a aeq n lemma1 in - let _lemma_sym = declare_instance_sym atts binders a aeq n lemma2 in - let _lemma_trans = declare_instance_trans atts binders a aeq n lemma3 in - let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence" - in ignore( - anew_instance atts binders instance + let _lemma_refl, pstate = declare_instance_refl ~pstate atts binders a aeq n lemma1 in + let _lemma_sym, pstate = declare_instance_sym ~pstate atts binders a aeq n lemma2 in + let _lemma_trans, pstate = declare_instance_trans ~pstate atts binders a aeq n lemma3 in + let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence" in + snd @@ anew_instance ~pstate atts binders instance [(qualid_of_ident (Id.of_string "Equivalence_Reflexive"), lemma1); (qualid_of_ident (Id.of_string "Equivalence_Symmetric"), lemma2); - (qualid_of_ident (Id.of_string "Equivalence_Transitive"), lemma3)]) + (qualid_of_ident (Id.of_string "Equivalence_Transitive"), lemma3)] let cHole = CAst.make @@ CHole (None, Namegen.IntroAnonymous, None) @@ -1947,18 +1946,18 @@ let warn_add_setoid_deprecated = CWarnings.create ~name:"add-setoid" ~category:"deprecated" (fun () -> Pp.(str "Add Setoid is deprecated, please use Add Parametric Relation.")) -let add_setoid atts binders a aeq t n = +let add_setoid ~pstate atts binders a aeq t n = warn_add_setoid_deprecated ?loc:a.CAst.loc (); init_setoid (); - let _lemma_refl = declare_instance_refl atts binders a aeq n (mkappc "Seq_refl" [a;aeq;t]) in - let _lemma_sym = declare_instance_sym atts binders a aeq n (mkappc "Seq_sym" [a;aeq;t]) in - let _lemma_trans = declare_instance_trans atts binders a aeq n (mkappc "Seq_trans" [a;aeq;t]) in + let _lemma_refl, pstate = declare_instance_refl ~pstate atts binders a aeq n (mkappc "Seq_refl" [a;aeq;t]) in + let _lemma_sym, pstate = declare_instance_sym ~pstate atts binders a aeq n (mkappc "Seq_sym" [a;aeq;t]) in + let _lemma_trans, pstate = declare_instance_trans ~pstate atts binders a aeq n (mkappc "Seq_trans" [a;aeq;t]) in let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence" - in ignore( - anew_instance atts binders instance + in + snd @@ anew_instance ~pstate atts binders instance [(qualid_of_ident (Id.of_string "Equivalence_Reflexive"), mkappc "Seq_refl" [a;aeq;t]); (qualid_of_ident (Id.of_string "Equivalence_Symmetric"), mkappc "Seq_sym" [a;aeq;t]); - (qualid_of_ident (Id.of_string "Equivalence_Transitive"), mkappc "Seq_trans" [a;aeq;t])]) + (qualid_of_ident (Id.of_string "Equivalence_Transitive"), mkappc "Seq_trans" [a;aeq;t])] let make_tactic name = @@ -1970,7 +1969,7 @@ let warn_add_morphism_deprecated = CWarnings.create ~name:"add-morphism" ~category:"deprecated" (fun () -> Pp.(str "Add Morphism f : id is deprecated, please use Add Morphism f with signature (...) as id")) -let add_morphism_infer atts m n = +let add_morphism_infer ~pstate atts m n : Proof_global.t option = warn_add_morphism_deprecated ?loc:m.CAst.loc (); init_setoid (); (* NB: atts.program is ignored, program mode automatically set by vernacentries *) @@ -1981,45 +1980,47 @@ let add_morphism_infer atts m n = if Lib.is_modtype () then let uctx = UState.univ_entry ~poly:atts.polymorphic uctx in let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest instance_id - (Entries.ParameterEntry - (None,(instance,uctx),None), - Decl_kinds.IsAssumption Decl_kinds.Logical) + (Entries.ParameterEntry + (None,(instance,uctx),None), + Decl_kinds.IsAssumption Decl_kinds.Logical) in - add_instance (Typeclasses.new_instance - (Lazy.force PropGlobal.proper_class) Hints.empty_hint_info atts.global (ConstRef cst)); - declare_projection n instance_id (ConstRef cst) + add_instance (Typeclasses.new_instance + (Lazy.force PropGlobal.proper_class) Hints.empty_hint_info atts.global (ConstRef cst)); + declare_projection n instance_id (ConstRef cst); + pstate else let kind = Decl_kinds.Global, atts.polymorphic, - Decl_kinds.DefinitionBody Decl_kinds.Instance + Decl_kinds.DefinitionBody Decl_kinds.Instance in let tac = make_tactic "Coq.Classes.SetoidTactics.add_morphism_tactic" in let hook _ _ _ = function - | Globnames.ConstRef cst -> - add_instance (Typeclasses.new_instance - (Lazy.force PropGlobal.proper_class) Hints.empty_hint_info + | Globnames.ConstRef cst -> + add_instance (Typeclasses.new_instance + (Lazy.force PropGlobal.proper_class) Hints.empty_hint_info atts.global (ConstRef cst)); - declare_projection n instance_id (ConstRef cst) - | _ -> assert false + declare_projection n instance_id (ConstRef cst) + | _ -> assert false in let hook = Lemmas.mk_hook hook in - Flags.silently - (fun () -> - Lemmas.start_proof ~hook instance_id kind (Evd.from_ctx uctx) (EConstr.of_constr instance); - ignore (Pfedit.by (Tacinterp.interp tac))) () + Flags.silently + (fun () -> + let pstate = Lemmas.start_proof ~ontop:pstate ~hook instance_id kind (Evd.from_ctx uctx) (EConstr.of_constr instance) in + Some (fst Pfedit.(by (Tacinterp.interp tac) pstate))) () -let add_morphism atts binders m s n = +let add_morphism ~pstate atts binders m s n = init_setoid (); let instance_id = add_suffix n "_Proper" in let instance = (((CAst.make @@ Name instance_id),None), Explicit, CAst.make @@ CAppExpl ( (None, Libnames.qualid_of_string "Coq.Classes.Morphisms.Proper",None), - [cHole; s; m])) + [cHole; s; m])) in let tac = Tacinterp.interp (make_tactic "add_morphism_tactic") in - ignore(new_instance ~program_mode:atts.program ~global:atts.global atts.polymorphic binders instance - None - ~generalize:false ~tac ~hook:(declare_projection n instance_id) Hints.empty_hint_info) + let _, pstate = new_instance ~pstate ~program_mode:atts.program ~global:atts.global atts.polymorphic binders instance + None + ~generalize:false ~tac ~hook:(declare_projection n instance_id) Hints.empty_hint_info in + pstate (** Bind to "rewrite" too *) diff --git a/plugins/ltac/rewrite.mli b/plugins/ltac/rewrite.mli index 2457b265f0..a200cb5ced 100644 --- a/plugins/ltac/rewrite.mli +++ b/plugins/ltac/rewrite.mli @@ -81,18 +81,18 @@ val cl_rewrite_clause : val is_applied_rewrite_relation : env -> evar_map -> rel_context -> constr -> types option -val declare_relation : rewrite_attributes -> +val declare_relation : pstate:Proof_global.t option -> rewrite_attributes -> ?binders:local_binder_expr list -> constr_expr -> constr_expr -> Id.t -> - constr_expr option -> constr_expr option -> constr_expr option -> unit + constr_expr option -> constr_expr option -> constr_expr option -> Proof_global.t option -val add_setoid : +val add_setoid : pstate:Proof_global.t option -> rewrite_attributes -> local_binder_expr list -> constr_expr -> constr_expr -> constr_expr -> - Id.t -> unit + Id.t -> Proof_global.t option -val add_morphism_infer : rewrite_attributes -> constr_expr -> Id.t -> unit +val add_morphism_infer : pstate:Proof_global.t option -> rewrite_attributes -> constr_expr -> Id.t -> Proof_global.t option -val add_morphism : - rewrite_attributes -> local_binder_expr list -> constr_expr -> constr_expr -> Id.t -> unit +val add_morphism : pstate:Proof_global.t option -> + rewrite_attributes -> local_binder_expr list -> constr_expr -> constr_expr -> Id.t -> Proof_global.t option val get_reflexive_proof : env -> evar_map -> constr -> constr -> evar_map * constr diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index eac84f0543..4398fb14ab 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -138,9 +138,10 @@ let f_debug : debug_info TacStore.field = TacStore.field () let f_trace : ltac_trace TacStore.field = TacStore.field () (* Signature for interpretation: val_interp and interpretation functions *) -type interp_sign = Geninterp.interp_sign = { - lfun : value Id.Map.t; - extra : TacStore.t } +type interp_sign = Geninterp.interp_sign = + { lfun : value Id.Map.t + ; poly : bool + ; extra : TacStore.t } let extract_trace ist = if is_traced () then match TacStore.get ist.extra f_trace with @@ -544,12 +545,7 @@ let interp_gen kind ist pattern_mode flags env sigma c = let (_, dummy_proofview) = Proofview.init sigma [] in (* Again this is called at times with no open proof! *) - let name, poly = - try - let Proof.{ name; poly } = Proof.data Proof_global.(give_me_the_proof ()) in - name, poly - with | Proof_global.NoCurrentProof -> Id.of_string "tacinterp", false - in + let name, poly = Id.of_string "tacinterp", ist.poly in let (trace,_,_,_) = Proofview.apply ~name ~poly env (push_trace (loc_of_glob_constr term,LtacConstrInterp (term,vars)) ist) dummy_proofview in let (evd,c) = catch_error trace (understand_ltac flags env sigma vars kind) term @@ -566,11 +562,13 @@ let constr_flags () = { fail_evar = true; expand_evars = true; program_mode = false; + polymorphic = false; } (* Interprets a constr; expects evars to be solved *) let interp_constr_gen kind ist env sigma c = - interp_gen kind ist false (constr_flags ()) env sigma c + let flags = { (constr_flags ()) with polymorphic = ist.Geninterp.poly } in + interp_gen kind ist false flags env sigma c let interp_constr = interp_constr_gen WithoutTypeConstraint @@ -582,6 +580,7 @@ let open_constr_use_classes_flags () = { fail_evar = false; expand_evars = true; program_mode = false; + polymorphic = false; } let open_constr_no_classes_flags () = { @@ -590,6 +589,7 @@ let open_constr_no_classes_flags () = { fail_evar = false; expand_evars = true; program_mode = false; + polymorphic = false; } let pure_open_constr_flags = { @@ -598,6 +598,7 @@ let pure_open_constr_flags = { fail_evar = false; expand_evars = false; program_mode = false; + polymorphic = false; } (* Interprets an open constr *) @@ -1021,6 +1022,7 @@ let type_uconstr ?(flags = (constr_flags ())) ltac_idents = closure.idents; ltac_genargs = Id.Map.empty; } in + let flags = { flags with polymorphic = ist.Geninterp.poly } in understand_ltac flags env sigma vars expected_type term end @@ -1146,6 +1148,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with (* For extensions *) | TacAlias {loc; v=(s,l)} -> let alias = Tacenv.interp_alias s in + Proofview.tclProofInfo [@ocaml.warning "-3"] >>= fun (_name, poly) -> let (>>=) = Ftactic.bind in let interp_vars = Ftactic.List.map (fun v -> interp_tacarg ist v) l in let tac l = @@ -1153,8 +1156,9 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with let lfun = List.fold_right2 addvar alias.Tacenv.alias_args l ist.lfun in Ftactic.lift (push_trace (loc,LtacNotationCall s) ist) >>= fun trace -> let ist = { - lfun = lfun; - extra = TacStore.set ist.extra f_trace trace; } in + lfun + ; poly + ; extra = TacStore.set ist.extra f_trace trace } in val_interp ist alias.Tacenv.alias_body >>= fun v -> Ftactic.lift (tactic_of_value ist v) in @@ -1207,12 +1211,13 @@ and interp_ltac_reference ?loc' mustbetac ist r : Val.t Ftactic.t = if mustbetac then Ftactic.return (coerce_to_tactic loc id v) else Ftactic.return v end | ArgArg (loc,r) -> + Proofview.tclProofInfo [@ocaml.warning "-3"] >>= fun (_name, poly) -> let ids = extract_ids [] ist.lfun Id.Set.empty in let loc_info = (Option.default loc loc',LtacNameCall r) in let extra = TacStore.set ist.extra f_avoid_ids ids in push_trace loc_info ist >>= fun trace -> let extra = TacStore.set extra f_trace trace in - let ist = { lfun = Id.Map.empty; extra = extra; } in + let ist = { lfun = Id.Map.empty; poly; extra } in let appl = GlbAppl[r,[]] in Profile_ltac.do_profile "interp_ltac_reference" trace ~count_call:false (val_interp ~appl ist (Tacenv.interp_ltac r)) @@ -1260,6 +1265,7 @@ and interp_tacarg ist arg : Val.t Ftactic.t = (* Interprets an application node *) and interp_app loc ist fv largs : Val.t Ftactic.t = + Proofview.tclProofInfo [@ocaml.warning "-3"] >>= fun (_name, poly) -> let (>>=) = Ftactic.bind in let fail = Tacticals.New.tclZEROMSG (str "Illegal tactic application.") in if has_type fv (topwit wit_tacvalue) then @@ -1277,9 +1283,11 @@ and interp_app loc ist fv largs : Val.t Ftactic.t = if List.is_empty lvar then begin wrap_error begin - let ist = { - lfun = newlfun; - extra = TacStore.set ist.extra f_trace []; } in + let ist = + { lfun = newlfun + ; poly + ; extra = TacStore.set ist.extra f_trace [] + } in Profile_ltac.do_profile "interp_app" trace ~count_call:false (catch_error_tac trace (val_interp ist body)) >>= fun v -> Ftactic.return (name_vfun (push_appl appl largs) v) @@ -1317,8 +1325,10 @@ and tactic_of_value ist vle = if has_type vle (topwit wit_tacvalue) then match to_tacvalue vle with | VFun (appl,trace,lfun,[],t) -> + Proofview.tclProofInfo [@ocaml.warning "-3"] >>= fun (_name, poly) -> let ist = { lfun = lfun; + poly; 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) @@ -1388,6 +1398,7 @@ and interp_letin ist llc u = (** [interp_match_success lz ist succ] interprets a single matching success (of type {!Tactic_matching.t}). *) and interp_match_success ist { Tactic_matching.subst ; context ; terms ; lhs } = + Proofview.tclProofInfo [@ocaml.warning "-3"] >>= fun (_name, poly) -> let (>>=) = Ftactic.bind in let lctxt = Id.Map.map interp_context context in let hyp_subst = Id.Map.map Value.of_constr terms in @@ -1396,9 +1407,11 @@ and interp_match_success ist { Tactic_matching.subst ; context ; terms ; lhs } = val_interp ist lhs >>= fun v -> if has_type v (topwit wit_tacvalue) then match to_tacvalue v with | VFun (appl,trace,lfun,[],t) -> - let ist = { - lfun = lfun; - extra = TacStore.set ist.extra f_trace trace; } in + let ist = + { lfun = lfun + ; poly + ; extra = TacStore.set ist.extra f_trace trace + } in let tac = eval_tactic ist t in let dummy = VFun (appl,extract_trace ist, Id.Map.empty, [], TacId []) in catch_error_tac trace (tac <*> Ftactic.return (of_tacvalue dummy)) @@ -1872,7 +1885,7 @@ and interp_atomic ist tac : unit Proofview.tactic = let default_ist () = let extra = TacStore.set TacStore.empty f_debug (get_debug ()) in - { lfun = Id.Map.empty; extra = extra } + { lfun = Id.Map.empty; poly = false; extra = extra } let eval_tactic t = Proofview.tclUNIT () >>= fun () -> (* delay for [default_ist] *) @@ -1912,11 +1925,12 @@ end let interp_tac_gen lfun avoid_ids debug t = + Proofview.tclProofInfo [@ocaml.warning "-3"] >>= fun (_name, poly) -> Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let extra = TacStore.set TacStore.empty f_debug debug in let extra = TacStore.set extra f_avoid_ids avoid_ids in - let ist = { lfun = lfun; extra = extra } in + let ist = { lfun; poly; extra } in let ltacvars = Id.Map.domain lfun in interp_tactic ist (intern_pure_tactic { (Genintern.empty_glob_sign env) with ltacvars } t) @@ -2057,20 +2071,15 @@ let interp_redexp env sigma r = (* Backwarding recursive needs of tactic glob/interp/eval functions *) let _ = - let eval lfun env sigma ty tac = + let eval lfun poly env sigma ty tac = let extra = TacStore.set TacStore.empty f_debug (get_debug ()) in - let ist = { lfun = lfun; extra; } in + let ist = { lfun; poly; extra; } in let tac = interp_tactic ist tac in - (* XXX: This depends on the global state which is bad; the hooking - mechanism should be modified. *) - let name, poly = - try - let (_, poly, _) = Proof_global.get_current_persistence () in - let name = Proof_global.get_current_proof_name () in - name, poly - with | Proof_global.NoCurrentProof -> - Id.of_string "ltac_gen", false - in + (* EJGA: We sould also pass the proof name if desired, for now + poly seems like enough to get reasonable behavior in practice + *) + let name, poly = Id.of_string "ltac_gen", poly in + let name, poly = Id.of_string "ltac_gen", poly in let (c, sigma) = Pfedit.refine_by_tactic ~name ~poly env sigma ty tac in (EConstr.of_constr c, sigma) in diff --git a/plugins/ltac/tacinterp.mli b/plugins/ltac/tacinterp.mli index d9c80bb835..22a092fa8b 100644 --- a/plugins/ltac/tacinterp.mli +++ b/plugins/ltac/tacinterp.mli @@ -39,9 +39,10 @@ module TacStore : Store.S with and type 'a field = 'a Geninterp.TacStore.field (** Signature for interpretation: val\_interp and interpretation functions *) -type interp_sign = Geninterp.interp_sign = { - lfun : value Id.Map.t; - extra : TacStore.t } +type interp_sign = Geninterp.interp_sign = + { lfun : value Id.Map.t + ; poly : bool + ; extra : TacStore.t } open Genintern diff --git a/plugins/ltac/tactic_debug.ml b/plugins/ltac/tactic_debug.ml index 99b9e881f6..04f3116664 100644 --- a/plugins/ltac/tactic_debug.ml +++ b/plugins/ltac/tactic_debug.ml @@ -19,11 +19,9 @@ let prtac x = Pptactic.pr_glob_tactic (Global.env()) x let prmatchpatt env sigma hyp = Pptactic.pr_match_pattern (Printer.pr_constr_pattern_env env sigma) hyp -let prmatchrl rl = +let prmatchrl env sigma rl = Pptactic.pr_match_rule false (Pptactic.pr_glob_tactic (Global.env())) - (fun (_,p) -> - let sigma, env = Pfedit.get_current_context () in - Printer.pr_constr_pattern_env env sigma p) rl + (fun (_,p) -> Printer.pr_constr_pattern_env env sigma p) rl (* This module intends to be a beginning of debugger for tactic expressions. Currently, it is quite simple and we can hope to have, in the future, a more @@ -246,13 +244,13 @@ let db_constr debug env sigma c = else return () (* Prints the pattern rule *) -let db_pattern_rule debug num r = +let db_pattern_rule debug env sigma num r = let open Proofview.NonLogical in is_debug debug >>= fun db -> if db then begin msg_tac_debug (str "Pattern rule " ++ int num ++ str ":" ++ fnl () ++ - str "|" ++ spc () ++ prmatchrl r) + str "|" ++ spc () ++ prmatchrl env sigma r) end else return () @@ -372,7 +370,10 @@ let explain_ltac_call_trace last trace loc = strbrk " (with " ++ prlist_with_sep pr_comma (fun (id,c) -> - let sigma, env = Pfedit.get_current_context () in + (* XXX: This hooks into the ExplainErr extension API + so it is tricky to provide the right env for now. *) + let env = Global.env () in + let sigma = Evd.from_env env in Id.print id ++ str ":=" ++ Printer.pr_lconstr_under_binders_env env sigma c) (List.rev (Id.Map.bindings vars)) ++ str ")" else mt()) diff --git a/plugins/ltac/tactic_debug.mli b/plugins/ltac/tactic_debug.mli index 91e8510b92..74ea4e6b74 100644 --- a/plugins/ltac/tactic_debug.mli +++ b/plugins/ltac/tactic_debug.mli @@ -40,7 +40,7 @@ val db_constr : debug_info -> env -> evar_map -> constr -> unit Proofview.NonLog (** Prints the pattern rule *) val db_pattern_rule : - debug_info -> int -> (Genintern.glob_constr_and_expr * constr_pattern,glob_tactic_expr) match_rule -> unit Proofview.NonLogical.t + debug_info -> env -> evar_map -> int -> (Genintern.glob_constr_and_expr * constr_pattern,glob_tactic_expr) match_rule -> unit Proofview.NonLogical.t (** Prints a matched hypothesis *) val db_matched_hyp : diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index ac34faa7da..6c04fe9a8a 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -877,11 +877,9 @@ struct * This is the big generic function for expression parsers. *) - let parse_expr sigma parse_constant parse_exp ops_spec env term = + let parse_expr env sigma parse_constant parse_exp ops_spec term_env term = if debug - then ( - let _, env = Pfedit.get_current_context () in - Feedback.msg_debug (Pp.str "parse_expr: " ++ Printer.pr_leconstr_env env sigma term)); + then Feedback.msg_debug (Pp.str "parse_expr: " ++ Printer.pr_leconstr_env env sigma term); (* let constant_or_variable env term = @@ -930,7 +928,7 @@ struct | _ -> parse_variable env term ) | _ -> parse_variable env term in - parse_expr env term + parse_expr term_env term let zop_spec = [ @@ -1000,8 +998,7 @@ struct | _ -> raise ParseError - let rconstant sigma term = - let _, env = Pfedit.get_current_context () in + let rconstant env sigma term = if debug then Feedback.msg_debug (Pp.str "rconstant: " ++ Printer.pr_leconstr_env env sigma term ++ fnl ()); let res = rconstant sigma term in @@ -1010,7 +1007,7 @@ struct res - let parse_zexpr sigma = parse_expr sigma + let parse_zexpr env sigma = parse_expr env sigma (zconstant sigma) (fun expr x -> let exp = (parse_z sigma x) in @@ -1019,7 +1016,7 @@ struct | _ -> Mc.PEpow(expr, Mc.Z.to_N exp)) zop_spec - let parse_qexpr sigma = parse_expr sigma + let parse_qexpr env sigma = parse_expr env sigma (qconstant sigma) (fun expr x -> let exp = parse_z sigma x in @@ -1034,23 +1031,24 @@ struct Mc.PEpow(expr,exp)) qop_spec - let parse_rexpr sigma = parse_expr sigma - (rconstant sigma) + let parse_rexpr env sigma = parse_expr env sigma + (rconstant env sigma) (fun expr x -> let exp = Mc.N.of_nat (parse_nat sigma x) in Mc.PEpow(expr,exp)) rop_spec - let parse_arith parse_op parse_expr env cstr gl = + let parse_arith parse_op parse_expr term_env cstr gl = let sigma = gl.sigma in + let env = gl.env in if debug - then Feedback.msg_debug (Pp.str "parse_arith: " ++ Printer.pr_leconstr_env gl.env sigma cstr ++ fnl ()); + then Feedback.msg_debug (Pp.str "parse_arith: " ++ Printer.pr_leconstr_env env sigma cstr ++ fnl ()); match EConstr.kind sigma cstr with | App(op,args) -> let (op,lhs,rhs) = parse_op gl (op,args) in - let (e1,env) = parse_expr sigma env lhs in - let (e2,env) = parse_expr sigma env rhs in - ({Mc.flhs = e1; Mc.fop = op;Mc.frhs = e2},env) + let (e1,term_env) = parse_expr env sigma term_env lhs in + let (e2,term_env) = parse_expr env sigma term_env rhs in + ({Mc.flhs = e1; Mc.fop = op;Mc.frhs = e2},term_env) | _ -> failwith "error : parse_arith(2)" let parse_zarith = parse_arith parse_zop parse_zexpr diff --git a/plugins/micromega/micromega_plugin.mlpack b/plugins/micromega/micromega_plugin.mlpack index 2baf6608a4..e3aa0dab7d 100644 --- a/plugins/micromega/micromega_plugin.mlpack +++ b/plugins/micromega/micromega_plugin.mlpack @@ -1,8 +1,8 @@ +Micromega Mutils Itv Vect Sos_types -Micromega Polynomial Mfourier Simplex diff --git a/plugins/setoid_ring/g_newring.mlg b/plugins/setoid_ring/g_newring.mlg index f59ca4cef4..6be556b2ae 100644 --- a/plugins/setoid_ring/g_newring.mlg +++ b/plugins/setoid_ring/g_newring.mlg @@ -38,24 +38,24 @@ END open Pptactic open Ppconstr -let pr_ring_mod = function - | Ring_kind (Computational eq_test) -> str "decidable" ++ pr_arg pr_constr_expr eq_test +let pr_ring_mod env sigma = function + | Ring_kind (Computational eq_test) -> str "decidable" ++ pr_arg (pr_constr_expr env sigma) eq_test | Ring_kind Abstract -> str "abstract" - | Ring_kind (Morphism morph) -> str "morphism" ++ pr_arg pr_constr_expr morph - | Const_tac (CstTac cst_tac) -> str "constants" ++ spc () ++ str "[" ++ pr_raw_tactic cst_tac ++ str "]" + | Ring_kind (Morphism morph) -> str "morphism" ++ pr_arg (pr_constr_expr env sigma) morph + | Const_tac (CstTac cst_tac) -> str "constants" ++ spc () ++ str "[" ++ pr_raw_tactic env sigma cst_tac ++ str "]" | Const_tac (Closed l) -> str "closed" ++ spc () ++ str "[" ++ prlist_with_sep spc pr_qualid l ++ str "]" - | Pre_tac t -> str "preprocess" ++ spc () ++ str "[" ++ pr_raw_tactic t ++ str "]" - | Post_tac t -> str "postprocess" ++ spc () ++ str "[" ++ pr_raw_tactic t ++ str "]" - | Setoid(sth,ext) -> str "setoid" ++ pr_arg pr_constr_expr sth ++ pr_arg pr_constr_expr ext - | Pow_spec(Closed l,spec) -> str "power_tac" ++ pr_arg pr_constr_expr spec ++ spc () ++ str "[" ++ prlist_with_sep spc pr_qualid l ++ str "]" - | Pow_spec(CstTac cst_tac,spec) -> str "power_tac" ++ pr_arg pr_constr_expr spec ++ spc () ++ str "[" ++ pr_raw_tactic cst_tac ++ str "]" - | Sign_spec t -> str "sign" ++ pr_arg pr_constr_expr t - | Div_spec t -> str "div" ++ pr_arg pr_constr_expr t + | Pre_tac t -> str "preprocess" ++ spc () ++ str "[" ++ pr_raw_tactic env sigma t ++ str "]" + | Post_tac t -> str "postprocess" ++ spc () ++ str "[" ++ pr_raw_tactic env sigma t ++ str "]" + | Setoid(sth,ext) -> str "setoid" ++ pr_arg (pr_constr_expr env sigma) sth ++ pr_arg (pr_constr_expr env sigma) ext + | Pow_spec(Closed l,spec) -> str "power_tac" ++ pr_arg (pr_constr_expr env sigma) spec ++ spc () ++ str "[" ++ prlist_with_sep spc pr_qualid l ++ str "]" + | Pow_spec(CstTac cst_tac,spec) -> str "power_tac" ++ pr_arg (pr_constr_expr env sigma) spec ++ spc () ++ str "[" ++ pr_raw_tactic env sigma cst_tac ++ str "]" + | Sign_spec t -> str "sign" ++ pr_arg (pr_constr_expr env sigma) t + | Div_spec t -> str "div" ++ pr_arg (pr_constr_expr env sigma) t } VERNAC ARGUMENT EXTEND ring_mod - PRINTED BY { pr_ring_mod } + PRINTED BY { pr_ring_mod env sigma } | [ "decidable" constr(eq_test) ] -> { Ring_kind(Computational eq_test) } | [ "abstract" ] -> { Ring_kind Abstract } | [ "morphism" constr(morph) ] -> { Ring_kind(Morphism morph) } @@ -74,27 +74,32 @@ END { -let pr_ring_mods l = surround (prlist_with_sep pr_comma pr_ring_mod l) +let pr_ring_mods env sigma l = surround (prlist_with_sep pr_comma (pr_ring_mod env sigma) l) } VERNAC ARGUMENT EXTEND ring_mods - PRINTED BY { pr_ring_mods } + PRINTED BY { pr_ring_mods env sigma } | [ "(" ne_ring_mod_list_sep(mods, ",") ")" ] -> { mods } END VERNAC COMMAND EXTEND AddSetoidRing CLASSIFIED AS SIDEFF | [ "Add" "Ring" ident(id) ":" constr(t) ring_mods_opt(l) ] -> { let l = match l with None -> [] | Some l -> l in add_theory id t l } - | [ "Print" "Rings" ] => { Vernacextend.classify_as_query } -> { + | ![proof] [ "Print" "Rings" ] => { Vernacextend.classify_as_query } -> { + fun ~pstate -> Feedback.msg_notice (strbrk "The following ring structures have been declared:"); Spmap.iter (fun fn fi -> - let sigma, env = Pfedit.get_current_context () in + (* We should use the global env here as this shouldn't contain proof + data, however preserving behavior as requested in review. *) + let sigma, env = Option.cata Pfedit.get_current_context + (let e = Global.env () in Evd.from_env e, e) pstate in Feedback.msg_notice (hov 2 (Ppconstr.pr_id (Libnames.basename fn)++spc()++ str"with carrier "++ pr_constr_env env sigma fi.ring_carrier++spc()++ str"and equivalence relation "++ pr_constr_env env sigma fi.ring_req)) - ) !from_name } + ) !from_name; + pstate } END TACTIC EXTEND ring_lookup @@ -104,41 +109,46 @@ END { -let pr_field_mod = function - | Ring_mod m -> pr_ring_mod m - | Inject inj -> str "completeness" ++ pr_arg pr_constr_expr inj +let pr_field_mod env sigma = function + | Ring_mod m -> pr_ring_mod env sigma m + | Inject inj -> str "completeness" ++ pr_arg (pr_constr_expr env sigma) inj } VERNAC ARGUMENT EXTEND field_mod - PRINTED BY { pr_field_mod } + PRINTED BY { pr_field_mod env sigma } | [ ring_mod(m) ] -> { Ring_mod m } | [ "completeness" constr(inj) ] -> { Inject inj } END { -let pr_field_mods l = surround (prlist_with_sep pr_comma pr_field_mod l) +let pr_field_mods env sigma l = surround (prlist_with_sep pr_comma (pr_field_mod env sigma) l) } VERNAC ARGUMENT EXTEND field_mods - PRINTED BY { pr_field_mods } + PRINTED BY { pr_field_mods env sigma } | [ "(" ne_field_mod_list_sep(mods, ",") ")" ] -> { mods } END VERNAC COMMAND EXTEND AddSetoidField CLASSIFIED AS SIDEFF | [ "Add" "Field" ident(id) ":" constr(t) field_mods_opt(l) ] -> { let l = match l with None -> [] | Some l -> l in add_field_theory id t l } -| [ "Print" "Fields" ] => {Vernacextend.classify_as_query} -> { +| ![proof] [ "Print" "Fields" ] => {Vernacextend.classify_as_query} -> { + fun ~pstate -> Feedback.msg_notice (strbrk "The following field structures have been declared:"); Spmap.iter (fun fn fi -> - let sigma, env = Pfedit.get_current_context () in + (* We should use the global env here as this shouldn't + contain proof data. *) + let sigma, env = Option.cata Pfedit.get_current_context + (let e = Global.env () in Evd.from_env e, e) pstate in Feedback.msg_notice (hov 2 (Ppconstr.pr_id (Libnames.basename fn)++spc()++ str"with carrier "++ pr_constr_env env sigma fi.field_carrier++spc()++ str"and equivalence relation "++ pr_constr_env env sigma fi.field_req)) - ) !field_from_name } + ) !field_from_name; + pstate } END TACTIC EXTEND field_lookup diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index 58daa7a7d4..2a84469af0 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -246,6 +246,7 @@ let interp_refine ist gl rc = fail_evar = false; expand_evars = true; program_mode = false; + polymorphic = false; } in let sigma, c = Pretyping.understand_ltac flags (pf_env gl) (project gl) vars kind rc in @@ -1175,7 +1176,7 @@ let genstac (gens, clr) = tclTHENLIST (old_cleartac clr :: List.rev_map gentac gens) let gen_tmp_ids - ?(ist=Geninterp.({ lfun = Id.Map.empty; extra = Tacinterp.TacStore.empty })) gl + ?(ist=Geninterp.({ lfun = Id.Map.empty; poly = false; extra = Tacinterp.TacStore.empty })) gl = let gl, ctx = pull_ctx gl in push_ctxs ctx @@ -1232,7 +1233,7 @@ let abs_wgen keep_let f gen (gl,args,c) = let evar_closed t p = if occur_existential sigma t then CErrors.user_err ?loc:(loc_of_cpattern p) ~hdr:"ssreflect" - (pr_constr_pat (EConstr.Unsafe.to_constr t) ++ + (pr_econstr_pat env sigma t ++ str" contains holes and matches no subterm of the goal") in match gen with | _, Some ((x, mode), None) when mode = "@" || (mode = " " && keep_let) -> diff --git a/plugins/ssr/ssrelim.ml b/plugins/ssr/ssrelim.ml index 82a88678f0..350bb9019e 100644 --- a/plugins/ssr/ssrelim.ml +++ b/plugins/ssr/ssrelim.ml @@ -133,7 +133,7 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = | _ -> false in let match_pat env p occ h cl = let sigma0 = project orig_gl in - ppdebug(lazy Pp.(str"matching: " ++ pr_occ occ ++ pp_pattern p)); + ppdebug(lazy Pp.(str"matching: " ++ pr_occ occ ++ pp_pattern env p)); let (c,ucst), cl = fill_occ_pattern ~raise_NoMatch:true env sigma0 (EConstr.Unsafe.to_constr cl) p occ h in ppdebug(lazy Pp.(str" got: " ++ pr_constr_env env sigma0 c)); @@ -239,8 +239,10 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = let elimty = Reductionops.whd_all env (project gl) elimty in seed, cty, elim, elimty, elim_args, n_elim_args, elim_is_dep, is_rec, pred, gl in - ppdebug(lazy Pp.(str"elim= "++ pr_constr_pat (EConstr.Unsafe.to_constr elim))); - ppdebug(lazy Pp.(str"elimty= "++ pr_constr_pat (EConstr.Unsafe.to_constr elimty))); + let () = + let sigma = project gl in + ppdebug(lazy Pp.(str"elim= "++ pr_econstr_pat env sigma elim)); + ppdebug(lazy Pp.(str"elimty= "++ pr_econstr_pat env sigma elimty)) in let inf_deps_r = match EConstr.kind_of_type (project gl) elimty with | AtomicType (_, args) -> List.rev (Array.to_list args) | _ -> assert false in @@ -255,38 +257,56 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = (* Here we try to understand if the main pattern/term the user gave is * the first pattern to be matched (i.e. if elimty ends in P t1 .. tn, * weather tn is the t the user wrote in 'elim: t' *) - let c_is_head_p, gl = match cty with + let c_is_head_p, gl = + match cty with | None -> true, gl (* The user wrote elim: _ *) | Some (c, c_ty, _) -> - let res = - (* we try to see if c unifies with the last arg of elim *) - if elim_is_dep then None else - let arg = List.assoc (n_elim_args - 1) elim_args in - let gl, arg_ty = pfe_type_of gl arg in - match saturate_until gl c c_ty (fun c c_ty gl -> - pf_unify_HO (pf_unify_HO gl c_ty arg_ty) arg c) with - | Some (c, _, _, gl) -> Some (false, gl) - | None -> None in - match res with - | Some x -> x - | None -> - (* we try to see if c unifies with the last inferred pattern *) - let inf_arg = List.hd inf_deps_r in - let gl, inf_arg_ty = pfe_type_of gl inf_arg in - match saturate_until gl c c_ty (fun _ c_ty gl -> - pf_unify_HO gl c_ty inf_arg_ty) with - | Some (c, _, _,gl) -> true, gl - | None -> - errorstrm Pp.(str"Unable to apply the eliminator to the term"++ - spc()++pr_econstr_env env (project gl) c++spc()++str"or to unify it's type with"++ - pr_econstr_env env (project gl) inf_arg_ty) in + let rec first = function + | [] -> + errorstrm Pp.(str"Unable to apply the eliminator to the term"++ + spc()++pr_econstr_env env (project gl) c++spc()) + | x :: rest -> + match x () with + | None -> first rest + | Some (b,gl) -> b, gl + in + (* Unify two terms if their heads are not applied unif variables, eg + * not (?P x). The idea is to rule out cases where the problem is too + * vague to drive the current heuristics. *) + let pf_unify_HO_rigid gl a b = + let is_applied_evar x = match EConstr.kind (project gl) x with + | App(x,_) -> EConstr.isEvar (project gl) x + | _ -> false in + if is_applied_evar a || is_applied_evar b then + raise Evarconv.(UnableToUnify(project gl, + Pretype_errors.ProblemBeyondCapabilities)) + else pf_unify_HO gl a b in + let try_c_last_arg () = + (* we try to see if c unifies with the last arg of elim *) + if elim_is_dep then None else + let arg = List.assoc (n_elim_args - 1) elim_args in + let gl, arg_ty = pfe_type_of gl arg in + match saturate_until gl c c_ty (fun c c_ty gl -> + pf_unify_HO (pf_unify_HO_rigid gl c_ty arg_ty) arg c) with + | Some (c, _, _, gl) -> Some (false, gl) + | None -> None in + let try_c_last_pattern () = + (* we try to see if c unifies with the last inferred pattern *) + if inf_deps_r = [] then None else + let inf_arg = List.hd inf_deps_r in + let gl, inf_arg_ty = pfe_type_of gl inf_arg in + match saturate_until gl c c_ty (fun _ c_ty gl -> + pf_unify_HO_rigid gl c_ty inf_arg_ty) with + | Some (c, _, _,gl) -> Some(true, gl) + | None -> None in + first [try_c_last_arg;try_c_last_pattern] in ppdebug(lazy Pp.(str"c_is_head_p= " ++ bool c_is_head_p)); let gl, predty = pfe_type_of gl pred in (* Patterns for the inductive types indexes to be bound in pred are computed * looking at the ones provided by the user and the inferred ones looking at * the type of the elimination principle *) - let pp_pat (_,p,_,occ) = Pp.(pr_occ occ ++ pp_pattern p) in - let pp_inf_pat gl (_,_,t,_) = pr_constr_pat (EConstr.Unsafe.to_constr (fire_subst gl t)) in + let pp_pat (_,p,_,occ) = Pp.(pr_occ occ ++ pp_pattern env p) in + let pp_inf_pat gl (_,_,t,_) = pr_econstr_pat env (project gl) (fire_subst gl t) in let patterns, clr, gl = let rec loop patterns clr i = function | [],[] -> patterns, clr, gl @@ -300,7 +320,7 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = loop (patterns @ [i, p, inf_t, occ]) (clr_t @ clr) (i+1) (deps, inf_deps) | [], c :: inf_deps -> - ppdebug(lazy Pp.(str"adding inf pattern " ++ pr_constr_pat (EConstr.Unsafe.to_constr c))); + ppdebug(lazy Pp.(str"adding inf pattern " ++ pr_econstr_pat env (project gl) c)); loop (patterns @ [i, mkTpat gl c, c, allocc]) clr (i+1) ([], inf_deps) | _::_, [] -> errorstrm Pp.(str "Too many dependent abstractions") in @@ -323,11 +343,11 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = let elim_pred, gen_eq_tac, clr, gl = let error gl t inf_t = errorstrm Pp.(str"The given pattern matches the term"++ spc()++pp_term gl t++spc()++str"while the inferred pattern"++ - spc()++pr_constr_pat (EConstr.Unsafe.to_constr (fire_subst gl inf_t))++spc()++ str"doesn't") in + spc()++pr_econstr_pat env (project gl) (fire_subst gl inf_t)++spc()++ str"doesn't") in let match_or_postpone (cl, gl, post) (h, p, inf_t, occ) = let p = unif_redex gl p inf_t in if is_undef_pat p then - let () = ppdebug(lazy Pp.(str"postponing " ++ pp_pattern p)) in + let () = ppdebug(lazy Pp.(str"postponing " ++ pp_pattern env p)) in cl, gl, post @ [h, p, inf_t, occ] else try let c, cl, ucst = match_pat env p occ h cl in @@ -408,7 +428,7 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = if not (Evar.Set.is_empty inter) then begin let i = Evar.Set.choose inter in let pat = List.find (fun t -> Evar.Set.mem i (evars_of_term t)) patterns in - errorstrm Pp.(str"Pattern"++spc()++pr_constr_pat (EConstr.Unsafe.to_constr pat)++spc()++ + errorstrm Pp.(str"Pattern"++spc()++pr_econstr_pat env (project gl) pat++spc()++ str"was not completely instantiated and one of its variables"++spc()++ str"occurs in the type of another non-instantiated pattern variable"); end diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml index 18461c0533..5abbc214de 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -199,13 +199,13 @@ let simplintac occ rdx sim gl = | SimplCut (n,m) -> tclTHEN (simptac m) (tclTRY (donetac n)) gl | _ -> simpltac sim gl -let rec get_evalref sigma c = match EConstr.kind sigma c with +let rec get_evalref env sigma c = match EConstr.kind sigma c with | Var id -> EvalVarRef id | Const (k,_) -> EvalConstRef k - | App (c', _) -> get_evalref sigma c' - | Cast (c', _, _) -> get_evalref sigma c' + | App (c', _) -> get_evalref env sigma c' + | Cast (c', _, _) -> get_evalref env sigma c' | Proj(c,_) -> EvalConstRef(Projection.constant c) - | _ -> errorstrm Pp.(str "The term " ++ pr_constr_pat (EConstr.Unsafe.to_constr c) ++ str " is not unfoldable") + | _ -> errorstrm Pp.(str "The term " ++ pr_econstr_pat (Global.env ()) sigma c ++ str " is not unfoldable") (* Strip a pattern generated by a prenex implicit to its constant. *) let strip_unfold_term _ ((sigma, t) as p) kt = match EConstr.kind sigma t with @@ -230,7 +230,7 @@ let unfoldintac occ rdx t (kt,_) gl = let sigma0, concl0, env0 = project gl, pf_concl gl, pf_env gl in let (sigma, t), const = strip_unfold_term env0 t kt in let body env t c = - Tacred.unfoldn [AllOccurrences, get_evalref sigma t] env sigma0 c in + Tacred.unfoldn [AllOccurrences, get_evalref env sigma t] env sigma0 c in let easy = occ = None && rdx = None in let red_flags = if easy then CClosure.betaiotazeta else CClosure.betaiota in let beta env = Reductionops.clos_norm_flags red_flags env sigma0 in @@ -244,7 +244,7 @@ let unfoldintac occ rdx t (kt,_) gl = try find_T env c h ~k:(fun env c _ _ -> EConstr.Unsafe.to_constr (body env t (EConstr.of_constr c))) with NoMatch when easy -> c | NoMatch | NoProgress -> errorstrm Pp.(str"No occurrence of " - ++ pr_constr_pat (EConstr.Unsafe.to_constr t) ++ spc() ++ str "in " ++ Printer.pr_constr_env env sigma c)), + ++ pr_econstr_pat env sigma0 t ++ spc() ++ str "in " ++ Printer.pr_constr_env env sigma c)), (fun () -> try end_T () with | NoMatch when easy -> fake_pmatcher_end () | NoMatch -> anomaly "unfoldintac") @@ -270,12 +270,12 @@ let unfoldintac occ rdx t (kt,_) gl = else try EConstr.Unsafe.to_constr @@ body env t (fs (unify_HO env sigma (EConstr.of_constr c) t) t) with _ -> errorstrm Pp.(str "The term " ++ - pr_constr_env env sigma c ++spc()++ str "does not unify with " ++ pr_constr_pat (EConstr.Unsafe.to_constr t))), + pr_constr_env env sigma c ++spc()++ str "does not unify with " ++ pr_econstr_pat env sigma t)), fake_pmatcher_end in let concl = let concl0 = EConstr.Unsafe.to_constr concl0 in try beta env0 (EConstr.of_constr (eval_pattern env0 sigma0 concl0 rdx occ unfold)) - with Option.IsNone -> errorstrm Pp.(str"Failed to unfold " ++ pr_constr_pat (EConstr.Unsafe.to_constr t)) in + with Option.IsNone -> errorstrm Pp.(str"Failed to unfold " ++ pr_econstr_pat env0 sigma t) in let _ = conclude () in Proofview.V82.of_tactic (convert_concl concl) gl ;; @@ -298,8 +298,8 @@ let foldtac occ rdx ft gl = try let sigma = unify_HO env sigma (EConstr.of_constr c) (EConstr.of_constr t) in EConstr.to_constr ~abort_on_undefined_evars:false sigma (EConstr.of_constr t) - with _ -> errorstrm Pp.(str "fold pattern " ++ pr_constr_pat t ++ spc () - ++ str "does not match redex " ++ pr_constr_pat c)), + with _ -> errorstrm Pp.(str "fold pattern " ++ pr_constr_pat env sigma t ++ spc () + ++ str "does not match redex " ++ pr_constr_pat env sigma c)), fake_pmatcher_end in let concl0 = EConstr.Unsafe.to_constr concl0 in let concl = eval_pattern env0 sigma0 concl0 rdx occ fold in @@ -325,7 +325,7 @@ let rec strip_prod_assum c = match Constr.kind c with let rule_id = mk_internal_id "rewrite rule" -exception PRtype_error +exception PRtype_error of (Environ.env * Evd.evar_map * Pretype_errors.pretype_error) option let pirrel_rewrite pred rdx rdx_ty new_rdx dir (sigma, c) c_ty gl = (* ppdebug(lazy(str"sigma@pirrel_rewrite=" ++ pr_evar_map None sigma)); *) @@ -351,7 +351,10 @@ let pirrel_rewrite pred rdx rdx_ty new_rdx dir (sigma, c) c_ty gl = let proof = EConstr.mkApp (elim, [| rdx_ty; new_rdx; pred; p; rdx; c |]) in (* We check the proof is well typed *) let sigma, proof_ty = - try Typing.type_of env sigma proof with _ -> raise PRtype_error in + try Typing.type_of env sigma proof with + | Pretype_errors.PretypeError (env, sigma, te) -> raise (PRtype_error (Some (env, sigma, te))) + | e when CErrors.noncritical e -> raise (PRtype_error None) + in ppdebug(lazy Pp.(str"pirrel_rewrite proof term of type: " ++ pr_econstr_env env sigma proof_ty)); try refine_with ~first_goes_last:(not !ssroldreworder) ~with_evars:false (sigma, proof) gl @@ -412,7 +415,7 @@ let rwcltac cl rdx dir sr gl = let dc, r2 = EConstr.decompose_lam_n_assum (project gl) n r' in let r3, _, r3t = try EConstr.destCast (project gl) r2 with _ -> - errorstrm Pp.(str "no cast from " ++ pr_constr_pat (EConstr.Unsafe.to_constr (snd sr)) + errorstrm Pp.(str "no cast from " ++ pr_econstr_pat (pf_env gl) (project gl) (snd sr) ++ str " to " ++ pr_econstr_env (pf_env gl) (project gl) r2) in let cl' = EConstr.mkNamedProd (make_annot rule_id Sorts.Relevant) (EConstr.it_mkProd_or_LetIn r3t dc) (EConstr.Vars.lift 1 cl) in let cl'' = EConstr.mkNamedProd (make_annot pattern_id Sorts.Relevant) rdxt cl' in @@ -423,13 +426,16 @@ let rwcltac cl rdx dir sr gl = in let cvtac' _ = try cvtac gl with - | PRtype_error -> + | PRtype_error e -> + let error = Option.cata (fun (env, sigma, te) -> + Pp.(fnl () ++ str "Type error was: " ++ Himsg.explain_pretype_error env sigma te)) + (Pp.mt ()) e in if occur_existential (project gl) (Tacmach.pf_concl gl) - then errorstrm Pp.(str "Rewriting impacts evars") + then errorstrm Pp.(str "Rewriting impacts evars" ++ error) else errorstrm Pp.(str "Dependent type error in rewrite of " - ++ pr_constr_env (pf_env gl) (project gl) - (Term.mkNamedLambda (make_annot pattern_id Sorts.Relevant) - (EConstr.Unsafe.to_constr rdxt) (EConstr.Unsafe.to_constr cl))) + ++ pr_econstr_env (pf_env gl) (project gl) + (EConstr.mkNamedLambda (make_annot pattern_id Sorts.Relevant) rdxt cl) + ++ error) in tclTHEN cvtac' rwtac gl @@ -473,7 +479,7 @@ let rwprocess_rule dir rule gl = let t = if red = 1 then Tacred.hnf_constr env sigma t0 else Reductionops.whd_betaiotazeta sigma t0 in - ppdebug(lazy Pp.(str"rewrule="++pr_constr_pat (EConstr.Unsafe.to_constr t))); + ppdebug(lazy Pp.(str"rewrule="++pr_econstr_pat env sigma t)); match EConstr.kind sigma t with | Prod (_, xt, at) -> let sigma = Evd.create_evar_defs sigma in @@ -532,8 +538,8 @@ let rwprocess_rule dir rule gl = sigma, (d, r', lhs, rhs) :: rs | _ -> if red = 0 then loop d sigma r t rs 1 - else errorstrm Pp.(str "not a rewritable relation: " ++ pr_constr_pat (EConstr.Unsafe.to_constr t) - ++ spc() ++ str "in rule " ++ pr_constr_pat (EConstr.Unsafe.to_constr (snd rule))) + else errorstrm Pp.(str "not a rewritable relation: " ++ pr_econstr_pat env sigma t + ++ spc() ++ str "in rule " ++ pr_econstr_pat env sigma (snd rule)) in let sigma, r = rule in let t = Retyping.get_type_of env sigma r in @@ -547,9 +553,9 @@ let rwrxtac occ rdx_pat dir rule gl = let find_rule rdx = let rec rwtac = function | [] -> - errorstrm Pp.(str "pattern " ++ pr_constr_pat (EConstr.Unsafe.to_constr rdx) ++ + errorstrm Pp.(str "pattern " ++ pr_econstr_pat env (project gl) rdx ++ str " does not match " ++ pr_dir_side dir ++ - str " of " ++ pr_constr_pat (EConstr.Unsafe.to_constr (snd rule))) + str " of " ++ pr_econstr_pat env (project gl) (snd rule)) | (d, r, lhs, rhs) :: rs -> try let ise = unify_HO env (Evd.create_evar_defs r_sigma) lhs rdx in @@ -640,7 +646,7 @@ let ssrrewritetac ist rwargs = let unfoldtac occ ko t kt gl = let env = pf_env gl in let cl, c = pf_fill_occ_term gl occ (fst (strip_unfold_term env t kt)) in - let cl' = EConstr.Vars.subst1 (pf_unfoldn [OnlyOccurrences [1], get_evalref (project gl) c] gl c) cl in + let cl' = EConstr.Vars.subst1 (pf_unfoldn [OnlyOccurrences [1], get_evalref env (project gl) c] gl c) cl in let f = if ko = None then CClosure.betaiotazeta else CClosure.betaiota in Proofview.V82.of_tactic (convert_concl (pf_reduce (Reductionops.clos_norm_flags f) gl cl')) gl diff --git a/plugins/ssr/ssrfwd.ml b/plugins/ssr/ssrfwd.ml index 9ea35b8694..3cadc92bcc 100644 --- a/plugins/ssr/ssrfwd.ml +++ b/plugins/ssr/ssrfwd.ml @@ -50,7 +50,7 @@ let ssrsettac id ((_, (pat, pty)), (_, occ)) gl = let c = EConstr.of_constr c in let cl = EConstr.of_constr cl in if Termops.occur_existential sigma c then errorstrm(str"The pattern"++spc()++ - pr_constr_pat (EConstr.Unsafe.to_constr c)++spc()++str"did not match and has holes."++spc()++ + pr_econstr_pat env sigma c++spc()++str"did not match and has holes."++spc()++ str"Did you mean pose?") else let c, (gl, cty) = match EConstr.kind sigma c with | Cast(t, DEFAULTcast, ty) -> t, (gl, ty) diff --git a/plugins/ssr/ssripats.ml b/plugins/ssr/ssripats.ml index e9fe1f3e48..3481b25c8b 100644 --- a/plugins/ssr/ssripats.ml +++ b/plugins/ssr/ssripats.ml @@ -369,18 +369,20 @@ let tac_intro_seed interp_ipats fix = Goal.enter begin fun gl -> end end (*** [=> [: id]] ************************************************************) -[@@@ocaml.warning "-3"] let mk_abstract_id = let open Coqlib in let ssr_abstract_id = Summary.ref ~name:"SSR:abstractid" 0 in -begin fun () -> +begin fun env sigma -> + let sigma, zero = EConstr.fresh_global env sigma (lib_ref "num.nat.O") in + let sigma, succ = EConstr.fresh_global env sigma (lib_ref "num.nat.S") in let rec nat_of_n n = - if n = 0 then EConstr.mkConstruct path_of_O - else EConstr.mkApp (EConstr.mkConstruct path_of_S, [|nat_of_n (n-1)|]) in - incr ssr_abstract_id; nat_of_n !ssr_abstract_id + if n = 0 then zero + else EConstr.mkApp (succ, [|nat_of_n (n-1)|]) in + incr ssr_abstract_id; + sigma, nat_of_n !ssr_abstract_id end -let tcltclMK_ABSTRACT_VAR id = Goal.enter begin fun gl -> +let tclMK_ABSTRACT_VAR id = Goal.enter begin fun gl -> let env, concl = Goal.(env gl, concl gl) in let step = begin fun sigma -> let (sigma, (abstract_proof, abstract_ty)) = @@ -389,8 +391,8 @@ let tcltclMK_ABSTRACT_VAR id = Goal.enter begin fun gl -> let (sigma, ablock) = Ssrcommon.mkSsrConst "abstract_lock" env sigma in let (sigma, lock) = Evarutil.new_evar env sigma ablock in let (sigma, abstract) = Ssrcommon.mkSsrConst "abstract" env sigma in - let abstract_ty = - EConstr.mkApp(abstract, [|ty;mk_abstract_id ();lock|]) in + let (sigma, abstract_id) = mk_abstract_id env sigma in + let abstract_ty = EConstr.mkApp(abstract, [|ty; abstract_id; lock|]) in let sigma, m = Evarutil.new_evar env sigma abstract_ty in sigma, (m, abstract_ty) in let sigma, kont = @@ -409,7 +411,7 @@ end let tclMK_ABSTRACT_VARS ids = List.fold_right (fun id tac -> - Tacticals.New.tclTHENFIRST (tcltclMK_ABSTRACT_VAR id) tac) ids (tclUNIT ()) + Tacticals.New.tclTHENFIRST (tclMK_ABSTRACT_VAR id) tac) ids (tclUNIT ()) (* Debugging *) let tclLOG p t = diff --git a/plugins/ssr/ssrparser.mlg b/plugins/ssr/ssrparser.mlg index 2a2cd73df2..0ec5f1673a 100644 --- a/plugins/ssr/ssrparser.mlg +++ b/plugins/ssr/ssrparser.mlg @@ -74,11 +74,11 @@ let frozen_lexer = CLexer.get_keyword_state () ;; let tacltop = (5,Notation_gram.E) -let pr_ssrtacarg _ _ prt = prt tacltop +let pr_ssrtacarg env sigma _ _ prt = prt env sigma tacltop } -ARGUMENT EXTEND ssrtacarg TYPED AS tactic PRINTED BY { pr_ssrtacarg } +ARGUMENT EXTEND ssrtacarg TYPED AS tactic PRINTED BY { pr_ssrtacarg env sigma } | [ "YouShouldNotTypeThis" ] -> { CErrors.anomaly (Pp.str "Grammar placeholder match") } END GRAMMAR EXTEND Gram @@ -89,12 +89,12 @@ END { (* Lexically closed tactic for tacticals. *) -let pr_ssrtclarg _ _ prt tac = prt tacltop tac +let pr_ssrtclarg env sigma _ _ prt tac = prt env sigma tacltop tac } ARGUMENT EXTEND ssrtclarg TYPED AS ssrtacarg - PRINTED BY { pr_ssrtclarg } + PRINTED BY { pr_ssrtclarg env sigma } | [ ssrtacarg(tac) ] -> { tac } END @@ -109,7 +109,7 @@ let add_genarg tag pr = let glob ist x = (ist, x) in let subst _ x = x in let interp ist x = Ftactic.return (Geninterp.Val.Dyn (tag, x)) in - let gen_pr _ _ _ = pr in + let gen_pr env sigma _ _ _ = pr env sigma in let () = Genintern.register_intern0 wit glob in let () = Genintern.register_subst0 wit subst in let () = Geninterp.register_interp0 wit interp in @@ -146,7 +146,7 @@ let pr_list = prlist_with_sep let pr_ssrhyp _ _ _ = pr_hyp -let wit_ssrhyprep = add_genarg "ssrhyprep" pr_hyp +let wit_ssrhyprep = add_genarg "ssrhyprep" (fun env sigma -> pr_hyp) let intern_hyp ist (SsrHyp (loc, id) as hyp) = let _ = Tacintern.intern_genarg ist (in_gen (rawwit wit_var) CAst.(make ?loc id)) in @@ -168,7 +168,7 @@ END let pr_hoi = hoik pr_hyp let pr_ssrhoi _ _ _ = pr_hoi -let wit_ssrhoirep = add_genarg "ssrhoirep" pr_hoi +let wit_ssrhoirep = add_genarg "ssrhoirep" (fun env sigma -> pr_hoi) let intern_ssrhoi ist = function | Hyp h -> Hyp (intern_hyp ist h) @@ -212,13 +212,13 @@ END let pr_rwdir = function L2R -> mt() | R2L -> str "-" -let wit_ssrdir = add_genarg "ssrdir" pr_dir +let wit_ssrdir = add_genarg "ssrdir" (fun env sigma -> pr_dir) (** Simpl switch *) let pr_ssrsimpl _ _ _ = pr_simpl -let wit_ssrsimplrep = add_genarg "ssrsimplrep" pr_simpl +let wit_ssrsimplrep = add_genarg "ssrsimplrep" (fun env sigma -> pr_simpl) let test_ssrslashnum b1 b2 strm = match Util.stream_nth 0 strm with @@ -413,7 +413,7 @@ END let pr_mmod = function May -> str "?" | Must -> str "!" | Once -> mt () -let wit_ssrmmod = add_genarg "ssrmmod" pr_mmod +let wit_ssrmmod = add_genarg "ssrmmod" (fun env sigma -> pr_mmod) let ssrmmod = Pcoq.create_generic_entry Pcoq.utactic "ssrmmod" (Genarg.rawwit wit_ssrmmod);; } @@ -643,7 +643,7 @@ and map_block map_id = function | SuffixNum _ as x -> x type ssripatrep = ssripat -let wit_ssripatrep = add_genarg "ssripatrep" pr_ipat +let wit_ssripatrep = add_genarg "ssripatrep" (fun env sigma -> pr_ipat) let pr_ssripat _ _ _ = pr_ipat let pr_ssripats _ _ _ = pr_ipats @@ -950,13 +950,13 @@ END { -let pr_ssrintrosarg _ _ prt (tac, ipats) = - prt tacltop tac ++ pr_intros spc ipats +let pr_ssrintrosarg env sigma _ _ prt (tac, ipats) = + prt env sigma tacltop tac ++ pr_intros spc ipats } ARGUMENT EXTEND ssrintrosarg TYPED AS (tactic * ssrintros) - PRINTED BY { pr_ssrintrosarg } + PRINTED BY { pr_ssrintrosarg env sigma } | [ "YouShouldNotTypeThis" ssrtacarg(arg) ssrintros_ne(ipats) ] -> { arg, ipats } END @@ -1007,22 +1007,22 @@ GRAMMAR EXTEND Gram { -let pr_ortacs prt = +let pr_ortacs env sigma prt = let rec pr_rec = function | [None] -> spc() ++ str "|" ++ spc() | None :: tacs -> spc() ++ str "|" ++ pr_rec tacs - | Some tac :: tacs -> spc() ++ str "| " ++ prt tacltop tac ++ pr_rec tacs + | Some tac :: tacs -> spc() ++ str "| " ++ prt env sigma tacltop tac ++ pr_rec tacs | [] -> mt() in function | [None] -> spc() | None :: tacs -> pr_rec tacs - | Some tac :: tacs -> prt tacltop tac ++ pr_rec tacs + | Some tac :: tacs -> prt env sigma tacltop tac ++ pr_rec tacs | [] -> mt() -let pr_ssrortacs _ _ = pr_ortacs +let pr_ssrortacs env sigma _ _ = pr_ortacs env sigma } -ARGUMENT EXTEND ssrortacs TYPED AS tactic option list PRINTED BY { pr_ssrortacs } +ARGUMENT EXTEND ssrortacs TYPED AS tactic option list PRINTED BY { pr_ssrortacs env sigma } | [ ssrtacarg(tac) "|" ssrortacs(tacs) ] -> { Some tac :: tacs } | [ ssrtacarg(tac) "|" ] -> { [Some tac; None] } | [ ssrtacarg(tac) ] -> { [Some tac] } @@ -1032,34 +1032,34 @@ END { -let pr_hintarg prt = function - | true, tacs -> hv 0 (str "[ " ++ pr_ortacs prt tacs ++ str " ]") - | false, [Some tac] -> prt tacltop tac +let pr_hintarg env sigma prt = function + | true, tacs -> hv 0 (str "[ " ++ pr_ortacs env sigma prt tacs ++ str " ]") + | false, [Some tac] -> prt env sigma tacltop tac | _, _ -> mt() -let pr_ssrhintarg _ _ = pr_hintarg +let pr_ssrhintarg env sigma _ _ = pr_hintarg env sigma } -ARGUMENT EXTEND ssrhintarg TYPED AS (bool * ssrortacs) PRINTED BY { pr_ssrhintarg } +ARGUMENT EXTEND ssrhintarg TYPED AS (bool * ssrortacs) PRINTED BY { pr_ssrhintarg env sigma } | [ "[" "]" ] -> { nullhint } | [ "[" ssrortacs(tacs) "]" ] -> { mk_orhint tacs } | [ ssrtacarg(arg) ] -> { mk_hint arg } END -ARGUMENT EXTEND ssrortacarg TYPED AS ssrhintarg PRINTED BY { pr_ssrhintarg } +ARGUMENT EXTEND ssrortacarg TYPED AS ssrhintarg PRINTED BY { pr_ssrhintarg env sigma } | [ "[" ssrortacs(tacs) "]" ] -> { mk_orhint tacs } END { -let pr_hint prt arg = - if arg = nohint then mt() else str "by " ++ pr_hintarg prt arg -let pr_ssrhint _ _ = pr_hint +let pr_hint env sigma prt arg = + if arg = nohint then mt() else str "by " ++ pr_hintarg env sigma prt arg +let pr_ssrhint env sigma _ _ = pr_hint env sigma } -ARGUMENT EXTEND ssrhint TYPED AS ssrhintarg PRINTED BY { pr_ssrhint } +ARGUMENT EXTEND ssrhint TYPED AS ssrhintarg PRINTED BY { pr_ssrhint env sigma } | [ ] -> { nohint } END (** The "in" pseudo-tactical *) @@ -1117,7 +1117,7 @@ let pr_clseq = function | InHypsSeq -> str " |-" | InAllHyps -> str "* |-" -let wit_ssrclseq = add_genarg "ssrclseq" pr_clseq +let wit_ssrclseq = add_genarg "ssrclseq" (fun env sigma -> pr_clseq) let pr_clausehyps = pr_list pr_spc pr_wgen let pr_ssrclausehyps _ _ _ = pr_clausehyps @@ -1220,7 +1220,7 @@ let pr_fwdkind = function | FwdHint (s,_) -> str (s ^ " ") | _ -> str " :=" ++ spc () let pr_fwdfmt (fk, _ : ssrfwdfmt) = pr_fwdkind fk -let wit_ssrfwdfmt = add_genarg "ssrfwdfmt" pr_fwdfmt +let wit_ssrfwdfmt = add_genarg "ssrfwdfmt" (fun env sigma -> pr_fwdfmt) (* type ssrfwd = ssrfwdfmt * ssrterm *) @@ -1283,11 +1283,11 @@ END { -let pr_ssrbvar prc _ _ v = prc v +let pr_ssrbvar env sigma prc _ _ v = prc env sigma v } -ARGUMENT EXTEND ssrbvar TYPED AS constr PRINTED BY { pr_ssrbvar } +ARGUMENT EXTEND ssrbvar TYPED AS constr PRINTED BY { pr_ssrbvar env sigma } | [ ident(id) ] -> { mkCVar ~loc id } | [ "_" ] -> { mkCHole (Some loc) } END @@ -1299,11 +1299,11 @@ let bvar_lname = let open CAst in function CAst.make ?loc:qid.CAst.loc @@ Name (qualid_basename qid) | { loc = loc } -> CAst.make ?loc Anonymous -let pr_ssrbinder prc _ _ (_, c) = prc c +let pr_ssrbinder env sigma prc _ _ (_, c) = prc env sigma c } -ARGUMENT EXTEND ssrbinder TYPED AS (ssrfwdfmt * constr) PRINTED BY { pr_ssrbinder } +ARGUMENT EXTEND ssrbinder TYPED AS (ssrfwdfmt * constr) PRINTED BY { pr_ssrbinder env sigma } | [ ssrbvar(bv) ] -> { let { CAst.loc=xloc } as x = bvar_lname bv in (FwdPose, [BFvar]), @@ -1474,11 +1474,11 @@ END { -let pr_ssrhavefwd _ _ prt (fwd, hint) = pr_fwd fwd ++ pr_hint prt hint +let pr_ssrhavefwd env sigma _ _ prt (fwd, hint) = pr_fwd fwd ++ pr_hint env sigma prt hint } -ARGUMENT EXTEND ssrhavefwd TYPED AS (ssrfwd * ssrhint) PRINTED BY { pr_ssrhavefwd } +ARGUMENT EXTEND ssrhavefwd TYPED AS (ssrfwd * ssrhint) PRINTED BY { pr_ssrhavefwd env sigma } | [ ":" ast_closure_lterm(t) ssrhint(hint) ] -> { mkFwdHint ":" t, hint } | [ ":" ast_closure_lterm(t) ":=" ast_closure_lterm(c) ] -> { mkFwdCast FwdHave ~loc t ~c, nohint } | [ ":" ast_closure_lterm(t) ":=" ] -> { mkFwdHintNoTC ":" t, nohint } @@ -1503,14 +1503,14 @@ let binder_to_intro_id = CAst.(List.map (function | (FwdPose, [BFdef]), { v = CLetIn ({v=Anonymous},_,_,_) } -> [IPatAnon (One None)] | _ -> anomaly "ssrbinder is not a binder")) -let pr_ssrhavefwdwbinders _ _ prt (tr,((hpats, (fwd, hint)))) = - pr_hpats hpats ++ pr_fwd fwd ++ pr_hint prt hint +let pr_ssrhavefwdwbinders env sigma _ _ prt (tr,((hpats, (fwd, hint)))) = + pr_hpats hpats ++ pr_fwd fwd ++ pr_hint env sigma prt hint } ARGUMENT EXTEND ssrhavefwdwbinders TYPED AS (bool * (ssrhpats * (ssrfwd * ssrhint))) - PRINTED BY { pr_ssrhavefwdwbinders } + PRINTED BY { pr_ssrhavefwdwbinders env sigma } | [ ssrhpats_wtransp(trpats) ssrbinder_list(bs) ssrhavefwd(fwd) ] -> { let tr, pats = trpats in let ((clr, pats), binders), simpl = pats in @@ -1522,14 +1522,14 @@ END { -let pr_ssrdoarg prc _ prt (((n, m), tac), clauses) = - pr_index n ++ pr_mmod m ++ pr_hintarg prt tac ++ pr_clauses clauses +let pr_ssrdoarg env sigma prc _ prt (((n, m), tac), clauses) = + pr_index n ++ pr_mmod m ++ pr_hintarg env sigma prt tac ++ pr_clauses clauses } ARGUMENT EXTEND ssrdoarg TYPED AS (((ssrindex * ssrmmod) * ssrhintarg) * ssrclauses) - PRINTED BY { pr_ssrdoarg } + PRINTED BY { pr_ssrdoarg env sigma } | [ "YouShouldNotTypeThis" ] -> { anomaly "Grammar placeholder match" } END @@ -1537,22 +1537,22 @@ END (* type ssrseqarg = ssrindex * (ssrtacarg * ssrtac option) *) -let pr_seqtacarg prt = function +let pr_seqtacarg env sigma prt = function | (is_first, []), _ -> str (if is_first then "first" else "last") | tac, Some dtac -> - hv 0 (pr_hintarg prt tac ++ spc() ++ str "|| " ++ prt tacltop dtac) - | tac, _ -> pr_hintarg prt tac + hv 0 (pr_hintarg env sigma prt tac ++ spc() ++ str "|| " ++ prt env sigma tacltop dtac) + | tac, _ -> pr_hintarg env sigma prt tac -let pr_ssrseqarg _ _ prt = function - | ArgArg 0, tac -> pr_seqtacarg prt tac - | i, tac -> pr_index i ++ str " " ++ pr_seqtacarg prt tac +let pr_ssrseqarg env sigma _ _ prt = function + | ArgArg 0, tac -> pr_seqtacarg env sigma prt tac + | i, tac -> pr_index i ++ str " " ++ pr_seqtacarg env sigma prt tac } (* We must parse the index separately to resolve the conflict with *) (* an unindexed tactic. *) ARGUMENT EXTEND ssrseqarg TYPED AS (ssrindex * (ssrhintarg * tactic option)) - PRINTED BY { pr_ssrseqarg } + PRINTED BY { pr_ssrseqarg env sigma } | [ "YouShouldNotTypeThis" ] -> { anomaly "Grammar placeholder match" } END @@ -2278,7 +2278,7 @@ let pr_rwkind = function | RWdef -> str "/" | RWeq -> mt () -let wit_ssrrwkind = add_genarg "ssrrwkind" pr_rwkind +let wit_ssrrwkind = add_genarg "ssrrwkind" (fun env sigma -> pr_rwkind) let pr_rule = function | RWred s, _ -> pr_simpl s @@ -2520,13 +2520,13 @@ END { -let pr_ssrsufffwdwbinders _ _ prt (hpats, (fwd, hint)) = - pr_hpats hpats ++ pr_fwd fwd ++ pr_hint prt hint +let pr_ssrsufffwdwbinders env sigma _ _ prt (hpats, (fwd, hint)) = + pr_hpats hpats ++ pr_fwd fwd ++ pr_hint env sigma prt hint } ARGUMENT EXTEND ssrsufffwd - TYPED AS (ssrhpats * (ssrfwd * ssrhint)) PRINTED BY { pr_ssrsufffwdwbinders } + TYPED AS (ssrhpats * (ssrfwd * ssrhint)) PRINTED BY { pr_ssrsufffwdwbinders env sigma } | [ ssrhpats(pats) ssrbinder_list(bs) ":" ast_closure_lterm(t) ssrhint(hint) ] -> { let ((clr, pats), binders), simpl = pats in let allbs = intro_id_to_binder binders @ bs in diff --git a/plugins/ssr/ssrparser.mli b/plugins/ssr/ssrparser.mli index 7844050272..4a872be6a5 100644 --- a/plugins/ssr/ssrparser.mli +++ b/plugins/ssr/ssrparser.mli @@ -14,13 +14,15 @@ open Ltac_plugin val ssrtacarg : Tacexpr.raw_tactic_expr Pcoq.Entry.t val wit_ssrtacarg : (Tacexpr.raw_tactic_expr, Tacexpr.glob_tactic_expr, Geninterp.Val.t) Genarg.genarg_type -val pr_ssrtacarg : 'a -> 'b -> (Notation_gram.tolerability -> 'c) -> 'c +val pr_ssrtacarg : Environ.env -> Evd.evar_map -> 'a -> 'b -> + (Environ.env -> Evd.evar_map -> Notation_gram.tolerability -> 'c) -> 'c val ssrtclarg : Tacexpr.raw_tactic_expr Pcoq.Entry.t val wit_ssrtclarg : (Tacexpr.raw_tactic_expr, Tacexpr.glob_tactic_expr, Geninterp.Val.t) Genarg.genarg_type -val pr_ssrtclarg : 'a -> 'b -> (Notation_gram.tolerability -> 'c -> 'd) -> 'c -> 'd +val pr_ssrtclarg : Environ.env -> Evd.evar_map -> 'a -> 'b -> + (Environ.env -> Evd.evar_map -> Notation_gram.tolerability -> 'c -> 'd) -> 'c -> 'd -val add_genarg : string -> ('a -> Pp.t) -> 'a Genarg.uniform_genarg_type +val add_genarg : string -> (Environ.env -> Evd.evar_map -> 'a -> Pp.t) -> 'a Genarg.uniform_genarg_type (* Parsing witnesses, needed to serialize ssreflect syntax *) open Ssrmatching_plugin diff --git a/plugins/ssr/ssrprinters.ml b/plugins/ssr/ssrprinters.ml index 38f5b7d107..5d8c94e49b 100644 --- a/plugins/ssr/ssrprinters.ml +++ b/plugins/ssr/ssrprinters.ml @@ -57,11 +57,17 @@ let pr_guarded guard prc c = let s = Format.flush_str_formatter () ^ "$" in if guard s (skip_wschars s 0) then pr_paren prc c else prc c -let prl_constr_expr = Ppconstr.pr_lconstr_expr +let prl_constr_expr = + let env = Global.env () in + let sigma = Evd.from_env env in + Ppconstr.pr_lconstr_expr env sigma let pr_glob_constr c = Printer.pr_glob_constr_env (Global.env ()) c let prl_glob_constr c = Printer.pr_lglob_constr_env (Global.env ()) c let pr_glob_constr_and_expr = function - | _, Some c -> Ppconstr.pr_constr_expr c + | _, Some c -> + let env = Global.env () in + let sigma = Evd.from_env env in + Ppconstr.pr_constr_expr env sigma c | c, None -> pr_glob_constr c let pr_term (k, c) = pr_guarded (guard_term k) pr_glob_constr_and_expr c @@ -91,7 +97,10 @@ let pr_simpl = function (* New terms *) -let pr_ast_closure_term { body } = Ppconstr.pr_constr_expr body +let pr_ast_closure_term { body } = + let env = Global.env () in + let sigma = Evd.from_env env in + Ppconstr.pr_constr_expr env sigma body let pr_view2 = pr_list mt (fun c -> str "/" ++ pr_ast_closure_term c) diff --git a/plugins/ssr/ssrvernac.mlg b/plugins/ssr/ssrvernac.mlg index 2e1554d496..0a0d9b12fa 100644 --- a/plugins/ssr/ssrvernac.mlg +++ b/plugins/ssr/ssrvernac.mlg @@ -198,13 +198,13 @@ type raw_glob_search_about_item = | RGlobSearchSubPattern of constr_expr | RGlobSearchString of Loc.t * string * string option -let pr_search_item = function +let pr_search_item env sigma = function | RGlobSearchString (_,s,_) -> str s - | RGlobSearchSubPattern p -> pr_constr_expr p + | RGlobSearchSubPattern p -> pr_constr_expr env sigma p let wit_ssr_searchitem = add_genarg "ssr_searchitem" pr_search_item -let pr_ssr_search_item _ _ _ = pr_search_item +let pr_ssr_search_item env sigma _ _ _ = pr_search_item env sigma (* Workaround the notation API that can only print notations *) @@ -316,7 +316,7 @@ let interp_search_notation ?loc tag okey = } ARGUMENT EXTEND ssr_search_item TYPED AS ssr_searchitem - PRINTED BY { pr_ssr_search_item } + PRINTED BY { pr_ssr_search_item env sigma } | [ string(s) ] -> { RGlobSearchString (loc,s,None) } | [ string(s) "%" preident(key) ] -> { RGlobSearchString (loc,s,Some key) } | [ constr_pattern(p) ] -> { RGlobSearchSubPattern p } @@ -324,14 +324,14 @@ END { -let pr_ssr_search_arg _ _ _ = - let pr_item (b, p) = str (if b then "-" else "") ++ pr_search_item p in +let pr_ssr_search_arg env sigma _ _ _ = + let pr_item (b, p) = str (if b then "-" else "") ++ pr_search_item env sigma p in pr_list spc pr_item } ARGUMENT EXTEND ssr_search_arg TYPED AS (bool * ssr_searchitem) list - PRINTED BY { pr_ssr_search_arg } + PRINTED BY { pr_ssr_search_arg env sigma } | [ "-" ssr_search_item(p) ssr_search_arg(a) ] -> { (false, p) :: a } | [ ssr_search_item(p) ssr_search_arg(a) ] -> { (true, p) :: a } | [ ] -> { [] } @@ -432,7 +432,7 @@ let interp_search_arg arg = let pr_modloc (b, m) = if b then str "-" ++ pr_qualid m else pr_qualid m -let wit_ssrmodloc = add_genarg "ssrmodloc" pr_modloc +let wit_ssrmodloc = add_genarg "ssrmodloc" (fun env sigma -> pr_modloc) let pr_ssr_modlocs _ _ _ ml = if ml = [] then str "" else spc () ++ str "in " ++ pr_list spc pr_modloc ml @@ -491,24 +491,23 @@ END { -let pr_raw_ssrhintref prc _ _ = let open CAst in function +let pr_raw_ssrhintref env sigma prc _ _ = let open CAst in function | { v = CAppExpl ((None, r,x), args) } when isCHoles args -> - prc (CAst.make @@ CRef (r,x)) ++ str "|" ++ int (List.length args) - | { v = CApp ((_, { v = CRef _ }), _) } as c -> prc c + prc env sigma (CAst.make @@ CRef (r,x)) ++ str "|" ++ int (List.length args) + | { v = CApp ((_, { v = CRef _ }), _) } as c -> prc env sigma c | { v = CApp ((_, c), args) } when isCxHoles args -> - prc c ++ str "|" ++ int (List.length args) - | c -> prc c + prc env sigma c ++ str "|" ++ int (List.length args) + | c -> prc env sigma c -let pr_rawhintref c = - let _, env = Pfedit.get_current_context () in +let pr_rawhintref env sigma c = match DAst.get c with | GApp (f, args) when isRHoles args -> pr_glob_constr_env env f ++ str "|" ++ int (List.length args) | _ -> pr_glob_constr_env env c -let pr_glob_ssrhintref _ _ _ (c, _) = pr_rawhintref c +let pr_glob_ssrhintref env sigma _ _ _ (c, _) = pr_rawhintref env sigma c -let pr_ssrhintref prc _ _ = prc +let pr_ssrhintref env sigma prc _ _ = prc env sigma let mkhintref ?loc c n = match c.CAst.v with | CRef (r,x) -> CAst.make ?loc @@ CAppExpl ((None, r, x), mkCHoles ?loc n) @@ -518,9 +517,9 @@ let mkhintref ?loc c n = match c.CAst.v with ARGUMENT EXTEND ssrhintref TYPED AS constr - PRINTED BY { pr_ssrhintref } - RAW_PRINTED BY { pr_raw_ssrhintref } - GLOB_PRINTED BY { pr_glob_ssrhintref } + PRINTED BY { pr_ssrhintref env sigma } + RAW_PRINTED BY { pr_raw_ssrhintref env sigma } + GLOB_PRINTED BY { pr_glob_ssrhintref env sigma } | [ constr(c) ] -> { c } | [ constr(c) "|" natural(n) ] -> { mkhintref ~loc c n } END @@ -559,22 +558,29 @@ END { -let print_view_hints kind l = +let print_view_hints env sigma kind l = let pp_viewname = str "Hint View" ++ pr_viewpos (Some kind) ++ str " " in - let pp_hints = pr_list spc pr_rawhintref l in + let pp_hints = pr_list spc (pr_rawhintref env sigma) l in Feedback.msg_info (pp_viewname ++ hov 0 pp_hints ++ Pp.cut ()) } VERNAC COMMAND EXTEND PrintView CLASSIFIED AS QUERY -| [ "Print" "Hint" "View" ssrviewpos(i) ] -> - { match i with - | Some k -> print_view_hints k (Ssrview.AdaptorDb.get k) +| ![proof] [ "Print" "Hint" "View" ssrviewpos(i) ] -> + { + fun ~pstate -> + (* XXX this is incorrect *) + let sigma, env = Option.cata Pfedit.get_current_context + (let e = Global.env () in Evd.from_env e, e) pstate in + (match i with + | Some k -> + print_view_hints env sigma k (Ssrview.AdaptorDb.get k) | None -> - List.iter (fun k -> print_view_hints k (Ssrview.AdaptorDb.get k)) + List.iter (fun k -> print_view_hints env sigma k (Ssrview.AdaptorDb.get k)) [ Ssrview.AdaptorDb.Forward; Ssrview.AdaptorDb.Backward; - Ssrview.AdaptorDb.Equivalence ] + Ssrview.AdaptorDb.Equivalence ]); + pstate } END diff --git a/plugins/ssrmatching/ssrmatching.ml b/plugins/ssrmatching/ssrmatching.ml index b83a6a34cb..1deb935d5c 100644 --- a/plugins/ssrmatching/ssrmatching.ml +++ b/plugins/ssrmatching/ssrmatching.ml @@ -97,14 +97,20 @@ let prl_glob_constr c = pr_lglob_constr_env (Global.env ()) c let pr_glob_constr c = pr_glob_constr_env (Global.env ()) c let prl_constr_expr = pr_lconstr_expr let pr_constr_expr = pr_constr_expr -let prl_glob_constr_and_expr = function - | _, Some c -> prl_constr_expr c +let prl_glob_constr_and_expr env sigma = function + | _, Some c -> prl_constr_expr env sigma c | c, None -> prl_glob_constr c -let pr_glob_constr_and_expr = function - | _, Some c -> pr_constr_expr c +let pr_glob_constr_and_expr env sigma = function + | _, Some c -> pr_constr_expr env sigma c | c, None -> pr_glob_constr c -let pr_term (k, c, _) = pr_guarded (guard_term k) pr_glob_constr_and_expr c -let prl_term (k, c, _) = pr_guarded (guard_term k) prl_glob_constr_and_expr c +let pr_term (k, c, _) = + let env = Global.env () in + let sigma = Evd.from_env env in + pr_guarded (guard_term k) (pr_glob_constr_and_expr env sigma) c +let prl_term (k, c, _) = + let env = Global.env () in + let sigma = Evd.from_env env in + pr_guarded (guard_term k) (prl_glob_constr_and_expr env sigma) c (** Adding a new uninterpreted generic argument type *) let add_genarg tag pr = @@ -113,7 +119,7 @@ let add_genarg tag pr = let glob ist x = (ist, x) in let subst _ x = x in let interp ist x = Ftactic.return (Geninterp.Val.Dyn (tag, x)) in - let gen_pr _ _ _ = pr in + let gen_pr env sigma _ _ _ = pr env sigma in let () = Genintern.register_intern0 wit glob in let () = Genintern.register_subst0 wit subst in let () = Geninterp.register_interp0 wit interp in @@ -362,12 +368,17 @@ let isRigid c = match kind c with | _ -> false let hole_var = mkVar (Id.of_string "_") -let pr_constr_pat c0 = +let pr_constr_pat env sigma c0 = let rec wipe_evar c = if isEvar c then hole_var else map wipe_evar c in - let sigma, env = Pfedit.get_current_context () in pr_constr_env env sigma (wipe_evar c0) +let ehole_var = EConstr.mkVar (Id.of_string "_") +let pr_econstr_pat env sigma c0 = + let rec wipe_evar c = let open EConstr in + if isEvar sigma c then ehole_var else map sigma wipe_evar c in + pr_econstr_env env sigma (wipe_evar c0) + (* Turn (new) evars into metas *) let evars_for_FO ~hack env sigma0 (ise0:evar_map) c0 = let ise = ref ise0 in @@ -417,7 +428,7 @@ let mk_tpattern ?p_origin ?(hack=false) env sigma0 (ise, t) ok dir p = (match p_origin with None -> CErrors.user_err Pp.(str "indeterminate pattern") | Some (dir, rule) -> errorstrm (str "indeterminate " ++ pr_dir_side dir - ++ str " in " ++ pr_constr_pat rule)) + ++ str " in " ++ pr_constr_pat env ise rule)) | LetIn (_, v, _, b) -> if b <> mkRel 1 then KpatLet, f, a else KpatFlex, v, a | Lambda _ -> KpatLam, f, a @@ -637,8 +648,8 @@ let assert_done r = let assert_done_multires r = match !r with | None -> CErrors.anomaly (str"do_once never called.") - | Some (n, xs) -> - r := Some (n+1,xs); + | Some (e, n, xs) -> + r := Some (e, n+1,xs); try List.nth xs n with Failure _ -> raise NoMatch type subst = Environ.env -> constr -> constr -> int -> constr @@ -684,14 +695,14 @@ let mk_tpattern_matcher ?(all_instances=false) | _ -> false) | _ -> unif_EQ env sigma u.up_f in let p2t p = mkApp(p.up_f,p.up_a) in -let source () = match upats_origin, upats with +let source env = match upats_origin, upats with | None, [p] -> (if fixed_upat ise p then str"term " else str"partial term ") ++ - pr_constr_pat (p2t p) ++ spc() + pr_constr_pat env ise (p2t p) ++ spc() | Some (dir,rule), [p] -> str"The " ++ pr_dir_side dir ++ str" of " ++ - pr_constr_pat rule ++ fnl() ++ ws 4 ++ pr_constr_pat (p2t p) ++ fnl() + pr_constr_pat env ise rule ++ fnl() ++ ws 4 ++ pr_constr_pat env ise (p2t p) ++ fnl() | Some (dir,rule), _ -> str"The " ++ pr_dir_side dir ++ str" of " ++ - pr_constr_pat rule ++ spc() + pr_constr_pat env ise rule ++ spc() | _, [] | None, _::_::_ -> CErrors.anomaly (str"mk_tpattern_matcher with no upats_origin.") in let on_instance, instances = @@ -721,23 +732,23 @@ let rec uniquize = function if not all_instances then match_upats_FO upats env sigma0 ise c; failed_because_of_TC:=match_upats_HO ~on_instance upats env sigma0 ise c; raise NoMatch - with FoundUnif sigma_u -> 0,[sigma_u] + with FoundUnif sigma_u -> env,0,[sigma_u] | (NoMatch|NoProgress) when all_instances && instances () <> [] -> - 0, uniquize (instances ()) + env, 0, uniquize (instances ()) | NoMatch when (not raise_NoMatch) -> if !failed_because_of_TC then - errorstrm (source ()++strbrk"matches but type classes inference fails") + errorstrm (source env ++ strbrk"matches but type classes inference fails") else - errorstrm (source () ++ str "does not match any subterm of the goal") + errorstrm (source env ++ str "does not match any subterm of the goal") | NoProgress when (not raise_NoMatch) -> let dir = match upats_origin with Some (d,_) -> d | _ -> CErrors.anomaly (str"mk_tpattern_matcher with no upats_origin.") in - errorstrm (str"all matches of "++source()++ + errorstrm (str"all matches of "++ source env ++ str"are equal to the " ++ pr_dir_side (inv_dir dir)) | NoProgress -> raise NoMatch); let sigma, _, ({up_f = pf; up_a = pa} as u) = if all_instances then assert_done_multires upat_that_matched - else List.hd (snd(assert_done upat_that_matched)) in + else List.hd (pi3(assert_done upat_that_matched)) in (* pp(lazy(str"sigma@tmatch=" ++ pr_evar_map None sigma)); *) if !skip_occ then ((*ignore(k env u.up_t 0);*) c) else let match_EQ = match_EQ env sigma u in @@ -766,18 +777,18 @@ let rec uniquize = function mkApp (f', Array.map_left (subst_loop acc) a) in subst_loop (env,h) c) : find_P), ((fun () -> - let sigma, uc, ({up_f = pf; up_a = pa} as u) = + let env, (sigma, uc, ({up_f = pf; up_a = pa} as u)) = match !upat_that_matched with - | Some (_,x) -> List.hd x | None when raise_NoMatch -> raise NoMatch + | Some (env,_,x) -> env,List.hd x | None when raise_NoMatch -> raise NoMatch | None -> CErrors.anomaly (str"companion function never called.") in let p' = mkApp (pf, pa) in if max_occ <= !nocc then p', u.up_dir, (sigma, uc, u.up_t) else errorstrm (str"Only " ++ int !nocc ++ str" < " ++ int max_occ ++ str(String.plural !nocc " occurrence") ++ match upats_origin with - | None -> str" of" ++ spc() ++ pr_constr_pat p' + | None -> str" of" ++ spc() ++ pr_constr_pat env sigma p' | Some (dir,rule) -> str" of the " ++ pr_dir_side dir ++ fnl() ++ - ws 4 ++ pr_constr_pat p' ++ fnl () ++ - str"of " ++ pr_constr_pat rule)) : conclude) + ws 4 ++ pr_constr_pat env sigma p' ++ fnl () ++ + str"of " ++ pr_constr_pat env sigma rule)) : conclude) type ('ident, 'term) ssrpattern = | T of 'term @@ -816,11 +827,11 @@ let pr_pattern_aux pr_constr = function pr_constr e ++ str " in " ++ pr_constr x ++ str " in " ++ pr_constr t | E_As_X_In_T (e,x,t) -> pr_constr e ++ str " as " ++ pr_constr x ++ str " in " ++ pr_constr t -let pp_pattern (sigma, p) = - pr_pattern_aux (fun t -> pr_constr_pat (EConstr.Unsafe.to_constr (pi3 (nf_open_term sigma sigma (EConstr.of_constr t))))) p +let pp_pattern env (sigma, p) = + pr_pattern_aux (fun t -> pr_econstr_pat env sigma (pi3 (nf_open_term sigma sigma (EConstr.of_constr t)))) p let pr_cpattern = pr_term -let wit_rpatternty = add_genarg "rpatternty" pr_pattern +let wit_rpatternty = add_genarg "rpatternty" (fun env sigma -> pr_pattern) let glob_ssrterm gs = function | k, (_, Some c), None -> @@ -1247,7 +1258,7 @@ let fill_occ_term env cl occ sigma0 (sigma, t) = if sigma' != sigma0 then raise NoMatch else cl, (Evd.merge_universe_context sigma' uc, t') with _ -> - errorstrm (str "partial term " ++ pr_constr_pat (EConstr.Unsafe.to_constr t) + errorstrm (str "partial term " ++ pr_econstr_pat env sigma t ++ str " does not match any subterm of the goal") let pf_fill_occ_term gl occ t = @@ -1256,7 +1267,7 @@ let pf_fill_occ_term gl occ t = cl, t let cpattern_of_id id = - ' ', (DAst.make @@ GRef (VarRef id, None), None), Some Geninterp.({ lfun = Id.Map.empty; extra = Tacinterp.TacStore.empty }) + ' ', (DAst.make @@ GRef (VarRef id, None), None), Some Geninterp.({ lfun = Id.Map.empty; poly = false; extra = Tacinterp.TacStore.empty }) let is_wildcard ((_, (l, r), _) : cpattern) : bool = match DAst.get l, r with | _, Some { CAst.v = CHole _ } | GHole _, None -> true diff --git a/plugins/ssrmatching/ssrmatching.mli b/plugins/ssrmatching/ssrmatching.mli index ff2c900130..25975c84e8 100644 --- a/plugins/ssrmatching/ssrmatching.mli +++ b/plugins/ssrmatching/ssrmatching.mli @@ -46,7 +46,7 @@ type ('ident, 'term) ssrpattern = | E_As_X_In_T of 'term * 'ident * 'term type pattern = evar_map * (constr, constr) ssrpattern -val pp_pattern : pattern -> Pp.t +val pp_pattern : env -> pattern -> Pp.t (** Extracts the redex and applies to it the substitution part of the pattern. @raise Anomaly if called on [In_T] or [In_X_In_T] *) @@ -222,7 +222,8 @@ val loc_of_cpattern : cpattern -> Loc.t option val id_of_pattern : pattern -> Names.Id.t option val is_wildcard : cpattern -> bool val cpattern_of_id : Names.Id.t -> cpattern -val pr_constr_pat : constr -> Pp.t +val pr_constr_pat : env -> evar_map -> constr -> Pp.t +val pr_econstr_pat : env -> evar_map -> econstr -> Pp.t val pf_merge_uc : UState.t -> goal Evd.sigma -> goal Evd.sigma val pf_unsafe_merge_uc : UState.t -> goal Evd.sigma -> goal Evd.sigma diff --git a/plugins/syntax/g_numeral.mlg b/plugins/syntax/g_numeral.mlg index 13e0bcbd47..baa4ae0306 100644 --- a/plugins/syntax/g_numeral.mlg +++ b/plugins/syntax/g_numeral.mlg @@ -35,7 +35,23 @@ ARGUMENT EXTEND numnotoption END VERNAC COMMAND EXTEND NumeralNotation CLASSIFIED AS SIDEFF - | #[ locality = Attributes.locality; ] [ "Numeral" "Notation" reference(ty) reference(f) reference(g) ":" + | #[ locality = Attributes.locality; ] ![proof][ "Numeral" "Notation" reference(ty) reference(f) reference(g) ":" ident(sc) numnotoption(o) ] -> - { vernac_numeral_notation (Locality.make_module_locality locality) ty f g (Id.to_string sc) o } + + { (* It is a bug to use the proof context here, but at the request of + * the reviewers we keep this broken behavior for now. The Global env + * should be used instead, and the `env, sigma` parameteter to the + * numeral notation command removed. + *) + fun ~pstate -> + let sigma, env = match pstate with + | None -> + let env = Global.env () in + let sigma = Evd.from_env env in + sigma, env + | Some pstate -> + Pfedit.get_current_context pstate + in + vernac_numeral_notation env sigma (Locality.make_module_locality locality) ty f g (Id.to_string sc) o; + pstate } END diff --git a/plugins/syntax/g_string.mlg b/plugins/syntax/g_string.mlg index 1e06cd8ddb..cc8c13a84b 100644 --- a/plugins/syntax/g_string.mlg +++ b/plugins/syntax/g_string.mlg @@ -19,7 +19,22 @@ open Stdarg } VERNAC COMMAND EXTEND StringNotation CLASSIFIED AS SIDEFF - | #[ locality = Attributes.locality; ] [ "String" "Notation" reference(ty) reference(f) reference(g) ":" + | #[ locality = Attributes.locality; ] ![proof] [ "String" "Notation" reference(ty) reference(f) reference(g) ":" ident(sc) ] -> - { vernac_string_notation (Locality.make_module_locality locality) ty f g (Id.to_string sc) } + { (* It is a bug to use the proof context here, but at the request of + * the reviewers we keep this broken behavior for now. The Global env + * should be used instead, and the `env, sigma` parameteter to the + * numeral notation command removed. + *) + fun ~pstate -> + let sigma, env = match pstate with + | None -> + let env = Global.env () in + let sigma = Evd.from_env env in + sigma, env + | Some pstate -> + Pfedit.get_current_context pstate + in + vernac_string_notation env sigma (Locality.make_module_locality locality) ty f g (Id.to_string sc); + pstate } END diff --git a/plugins/syntax/numeral.ml b/plugins/syntax/numeral.ml index 0c6d2ac0d1..525056e5f1 100644 --- a/plugins/syntax/numeral.ml +++ b/plugins/syntax/numeral.ml @@ -77,8 +77,7 @@ let locate_int63 () = Some (mkRefC q_int63) else None -let has_type f ty = - let (sigma, env) = Pfedit.get_current_context () in +let has_type env sigma f ty = let c = mkCastC (mkRefC f, Glob_term.CastConv ty) in try let _ = Constrintern.interp_constr env sigma c in true with Pretype_errors.PretypeError _ -> false @@ -95,7 +94,7 @@ let type_error_of g ty = str " to Decimal.int or (option Decimal.int)." ++ fnl () ++ str "Instead of Decimal.int, the types Decimal.uint or Z or Int63.int could be used (you may need to require BinNums or Decimal or Int63 first).") -let vernac_numeral_notation local ty f g scope opts = +let vernac_numeral_notation env sigma local ty f g scope opts = let int_ty = locate_int () in let z_pos_ty = locate_z () in let int63_ty = locate_int63 () in @@ -112,35 +111,35 @@ let vernac_numeral_notation local ty f g scope opts = (* Check the type of f *) let to_kind = match int_ty with - | Some (int_ty, cint, _) when has_type f (arrow cint cty) -> Int int_ty, Direct - | Some (int_ty, cint, _) when has_type f (arrow cint (opt cty)) -> Int int_ty, Option - | Some (int_ty, _, cuint) when has_type f (arrow cuint cty) -> UInt int_ty.uint, Direct - | Some (int_ty, _, cuint) when has_type f (arrow cuint (opt cty)) -> UInt int_ty.uint, Option + | Some (int_ty, cint, _) when has_type env sigma f (arrow cint cty) -> Int int_ty, Direct + | Some (int_ty, cint, _) when has_type env sigma f (arrow cint (opt cty)) -> Int int_ty, Option + | Some (int_ty, _, cuint) when has_type env sigma f (arrow cuint cty) -> UInt int_ty.uint, Direct + | Some (int_ty, _, cuint) when has_type env sigma f (arrow cuint (opt cty)) -> UInt int_ty.uint, Option | _ -> match z_pos_ty with - | Some (z_pos_ty, cZ) when has_type f (arrow cZ cty) -> Z z_pos_ty, Direct - | Some (z_pos_ty, cZ) when has_type f (arrow cZ (opt cty)) -> Z z_pos_ty, Option + | Some (z_pos_ty, cZ) when has_type env sigma f (arrow cZ cty) -> Z z_pos_ty, Direct + | Some (z_pos_ty, cZ) when has_type env sigma f (arrow cZ (opt cty)) -> Z z_pos_ty, Option | _ -> match int63_ty with - | Some cint63 when has_type f (arrow cint63 cty) -> Int63, Direct - | Some cint63 when has_type f (arrow cint63 (opt cty)) -> Int63, Option + | Some cint63 when has_type env sigma f (arrow cint63 cty) -> Int63, Direct + | Some cint63 when has_type env sigma f (arrow cint63 (opt cty)) -> Int63, Option | _ -> type_error_to f ty in (* Check the type of g *) let of_kind = match int_ty with - | Some (int_ty, cint, _) when has_type g (arrow cty cint) -> Int int_ty, Direct - | Some (int_ty, cint, _) when has_type g (arrow cty (opt cint)) -> Int int_ty, Option - | Some (int_ty, _, cuint) when has_type g (arrow cty cuint) -> UInt int_ty.uint, Direct - | Some (int_ty, _, cuint) when has_type g (arrow cty (opt cuint)) -> UInt int_ty.uint, Option + | Some (int_ty, cint, _) when has_type env sigma g (arrow cty cint) -> Int int_ty, Direct + | Some (int_ty, cint, _) when has_type env sigma g (arrow cty (opt cint)) -> Int int_ty, Option + | Some (int_ty, _, cuint) when has_type env sigma g (arrow cty cuint) -> UInt int_ty.uint, Direct + | Some (int_ty, _, cuint) when has_type env sigma g (arrow cty (opt cuint)) -> UInt int_ty.uint, Option | _ -> match z_pos_ty with - | Some (z_pos_ty, cZ) when has_type g (arrow cty cZ) -> Z z_pos_ty, Direct - | Some (z_pos_ty, cZ) when has_type g (arrow cty (opt cZ)) -> Z z_pos_ty, Option + | Some (z_pos_ty, cZ) when has_type env sigma g (arrow cty cZ) -> Z z_pos_ty, Direct + | Some (z_pos_ty, cZ) when has_type env sigma g (arrow cty (opt cZ)) -> Z z_pos_ty, Option | _ -> match int63_ty with - | Some cint63 when has_type g (arrow cty cint63) -> Int63, Direct - | Some cint63 when has_type g (arrow cty (opt cint63)) -> Int63, Option + | Some cint63 when has_type env sigma g (arrow cty cint63) -> Int63, Direct + | Some cint63 when has_type env sigma g (arrow cty (opt cint63)) -> Int63, Option | _ -> type_error_of g ty in let o = { to_kind; to_ty; of_kind; of_ty; diff --git a/plugins/syntax/numeral.mli b/plugins/syntax/numeral.mli index f96b8321f8..b14ed18497 100644 --- a/plugins/syntax/numeral.mli +++ b/plugins/syntax/numeral.mli @@ -14,4 +14,6 @@ open Notation (** * Numeral notation *) -val vernac_numeral_notation : locality_flag -> qualid -> qualid -> qualid -> Notation_term.scope_name -> numnot_option -> unit +val vernac_numeral_notation : Environ.env -> Evd.evar_map -> locality_flag -> + qualid -> qualid -> qualid -> + Notation_term.scope_name -> numnot_option -> unit diff --git a/plugins/syntax/string_notation.ml b/plugins/syntax/string_notation.ml index 12ee4c6eda..5fae696d58 100644 --- a/plugins/syntax/string_notation.ml +++ b/plugins/syntax/string_notation.ml @@ -32,8 +32,7 @@ let q_option () = qualid_of_ref "core.option.type" let q_list () = qualid_of_ref "core.list.type" let q_byte () = qualid_of_ref "core.byte.type" -let has_type f ty = - let (sigma, env) = Pfedit.get_current_context () in +let has_type env sigma f ty = let c = mkCastC (mkRefC f, Glob_term.CastConv ty) in try let _ = Constrintern.interp_constr env sigma c in true with Pretype_errors.PretypeError _ -> false @@ -48,7 +47,7 @@ let type_error_of g ty = (pr_qualid g ++ str " should go from " ++ pr_qualid ty ++ str " to Byte.byte or (option Byte.byte) or (list Byte.byte) or (option (list Byte.byte)).") -let vernac_string_notation local ty f g scope = +let vernac_string_notation env sigma local ty f g scope = let app x y = mkAppC (x,[y]) in let cref q = mkRefC q in let cbyte = cref (q_byte ()) in @@ -66,18 +65,18 @@ let vernac_string_notation local ty f g scope = let constructors = get_constructors tyc in (* Check the type of f *) let to_kind = - if has_type f (arrow clist_byte cty) then ListByte, Direct - else if has_type f (arrow clist_byte (opt cty)) then ListByte, Option - else if has_type f (arrow cbyte cty) then Byte, Direct - else if has_type f (arrow cbyte (opt cty)) then Byte, Option + if has_type env sigma f (arrow clist_byte cty) then ListByte, Direct + else if has_type env sigma f (arrow clist_byte (opt cty)) then ListByte, Option + else if has_type env sigma f (arrow cbyte cty) then Byte, Direct + else if has_type env sigma f (arrow cbyte (opt cty)) then Byte, Option else type_error_to f ty in (* Check the type of g *) let of_kind = - if has_type g (arrow cty clist_byte) then ListByte, Direct - else if has_type g (arrow cty (opt clist_byte)) then ListByte, Option - else if has_type g (arrow cty cbyte) then Byte, Direct - else if has_type g (arrow cty (opt cbyte)) then Byte, Option + if has_type env sigma g (arrow cty clist_byte) then ListByte, Direct + else if has_type env sigma g (arrow cty (opt clist_byte)) then ListByte, Option + else if has_type env sigma g (arrow cty cbyte) then Byte, Direct + else if has_type env sigma g (arrow cty (opt cbyte)) then Byte, Option else type_error_of g ty in let o = { to_kind = to_kind; diff --git a/plugins/syntax/string_notation.mli b/plugins/syntax/string_notation.mli index 9a0174abf2..e81de603d9 100644 --- a/plugins/syntax/string_notation.mli +++ b/plugins/syntax/string_notation.mli @@ -13,4 +13,6 @@ open Vernacexpr (** * String notation *) -val vernac_string_notation : locality_flag -> qualid -> qualid -> qualid -> Notation_term.scope_name -> unit +val vernac_string_notation : Environ.env -> Evd.evar_map -> locality_flag -> + qualid -> qualid -> qualid -> + Notation_term.scope_name -> unit diff --git a/pretyping/classops.ml b/pretyping/classops.ml index 54a1aa9aa0..5560e5e5f5 100644 --- a/pretyping/classops.ml +++ b/pretyping/classops.ml @@ -120,9 +120,6 @@ let class_tab = let coercion_tab = Summary.ref ~name:"coercion_tab" (CoeTypMap.empty : coe_info_typ CoeTypMap.t) -let coercions_in_scope = - Summary.ref ~name:"coercions_in_scope" GlobRef.Set_env.empty - module ClPairOrd = struct type t = cl_index * cl_index @@ -308,9 +305,16 @@ let install_path_printer f = path_printer := f let print_path x = !path_printer x -let message_ambig l = - str"Ambiguous paths:" ++ spc () ++ - prlist_with_sep fnl print_path l +let path_comparator : (inheritance_path -> inheritance_path -> bool) ref = + ref (fun _ _ -> false) + +let install_path_comparator f = path_comparator := f + +let compare_path p q = !path_comparator p q + +let warn_ambiguous_path = + CWarnings.create ~name:"ambiguous-paths" ~category:"typechecker" + (fun l -> strbrk"Ambiguous paths: " ++ prlist_with_sep fnl print_path l) (* add_coercion_in_graph : coe_index * cl_index * cl_index -> unit coercion,source,target *) @@ -329,21 +333,15 @@ let add_coercion_in_graph (ic,source,target) = let ambig_paths = (ref [] : ((cl_index * cl_index) * inheritance_path) list ref) in let try_add_new_path (i,j as ij) p = - try - if Bijint.Index.equal i j then begin - if different_class_params i then begin - let _ = lookup_path_between_class ij in - ambig_paths := (ij,p)::!ambig_paths - end - end else begin - let _ = lookup_path_between_class ij in - ambig_paths := (ij,p)::!ambig_paths - end; + if not (Bijint.Index.equal i j) || different_class_params i then + match lookup_path_between_class ij with + | q -> + if not (compare_path p q) then + ambig_paths := (ij,p)::!ambig_paths; + false + | exception Not_found -> (add_new_path ij p; true) + else false - with Not_found -> begin - add_new_path ij p; - true - end in let try_add_new_path1 ij p = let _ = try_add_new_path ij p in () @@ -364,9 +362,7 @@ let add_coercion_in_graph (ic,source,target) = end) old_inheritance_graph end; - let is_ambig = match !ambig_paths with [] -> false | _ -> true in - if is_ambig && not !Flags.quiet then - Feedback.msg_info (message_ambig !ambig_paths) + match !ambig_paths with [] -> () | _ -> warn_ambiguous_path !ambig_paths type coercion = { coercion_type : coe_typ; @@ -400,13 +396,6 @@ let class_params = function let add_class cl = add_new_class cl { cl_param = class_params cl } -let get_automatically_import_coercions = - Goptions.declare_bool_option_and_ref - ~depr:true (* Remove in 8.8 *) - ~name:"automatic import of coercions" - ~key:["Automatic";"Coercions";"Import"] - ~value:false - let cache_coercion (_, c) = let () = add_class c.coercion_source in let () = add_class c.coercion_target in @@ -422,20 +411,9 @@ let cache_coercion (_, c) = let () = add_new_coercion c.coercion_type xf in add_coercion_in_graph (xf,is,it) -let load_coercion _ o = - if get_automatically_import_coercions () then - cache_coercion o - -let set_coercion_in_scope (_, c) = - let r = c.coercion_type in - coercions_in_scope := GlobRef.Set_env.add r !coercions_in_scope - let open_coercion i o = - if Int.equal i 1 then begin - set_coercion_in_scope o; - if not (get_automatically_import_coercions ()) then - cache_coercion o - end + if Int.equal i 1 then + cache_coercion o let subst_coercion (subst, c) = let coe = subst_coe_typ subst c.coercion_type in @@ -469,10 +447,7 @@ let classify_coercion obj = let inCoercion : coercion -> obj = declare_object {(default_object "COERCION") with open_function = open_coercion; - load_function = load_coercion; - cache_function = (fun objn -> - set_coercion_in_scope objn; - cache_coercion objn); + cache_function = cache_coercion; subst_function = subst_coercion; classify_function = classify_coercion; discharge_function = discharge_coercion } @@ -532,6 +507,3 @@ let hide_coercion coe = let coe_info = coercion_info coe in Some coe_info.coe_param else None - -let is_coercion_in_scope r = - GlobRef.Set_env.mem r !coercions_in_scope diff --git a/pretyping/classops.mli b/pretyping/classops.mli index 7c4842c8ae..bd468e62ad 100644 --- a/pretyping/classops.mli +++ b/pretyping/classops.mli @@ -100,6 +100,8 @@ val lookup_pattern_path_between : (* Crade *) val install_path_printer : ((cl_index * cl_index) * inheritance_path -> Pp.t) -> unit +val install_path_comparator : + (inheritance_path -> inheritance_path -> bool) -> unit (**/**) (** {6 This is for printing purpose } *) @@ -113,5 +115,3 @@ val coercions : unit -> coe_info_typ list (** [hide_coercion] returns the number of params to skip if the coercion must be hidden, [None] otherwise; it raises [Not_found] if not a coercion *) val hide_coercion : coe_typ -> int option - -val is_coercion_in_scope : GlobRef.t -> bool diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index 82411ba2ef..8c9b6550f3 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -368,20 +368,12 @@ let saturate_evd env evd = Typeclasses.resolve_typeclasses ~filter:Typeclasses.no_goals ~split:true ~fail:false env evd -let warn_coercion_not_in_scope = - CWarnings.create ~name:"coercion-not-in-scope" ~category:"deprecated" - Pp.(fun r -> str "Coercion used but not in scope: " ++ - Nametab.pr_global_env Id.Set.empty r ++ str ". If you want to use " - ++ str "this coercion, please Import the module that contains it.") - (* Apply coercion path from p to hj; raise NoCoercion if not applicable *) let apply_coercion env sigma p hj typ_cl = try let j,t,evd = List.fold_left (fun (ja,typ_cl,sigma) i -> - if not (is_coercion_in_scope i.coe_value) then - warn_coercion_not_in_scope i.coe_value; let isid = i.coe_is_identity in let isproj = i.coe_is_projection in let sigma, c = new_global sigma i.coe_value in diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml index bc083ed9d9..6bfbb9a9c0 100644 --- a/pretyping/constr_matching.ml +++ b/pretyping/constr_matching.ml @@ -17,7 +17,6 @@ open Constr open Context open Globnames open Termops -open Term open EConstr open Vars open Pattern @@ -280,14 +279,8 @@ let matches_core env sigma allow_bound_rels | PRel n1, Rel n2 when Int.equal n1 n2 -> subst | PSort ps, Sort s -> - - let open Glob_term in - begin match ps, ESorts.kind sigma s with - | GProp, Prop -> subst - | GSet, Set -> subst - | GType _, Type _ -> subst - | _ -> raise PatternMatchingFailure - end + if Sorts.family_equal ps (Sorts.family (ESorts.kind sigma s)) + then subst else raise PatternMatchingFailure | PApp (p, [||]), _ -> sorec ctx env subst p t diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 28a97bb91a..0ccc4fd9f9 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -503,14 +503,23 @@ let rec evar_conv_x flags env evd pbty term1 term2 = | Evar ev, _ when Evd.is_undefined evd (fst ev) && not (is_frozen flags ev) -> (match solve_simple_eqn (conv_fun evar_conv_x) flags env evd (position_problem true pbty,ev,term2) with - | UnifFailure (_,OccurCheck _) -> - (* Eta-expansion might apply *) default () + | UnifFailure (_,(OccurCheck _ | NotClean _)) -> + (* Eta-expansion might apply *) + (* OccurCheck: eta-expansion could solve + ?X = {| foo := ?X.(foo) |} + NotClean: pruning in solve_simple_eqn is incomplete wrt + Miller patterns *) + default () | x -> x) | _, Evar ev when Evd.is_undefined evd (fst ev) && not (is_frozen flags ev) -> (match solve_simple_eqn (conv_fun evar_conv_x) flags env evd (position_problem false pbty,ev,term1) with - | UnifFailure (_, OccurCheck _) -> - (* Eta-expansion might apply *) default () + | UnifFailure (_, (OccurCheck _ | NotClean _)) -> + (* OccurCheck: eta-expansion could solve + ?X = {| foo := ?X.(foo) |} + NotClean: pruning in solve_simple_eqn is incomplete wrt + Miller patterns *) + default () | x -> x) | _ -> default () end diff --git a/pretyping/geninterp.ml b/pretyping/geninterp.ml index 1f8b926365..32152ad0e4 100644 --- a/pretyping/geninterp.ml +++ b/pretyping/geninterp.ml @@ -82,9 +82,10 @@ let register_val0 wit tag = (** Interpretation functions *) -type interp_sign = { - lfun : Val.t Id.Map.t; - extra : TacStore.t } +type interp_sign = + { lfun : Val.t Id.Map.t + ; poly : bool + ; extra : TacStore.t } type ('glb, 'top) interp_fun = interp_sign -> 'glb -> 'top Ftactic.t diff --git a/pretyping/geninterp.mli b/pretyping/geninterp.mli index 606a6ebead..49d874289d 100644 --- a/pretyping/geninterp.mli +++ b/pretyping/geninterp.mli @@ -62,9 +62,10 @@ val register_val0 : ('raw, 'glb, 'top) genarg_type -> 'top Val.tag option -> uni module TacStore : Store.S -type interp_sign = { - lfun : Val.t Id.Map.t; - extra : TacStore.t } +type interp_sign = + { lfun : Val.t Id.Map.t + ; poly : bool + ; extra : TacStore.t } type ('glb, 'top) interp_fun = interp_sign -> 'glb -> 'top Ftactic.t diff --git a/pretyping/globEnv.ml b/pretyping/globEnv.ml index cd82b1993b..e76eb2a7de 100644 --- a/pretyping/globEnv.ml +++ b/pretyping/globEnv.ml @@ -183,7 +183,7 @@ let interp_ltac_id env id = ltac_interp_id env.lvar id module ConstrInterpObj = struct type ('r, 'g, 't) obj = - unbound_ltac_var_map -> env -> Evd.evar_map -> types -> 'g -> constr * Evd.evar_map + unbound_ltac_var_map -> bool -> env -> Evd.evar_map -> types -> 'g -> constr * Evd.evar_map let name = "constr_interp" let default _ = None end @@ -192,8 +192,8 @@ module ConstrInterp = Genarg.Register(ConstrInterpObj) let register_constr_interp0 = ConstrInterp.register0 -let interp_glob_genarg env sigma ty arg = +let interp_glob_genarg env poly sigma ty arg = let open Genarg in let GenArg (Glbwit tag, arg) = arg in let interp = ConstrInterp.obj tag in - interp env.lvar.ltac_genargs env.renamed_env sigma ty arg + interp env.lvar.ltac_genargs poly env.renamed_env sigma ty arg diff --git a/pretyping/globEnv.mli b/pretyping/globEnv.mli index 65ae495135..cdd36bbba6 100644 --- a/pretyping/globEnv.mli +++ b/pretyping/globEnv.mli @@ -19,7 +19,7 @@ open Evarutil val register_constr_interp0 : ('r, 'g, 't) Genarg.genarg_type -> - (unbound_ltac_var_map -> env -> evar_map -> types -> 'g -> constr * evar_map) -> unit + (unbound_ltac_var_map -> bool -> env -> evar_map -> types -> 'g -> constr * evar_map) -> unit (** {6 Pretyping name management} *) @@ -85,5 +85,5 @@ val interp_ltac_id : t -> Id.t -> Id.t (** Interpreting a generic argument, typically a "ltac:(...)", taking into account the possible renaming *) -val interp_glob_genarg : t -> evar_map -> constr -> +val interp_glob_genarg : t -> bool -> evar_map -> constr -> Genarg.glob_generic_argument -> constr * evar_map diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml index affed5389f..74432cc010 100644 --- a/pretyping/glob_ops.ml +++ b/pretyping/glob_ops.ml @@ -47,11 +47,18 @@ let map_glob_decl_left_to_right f (na,k,obd,ty) = let glob_sort_eq g1 g2 = let open Glob_term in match g1, g2 with -| GProp, GProp -> true +| GSProp, GSProp +| GProp, GProp | GSet, GSet -> true | GType l1, GType l2 -> List.equal (Option.equal (fun (x,m) (y,n) -> Libnames.qualid_eq x y && Int.equal m n)) l1 l2 -| _ -> false +| (GSProp|GProp|GSet|GType _), _ -> false + +let glob_sort_family = let open Sorts in function +| GSProp -> InSProp +| GProp -> InProp +| GSet -> InSet +| GType _ -> InType let binding_kind_eq bk1 bk2 = match bk1, bk2 with | Decl_kinds.Explicit, Decl_kinds.Explicit -> true diff --git a/pretyping/glob_ops.mli b/pretyping/glob_ops.mli index c189a3bcb2..2f0ac76235 100644 --- a/pretyping/glob_ops.mli +++ b/pretyping/glob_ops.mli @@ -15,6 +15,8 @@ open Glob_term val glob_sort_eq : Glob_term.glob_sort -> Glob_term.glob_sort -> bool +val glob_sort_family : 'a glob_sort_gen -> Sorts.family + val cases_pattern_eq : 'a cases_pattern_g -> 'a cases_pattern_g -> bool val alias_of_pat : 'a cases_pattern_g -> Name.t diff --git a/pretyping/pattern.ml b/pretyping/pattern.ml index 2ca7f21e8d..d1c0a4ea2a 100644 --- a/pretyping/pattern.ml +++ b/pretyping/pattern.ml @@ -32,7 +32,7 @@ type constr_pattern = | PLambda of Name.t * constr_pattern * constr_pattern | PProd of Name.t * constr_pattern * constr_pattern | PLetIn of Name.t * constr_pattern * constr_pattern option * constr_pattern - | PSort of Glob_term.glob_sort + | PSort of Sorts.family | PMeta of patvar option | PIf of constr_pattern * constr_pattern * constr_pattern | PCase of case_info_pattern * constr_pattern * constr_pattern * diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index 13034d078a..4e3c77cb1a 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -13,7 +13,6 @@ open Util open Names open Globnames open Nameops -open Term open Constr open Context open Glob_term @@ -47,7 +46,7 @@ let rec constr_pattern_eq p1 p2 = match p1, p2 with | PLetIn (v1, b1, t1, c1), PLetIn (v2, b2, t2, c2) -> Name.equal v1 v2 && constr_pattern_eq b1 b2 && Option.equal constr_pattern_eq t1 t2 && constr_pattern_eq c1 c2 -| PSort s1, PSort s2 -> Glob_ops.glob_sort_eq s1 s2 +| PSort s1, PSort s2 -> Sorts.family_equal s1 s2 | PMeta m1, PMeta m2 -> Option.equal Id.equal m1 m2 | PIf (t1, l1, r1), PIf (t2, l2, r2) -> constr_pattern_eq t1 t2 && constr_pattern_eq l1 l2 && constr_pattern_eq r1 r2 @@ -154,10 +153,7 @@ let pattern_of_constr env sigma t = | Rel n -> PRel n | Meta n -> PMeta (Some (Id.of_string ("META" ^ string_of_int n))) | Var id -> PVar id - | Sort SProp -> PSort GSProp - | Sort Prop -> PSort GProp - | Sort Set -> PSort GSet - | Sort (Type _) -> PSort (GType []) + | Sort s -> PSort (Sorts.family s) | Cast (c,_,_) -> pattern_of_constr env c | LetIn (na,c,t,b) -> PLetIn (na.binder_name, pattern_of_constr env c,Some (pattern_of_constr env t), @@ -416,8 +412,7 @@ let rec pat_of_raw metas vars = DAst.with_loc_val (fun ?loc -> function PLetIn (na, pat_of_raw metas vars c1, Option.map (pat_of_raw metas vars) t, pat_of_raw metas (na::vars) c2) - | GSort s -> - PSort s + | GSort gs -> PSort (Glob_ops.glob_sort_family gs) | GHole _ -> PMeta None | GCast (c,_) -> diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 8e9a2e114b..bec939b911 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -198,6 +198,7 @@ type inference_flags = { fail_evar : bool; expand_evars : bool; program_mode : bool; + polymorphic : bool; } (* Compute the set of still-undefined initial evars up to restriction @@ -474,10 +475,10 @@ let mark_obligation_evar sigma k evc = (* in environment [env], with existential variables [sigma] and *) (* the type constraint tycon *) -let rec pretype ~program_mode k0 resolve_tc (tycon : type_constraint) (env : GlobEnv.t) (sigma : evar_map) t = +let rec pretype ~program_mode ~poly k0 resolve_tc (tycon : type_constraint) (env : GlobEnv.t) (sigma : evar_map) t = let inh_conv_coerce_to_tycon ?loc = inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc in - let pretype_type = pretype_type ~program_mode k0 resolve_tc in - let pretype = pretype ~program_mode k0 resolve_tc in + let pretype_type = pretype_type ~program_mode ~poly k0 resolve_tc in + let pretype = pretype ~program_mode ~poly k0 resolve_tc in let open Context.Rel.Declaration in let loc = t.CAst.loc in match DAst.get t with @@ -497,7 +498,7 @@ let rec pretype ~program_mode k0 resolve_tc (tycon : type_constraint) (env : Glo try Evd.evar_key id sigma with Not_found -> error_evar_not_found ?loc !!env sigma id in let hyps = evar_filtered_context (Evd.find sigma evk) in - let sigma, args = pretype_instance ~program_mode k0 resolve_tc env sigma loc hyps evk inst in + let sigma, args = pretype_instance ~program_mode ~poly k0 resolve_tc env sigma loc hyps evk inst in let c = mkEvar (evk, args) in let j = Retyping.get_judgment_of !!env sigma c in inh_conv_coerce_to_tycon ?loc env sigma j tycon @@ -530,7 +531,7 @@ let rec pretype ~program_mode k0 resolve_tc (tycon : type_constraint) (env : Glo match tycon with | Some ty -> sigma, ty | None -> new_type_evar env sigma loc in - let c, sigma = GlobEnv.interp_glob_genarg env sigma ty arg in + let c, sigma = GlobEnv.interp_glob_genarg env poly sigma ty arg in sigma, { uj_val = c; uj_type = ty } | GRec (fixkind,names,bl,lar,vdef) -> @@ -983,7 +984,7 @@ let rec pretype ~program_mode k0 resolve_tc (tycon : type_constraint) (env : Glo in inh_conv_coerce_to_tycon ?loc env sigma resj tycon -and pretype_instance ~program_mode k0 resolve_tc env sigma loc hyps evk update = +and pretype_instance ~program_mode ~poly k0 resolve_tc env sigma loc hyps evk update = let f decl (subst,update,sigma) = let id = NamedDecl.get_id decl in let b = Option.map (replace_vars subst) (NamedDecl.get_value decl) in @@ -1015,7 +1016,7 @@ and pretype_instance ~program_mode k0 resolve_tc env sigma loc hyps evk update = let sigma, c, update = try let c = List.assoc id update in - let sigma, c = pretype ~program_mode k0 resolve_tc (mk_tycon t) env sigma c in + let sigma, c = pretype ~program_mode ~poly k0 resolve_tc (mk_tycon t) env sigma c in check_body sigma id (Some c.uj_val); sigma, c.uj_val, List.remove_assoc id update with Not_found -> @@ -1040,7 +1041,7 @@ and pretype_instance ~program_mode k0 resolve_tc env sigma loc hyps evk update = sigma, Array.map_of_list snd subst (* [pretype_type valcon env sigma c] coerces [c] into a type *) -and pretype_type ~program_mode k0 resolve_tc valcon (env : GlobEnv.t) sigma c = match DAst.get c with +and pretype_type ~program_mode ~poly k0 resolve_tc valcon (env : GlobEnv.t) sigma c = match DAst.get c with | GHole (knd, naming, None) -> let loc = loc_of_glob_constr c in (match valcon with @@ -1067,7 +1068,7 @@ and pretype_type ~program_mode k0 resolve_tc valcon (env : GlobEnv.t) sigma c = let sigma = if program_mode then mark_obligation_evar sigma knd utj_val else sigma in sigma, { utj_val; utj_type = s}) | _ -> - let sigma, j = pretype ~program_mode k0 resolve_tc empty_tycon env sigma c in + let sigma, j = pretype ~program_mode ~poly k0 resolve_tc empty_tycon env sigma c in let loc = loc_of_glob_constr c in let sigma, tj = Coercion.inh_coerce_to_sort ?loc !!env sigma j in match valcon with @@ -1082,6 +1083,7 @@ and pretype_type ~program_mode k0 resolve_tc valcon (env : GlobEnv.t) sigma c = let ise_pretype_gen flags env sigma lvar kind c = let program_mode = flags.program_mode in + let poly = flags.polymorphic in let hypnaming = if program_mode then ProgramNaming else KeepUserNameAndRenameExistingButSectionNames in @@ -1089,13 +1091,13 @@ let ise_pretype_gen flags env sigma lvar kind c = let k0 = Context.Rel.length (rel_context !!env) in let sigma', c', c'_ty = match kind with | WithoutTypeConstraint -> - let sigma, j = pretype ~program_mode k0 flags.use_typeclasses empty_tycon env sigma c in + let sigma, j = pretype ~program_mode ~poly k0 flags.use_typeclasses empty_tycon env sigma c in sigma, j.uj_val, j.uj_type | OfType exptyp -> - let sigma, j = pretype ~program_mode k0 flags.use_typeclasses (mk_tycon exptyp) env sigma c in + let sigma, j = pretype ~program_mode ~poly k0 flags.use_typeclasses (mk_tycon exptyp) env sigma c in sigma, j.uj_val, j.uj_type | IsType -> - let sigma, tj = pretype_type ~program_mode k0 flags.use_typeclasses empty_valcon env sigma c in + let sigma, tj = pretype_type ~program_mode ~poly k0 flags.use_typeclasses empty_valcon env sigma c in sigma, tj.utj_val, mkSort tj.utj_type in process_inference_flags flags !!env sigma (sigma',c',c'_ty) @@ -1106,6 +1108,7 @@ let default_inference_flags fail = { fail_evar = fail; expand_evars = true; program_mode = false; + polymorphic = false; } let no_classes_no_fail_inference_flags = { @@ -1114,6 +1117,7 @@ let no_classes_no_fail_inference_flags = { fail_evar = false; expand_evars = true; program_mode = false; + polymorphic = false; } let all_and_fail_flags = default_inference_flags true @@ -1141,3 +1145,39 @@ let understand_tcc ?flags env sigma ?expected_type c = let understand_ltac flags env sigma lvar kind c = let (sigma, c, _) = ise_pretype_gen flags env sigma lvar kind c in (sigma, c) + +let path_convertible p q = + let open Classops in + let mkGRef ref = DAst.make @@ Glob_term.GRef(ref,None) in + let mkGVar id = DAst.make @@ Glob_term.GVar(id) in + let mkGApp(rt,rtl) = DAst.make @@ Glob_term.GApp(rt,rtl) in + let mkGLambda(n,t,b) = DAst.make @@ Glob_term.GLambda(n,Decl_kinds.Explicit,t,b) in + let mkGHole () = DAst.make @@ Glob_term.GHole(Evar_kinds.BinderType Anonymous,Namegen.IntroAnonymous,None) in + let path_to_gterm p = + match p with + | ic :: p' -> + let names = + List.map (fun n -> Id.of_string ("x" ^ string_of_int n)) + (List.interval 0 ic.coe_param) + in + List.fold_right + (fun id t -> mkGLambda (Name id, mkGHole (), t)) names @@ + List.fold_left + (fun t ic -> + mkGApp (mkGRef ic.coe_value, + List.make ic.coe_param (mkGHole ()) @ [t])) + (mkGApp (mkGRef ic.coe_value, List.map (fun i -> mkGVar i) names)) + p' + | [] -> anomaly (str "A coercion path shouldn't be empty.") + in + try + let e = Global.env () in + let sigma,tp = understand_tcc e (Evd.from_env e) (path_to_gterm p) in + let sigma,tq = understand_tcc e sigma (path_to_gterm q) in + if Evd.has_undefined sigma then + false + else + let _ = Evarconv.unify_delay e sigma tp tq in true + with Evarconv.UnableToUnify _ | PretypeError _ -> false + +let _ = Classops.install_path_comparator path_convertible diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index 3c875e69d2..1037cf6cc5 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -38,6 +38,7 @@ type inference_flags = { fail_evar : bool; expand_evars : bool; program_mode : bool; + polymorphic : bool; } val default_inference_flags : bool -> inference_flags diff --git a/printing/genprint.ml b/printing/genprint.ml index fa53a87945..2f0f7f48c9 100644 --- a/printing/genprint.ml +++ b/printing/genprint.ml @@ -24,8 +24,8 @@ type 'a with_level = printer : 'a } type printer_result = -| PrinterBasic of (unit -> Pp.t) -| PrinterNeedsLevel of (Notation_gram.tolerability -> Pp.t) with_level +| PrinterBasic of (Environ.env -> Evd.evar_map -> Pp.t) +| PrinterNeedsLevel of (Environ.env -> Evd.evar_map -> Notation_gram.tolerability -> Pp.t) with_level type printer_fun_with_level = Environ.env -> Evd.evar_map -> Notation_gram.tolerability -> Pp.t @@ -120,8 +120,8 @@ struct | ExtraArg tag -> let name = ArgT.repr tag in let printer = { - raw = (fun _ -> PrinterBasic (fun () -> str "<genarg:" ++ str name ++ str ">")); - glb = (fun _ -> PrinterBasic (fun () -> str "<genarg:" ++ str name ++ str ">")); + raw = (fun _ -> PrinterBasic (fun env sigma -> str "<genarg:" ++ str name ++ str ">")); + glb = (fun _ -> PrinterBasic (fun env sigma -> str "<genarg:" ++ str name ++ str ">")); top = (fun _ -> TopPrinterBasic (fun () -> str "<genarg:" ++ str name ++ str ">")); } in Some printer diff --git a/printing/genprint.mli b/printing/genprint.mli index 1a31025a9a..24b008643b 100644 --- a/printing/genprint.mli +++ b/printing/genprint.mli @@ -18,8 +18,8 @@ type 'a with_level = printer : 'a } type printer_result = -| PrinterBasic of (unit -> Pp.t) -| PrinterNeedsLevel of (Notation_gram.tolerability -> Pp.t) with_level +| PrinterBasic of (Environ.env -> Evd.evar_map -> Pp.t) +| PrinterNeedsLevel of (Environ.env -> Evd.evar_map -> Notation_gram.tolerability -> Pp.t) with_level type printer_fun_with_level = Environ.env -> Evd.evar_map -> Notation_gram.tolerability -> Pp.t diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index ad2b51b23d..229930142e 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -669,10 +669,10 @@ let tag_var = tag Tag.variable (sep() ++ if prec_less prec inherited then strm else surround strm) type term_pr = { - pr_constr_expr : constr_expr -> Pp.t; - pr_lconstr_expr : constr_expr -> Pp.t; - pr_constr_pattern_expr : constr_pattern_expr -> Pp.t; - pr_lconstr_pattern_expr : constr_pattern_expr -> Pp.t + pr_constr_expr : Environ.env -> Evd.evar_map -> constr_expr -> Pp.t; + pr_lconstr_expr : Environ.env -> Evd.evar_map -> constr_expr -> Pp.t; + pr_constr_pattern_expr : Environ.env -> Evd.evar_map -> constr_pattern_expr -> Pp.t; + pr_lconstr_pattern_expr : Environ.env -> Evd.evar_map -> constr_pattern_expr -> Pp.t } let modular_constr_pr = pr @@ -693,18 +693,16 @@ let tag_var = tag Tag.variable Constrextern.extern_glob_constr (Termops.vars_of_env env) r else c - let pr_expr prec c = - let env = Global.env () in - let sigma = Evd.from_env env in + let pr_expr env sigma prec c = pr prec (transf env sigma c) - let pr_simpleconstr = pr_expr lsimpleconstr + let pr_simpleconstr env sigma = pr_expr env sigma lsimpleconstr let default_term_pr = { pr_constr_expr = pr_simpleconstr; - pr_lconstr_expr = pr_expr ltop; + pr_lconstr_expr = (fun env sigma -> pr_expr env sigma ltop); pr_constr_pattern_expr = pr_simpleconstr; - pr_lconstr_pattern_expr = pr_expr ltop + pr_lconstr_pattern_expr = (fun env sigma -> pr_expr env sigma ltop) } let term_pr = ref default_term_pr @@ -721,5 +719,5 @@ let tag_var = tag Tag.variable let pr_record_body = pr_record_body_gen pr - let pr_binders = pr_undelimited_binders spc (pr_expr ltop) + let pr_binders env sigma = pr_undelimited_binders spc (pr_expr env sigma ltop) diff --git a/printing/ppconstr.mli b/printing/ppconstr.mli index 1cb3aa6d7a..db1687a49b 100644 --- a/printing/ppconstr.mli +++ b/printing/ppconstr.mli @@ -41,19 +41,19 @@ val pr_guard_annot : (constr_expr -> Pp.t) -> Pp.t val pr_record_body : (qualid * constr_expr) list -> Pp.t -val pr_binders : local_binder_expr list -> Pp.t -val pr_constr_pattern_expr : constr_pattern_expr -> Pp.t -val pr_lconstr_pattern_expr : constr_pattern_expr -> Pp.t -val pr_constr_expr : constr_expr -> Pp.t -val pr_lconstr_expr : constr_expr -> Pp.t +val pr_binders : Environ.env -> Evd.evar_map -> local_binder_expr list -> Pp.t +val pr_constr_pattern_expr : Environ.env -> Evd.evar_map -> constr_pattern_expr -> Pp.t +val pr_lconstr_pattern_expr : Environ.env -> Evd.evar_map -> constr_pattern_expr -> Pp.t +val pr_constr_expr : Environ.env -> Evd.evar_map -> constr_expr -> Pp.t +val pr_lconstr_expr : Environ.env -> Evd.evar_map -> constr_expr -> Pp.t val pr_cases_pattern_expr : cases_pattern_expr -> Pp.t -val pr_constr_expr_n : tolerability -> constr_expr -> Pp.t +val pr_constr_expr_n : Environ.env -> Evd.evar_map -> tolerability -> constr_expr -> Pp.t type term_pr = { - pr_constr_expr : constr_expr -> Pp.t; - pr_lconstr_expr : constr_expr -> Pp.t; - pr_constr_pattern_expr : constr_pattern_expr -> Pp.t; - pr_lconstr_pattern_expr : constr_pattern_expr -> Pp.t + pr_constr_expr : Environ.env -> Evd.evar_map -> constr_expr -> Pp.t; + pr_lconstr_expr : Environ.env -> Evd.evar_map -> constr_expr -> Pp.t; + pr_constr_pattern_expr : Environ.env -> Evd.evar_map -> constr_pattern_expr -> Pp.t; + pr_lconstr_pattern_expr : Environ.env -> Evd.evar_map -> constr_pattern_expr -> Pp.t } val set_term_pr : term_pr -> unit diff --git a/printing/pputils.ml b/printing/pputils.ml index e6daf9544c..fff6dae1b4 100644 --- a/printing/pputils.ml +++ b/printing/pputils.ml @@ -60,50 +60,52 @@ let pr_or_by_notation f = let open Constrexpr in CAst.with_val (function 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)) = +let rec pr_raw_generic env sigma (GenArg (Rawwit wit, x)) = match wit with | ListArg wit -> - let map x = pr_raw_generic env (in_gen (rawwit wit) x) in + let map x = pr_raw_generic env sigma (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) + | Some x -> pr_raw_generic env sigma (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]) + hov_if_not_empty 0 (pr_sequence (pr_raw_generic env sigma) [p; q]) | ExtraArg s -> let open Genprint in match generic_raw_print (in_gen (rawwit wit) x) with - | PrinterBasic pp -> pp () - | PrinterNeedsLevel { default_ensure_surrounded; printer } -> printer default_ensure_surrounded + | PrinterBasic pp -> pp env sigma + | PrinterNeedsLevel { default_ensure_surrounded; printer } -> + printer env sigma default_ensure_surrounded -let rec pr_glb_generic env (GenArg (Glbwit wit, x)) = +let rec pr_glb_generic env sigma (GenArg (Glbwit wit, x)) = match wit with | ListArg wit -> - let map x = pr_glb_generic env (in_gen (glbwit wit) x) in + let map x = pr_glb_generic env sigma (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) + | Some x -> pr_glb_generic env sigma (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 + let ans = pr_sequence (pr_glb_generic env sigma) [p; q] in hov_if_not_empty 0 ans | ExtraArg s -> let open Genprint in match generic_glb_print (in_gen (glbwit wit) x) with - | PrinterBasic pp -> pp () - | PrinterNeedsLevel { default_ensure_surrounded; printer } -> printer default_ensure_surrounded + | PrinterBasic pp -> pp env sigma + | PrinterNeedsLevel { default_ensure_surrounded; printer } -> + printer env sigma default_ensure_surrounded diff --git a/printing/pputils.mli b/printing/pputils.mli index ea554355bc..d0f3e61eac 100644 --- a/printing/pputils.mli +++ b/printing/pputils.mli @@ -20,8 +20,8 @@ val pr_lname : lname -> Pp.t val pr_or_var : ('a -> Pp.t) -> 'a Locus.or_var -> Pp.t val pr_or_by_notation : ('a -> Pp.t) -> 'a Constrexpr.or_by_notation -> Pp.t -val pr_raw_generic : Environ.env -> rlevel generic_argument -> Pp.t -val pr_glb_generic : Environ.env -> glevel generic_argument -> Pp.t +val pr_raw_generic : Environ.env -> Evd.evar_map -> rlevel generic_argument -> Pp.t +val pr_glb_generic : Environ.env -> Evd.evar_map -> glevel generic_argument -> Pp.t (* The comments interface is imperative due to the printer not threading it, this could be solved using a better data diff --git a/printing/printer.ml b/printing/printer.ml index fa55a28cb3..2951d8e5c8 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -78,9 +78,9 @@ let () = _not_ occur in the scope of the binder to be printed are avoided. *) let pr_econstr_n_core goal_concl_style env sigma n t = - pr_constr_expr_n n (extern_constr goal_concl_style env sigma t) + pr_constr_expr_n env sigma n (extern_constr goal_concl_style env sigma t) let pr_econstr_core goal_concl_style env sigma t = - pr_constr_expr (extern_constr goal_concl_style env sigma t) + pr_constr_expr env sigma (extern_constr goal_concl_style env sigma t) let pr_leconstr_core = Proof_diffs.pr_leconstr_core let pr_constr_n_env env sigma n c = pr_econstr_n_core false env sigma n (EConstr.of_constr c) @@ -108,7 +108,7 @@ let pr_constr_under_binders_env = pr_constr_under_binders_env_gen pr_econstr_env let pr_lconstr_under_binders_env = pr_constr_under_binders_env_gen pr_leconstr_env let pr_etype_core goal_concl_style env sigma t = - pr_constr_expr (extern_type goal_concl_style env sigma t) + pr_constr_expr env sigma (extern_type goal_concl_style env sigma t) let pr_letype_core = Proof_diffs.pr_letype_core let pr_ltype_env env sigma c = pr_letype_core false env sigma (EConstr.of_constr c) @@ -122,19 +122,19 @@ let pr_ljudge_env env sigma j = (pr_leconstr_env env sigma j.uj_val, pr_leconstr_env env sigma j.uj_type) let pr_lglob_constr_env env c = - pr_lconstr_expr (extern_glob_constr (Termops.vars_of_env env) c) + pr_lconstr_expr env (Evd.from_env env) (extern_glob_constr (Termops.vars_of_env env) c) let pr_glob_constr_env env c = - pr_constr_expr (extern_glob_constr (Termops.vars_of_env env) c) + pr_constr_expr env (Evd.from_env env) (extern_glob_constr (Termops.vars_of_env env) c) let pr_closed_glob_n_env env sigma n c = - pr_constr_expr_n n (extern_closed_glob false env sigma c) + pr_constr_expr_n env sigma n (extern_closed_glob false env sigma c) let pr_closed_glob_env env sigma c = - pr_constr_expr (extern_closed_glob false env sigma c) + pr_constr_expr env sigma (extern_closed_glob false env sigma c) let pr_lconstr_pattern_env env sigma c = - pr_lconstr_pattern_expr (extern_constr_pattern (Termops.names_of_rel_context env) sigma c) + pr_lconstr_pattern_expr env sigma (extern_constr_pattern (Termops.names_of_rel_context env) sigma c) let pr_constr_pattern_env env sigma c = - pr_constr_pattern_expr (extern_constr_pattern (Termops.names_of_rel_context env) sigma c) + pr_constr_pattern_expr env sigma (extern_constr_pattern (Termops.names_of_rel_context env) sigma c) let pr_cases_pattern t = pr_cases_pattern_expr (extern_cases_pattern Names.Id.Set.empty t) @@ -142,7 +142,7 @@ let pr_cases_pattern t = let pr_sort sigma s = pr_glob_sort (extern_sort sigma s) let () = Termops.Internal.set_print_constr - (fun env sigma t -> pr_lconstr_expr (extern_constr ~lax:true false env sigma t)) + (fun env sigma t -> pr_lconstr_expr env sigma (extern_constr ~lax:true false env sigma t)) let pr_in_comment x = str "(* " ++ x ++ str " *)" @@ -335,7 +335,7 @@ let pr_named_context env sigma ne_context = let pr_rel_context env sigma rel_context = let rel_context = List.map (fun d -> Termops.map_rel_decl EConstr.of_constr d) rel_context in - pr_binders (extern_rel_context None env sigma rel_context) + pr_binders env sigma (extern_rel_context None env sigma rel_context) let pr_rel_context_of env sigma = pr_rel_context env sigma (rel_context env) diff --git a/printing/proof_diffs.ml b/printing/proof_diffs.ml index 5aa7b3c7bd..ab4501fe75 100644 --- a/printing/proof_diffs.ml +++ b/printing/proof_diffs.ml @@ -39,6 +39,13 @@ uses strikeout on removed text. open Pp_diff +let term_color = ref true + +let write_color_enabled enabled = + term_color := enabled + +let color_enabled () = !term_color + let diff_option = ref `OFF let read_diffs_option () = match !diff_option with @@ -46,11 +53,18 @@ let read_diffs_option () = match !diff_option with | `ON -> "on" | `REMOVED -> "removed" -let write_diffs_option = function -| "off" -> diff_option := `OFF -| "on" -> diff_option := `ON -| "removed" -> diff_option := `REMOVED -| _ -> CErrors.user_err Pp.(str "Diffs option only accepts the following values: \"off\", \"on\", \"removed\".") +let write_diffs_option opt = + let enable opt = + if not (color_enabled ()) then + CErrors.user_err Pp.(str "Enabling Diffs requires setting the \"-color\" command line argument to \"on\" or \"auto\".") + else + diff_option := opt + in + match opt with + | "off" -> diff_option := `OFF + | "on" -> enable `ON + | "removed" -> enable `REMOVED + | _ -> CErrors.user_err Pp.(str "Diffs option only accepts the following values: \"off\", \"on\", \"removed\".") let () = Goptions.(declare_string_option { @@ -233,13 +247,13 @@ let process_goal sigma g : EConstr.t reified_goal = { name; ty; hyps; env; sigma };; let pr_letype_core goal_concl_style env sigma t = - Ppconstr.pr_lconstr_expr (Constrextern.extern_type goal_concl_style env sigma t) + Ppconstr.pr_lconstr_expr env sigma (Constrextern.extern_type goal_concl_style env sigma t) let pp_of_type env sigma ty = pr_letype_core true env sigma ty let pr_leconstr_core goal_concl_style env sigma t = - Ppconstr.pr_lconstr_expr (Constrextern.extern_constr goal_concl_style env sigma t) + Ppconstr.pr_lconstr_expr env sigma (Constrextern.extern_constr goal_concl_style env sigma t) let pr_lconstr_env env sigma c = pr_leconstr_core false env sigma (EConstr.of_constr c) @@ -533,13 +547,16 @@ let match_goals ot nt = | None -> ()); !nevar_to_oevar +let get_proof_context (p : Proof.t) = + let Proof.{goals; sigma} = Proof.data p in + sigma, Refiner.pf_env { Evd.it = List.(hd goals); sigma } -let to_constr p = +let to_constr pf = let open CAst in - let pprf = Proof.partial_proof p in + let pprf = Proof.partial_proof pf in (* pprf generally has only one element, but it may have more in the derive plugin *) let t = List.hd pprf in - let sigma, env = Pfedit.get_current_context ~p () in + let sigma, env = get_proof_context pf in let x = Constrextern.extern_constr false env sigma t in (* todo: right options?? *) x.v diff --git a/printing/proof_diffs.mli b/printing/proof_diffs.mli index 1ebde3d572..fd10eaa458 100644 --- a/printing/proof_diffs.mli +++ b/printing/proof_diffs.mli @@ -16,6 +16,12 @@ val write_diffs_option : string -> unit (** Returns true if the diffs option is "on" or "removed" *) val show_diffs : unit -> bool +(** controls whether color output is enabled *) +val write_color_enabled : bool -> unit + +(** true indicates that color output is enabled *) +val color_enabled : unit -> bool + open Evd open Environ open Constr diff --git a/proofs/evar_refiner.ml b/proofs/evar_refiner.ml index 0f97a942ed..1a34105ab6 100644 --- a/proofs/evar_refiner.ml +++ b/proofs/evar_refiner.ml @@ -55,6 +55,7 @@ let w_refine (evk,evi) (ltac_var,rawc) sigma = Pretyping.fail_evar = false; Pretyping.expand_evars = true; Pretyping.program_mode = false; + Pretyping.polymorphic = false; } in try Pretyping.understand_ltac flags env sigma ltac_var (Pretyping.OfType evi.evar_concl) rawc diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index 9509c36ec0..472db790f2 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -37,41 +37,35 @@ let get_nth_V82_goal p i = try { it = List.nth goals (i-1) ; sigma } with Failure _ -> raise NoSuchGoal -let get_goal_context_gen p i = - let { it=goal ; sigma=sigma; } = get_nth_V82_goal p i in +let get_goal_context_gen pf i = + let { it=goal ; sigma=sigma; } = get_nth_V82_goal pf i in (sigma, Refiner.pf_env { it=goal ; sigma=sigma; }) -let get_goal_context i = - try get_goal_context_gen (Proof_global.give_me_the_proof ()) i - with Proof_global.NoCurrentProof -> CErrors.user_err Pp.(str "No focused proof.") - | NoSuchGoal -> CErrors.user_err Pp.(str "No such goal.") - -let get_current_goal_context () = - try get_goal_context_gen (Proof_global.give_me_the_proof ()) 1 - with Proof_global.NoCurrentProof -> CErrors.user_err Pp.(str "No focused proof.") - | NoSuchGoal -> - (* spiwack: returning empty evar_map, since if there is no goal, under focus, - there is no accessible evar either *) - let env = Global.env () in - (Evd.from_env env, env) +let get_goal_context pf i = + let p = Proof_global.give_me_the_proof pf in + get_goal_context_gen p i -let get_current_context ?p () = - let current_proof_by_default = function - | Some p -> p - | None -> Proof_global.give_me_the_proof () - in - try get_goal_context_gen (current_proof_by_default p) 1 - with Proof_global.NoCurrentProof -> +let get_current_goal_context pf = + let p = Proof_global.give_me_the_proof pf in + try get_goal_context_gen p 1 + with + | NoSuchGoal -> + (* spiwack: returning empty evar_map, since if there is no goal, + under focus, there is no accessible evar either. EJGA: this + seems strange, as we have pf *) let env = Global.env () in - (Evd.from_env env, env) - | NoSuchGoal -> - (* No more focused goals ? *) - let p = (current_proof_by_default p) in - let evd = Proof.in_proof p (fun x -> x) in - (evd, Global.env ()) + Evd.from_env env, env + +let get_current_context pf = + let p = Proof_global.give_me_the_proof pf in + try get_goal_context_gen p 1 + with + | NoSuchGoal -> + (* No more focused goals *) + let evd = Proof.in_proof p (fun x -> x) in + evd, Global.env () let solve ?with_end_tac gi info_lvl tac pr = - try let tac = match with_end_tac with | None -> tac | Some etac -> Proofview.tclTHEN tac etac in @@ -112,15 +106,12 @@ let solve ?with_end_tac gi info_lvl tac pr = | Some i -> Feedback.msg_info (hov 0 (Proofview.Trace.pr_info env sigma ~lvl:i info)) in (p,status) - with - Proof_global.NoCurrentProof -> CErrors.user_err Pp.(str "No focused proof") let by tac = Proof_global.with_current_proof (fun _ -> solve (Goal_select.SelectNth 1) None tac) -let instantiate_nth_evar_com n com = +let instantiate_nth_evar_com n com = Proof_global.simple_with_current_proof (fun _ p -> - Proof.V82.instantiate_evar Global.(env ())n com p) - + Proof.V82.instantiate_evar Global.(env ()) n com p) (**********************************************************************) (* Shortcut to build a term using tactics *) @@ -133,21 +124,19 @@ let build_constant_by_tactic id ctx sign ?(goal_kind = Global, false, Proof Theo let evd = Evd.from_ctx ctx in let terminator = Proof_global.make_terminator (fun _ -> ()) in let goals = [ (Global.env_of_context sign , typ) ] in - Proof_global.start_proof evd id goal_kind goals terminator; + let pf = Proof_global.start_proof ~ontop:None evd id goal_kind goals terminator in try - let status = by tac in + let pf, status = by tac pf in let open Proof_global in - let { entries; universes } = fst @@ close_proof ~opaque:Transparent ~keep_body_ucst_separate:false (fun x -> x) in + let { entries; universes } = fst @@ close_proof ~opaque:Transparent ~keep_body_ucst_separate:false (fun x -> x) pf in match entries with | [entry] -> - discard_current (); let univs = UState.demote_seff_univs entry universes in entry, status, univs | _ -> CErrors.anomaly Pp.(str "[build_constant_by_tactic] close_proof returned more than one proof term") with reraise -> let reraise = CErrors.push reraise in - Proof_global.discard_current (); iraise reraise let build_by_tactic ?(side_eff=true) env sigma ?(poly=false) typ tac = diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli index 29ab00876a..2fe4bc6385 100644 --- a/proofs/pfedit.mli +++ b/proofs/pfedit.mli @@ -16,29 +16,29 @@ open Environ open Decl_kinds (** {6 ... } *) + +exception NoSuchGoal + (** [get_goal_context n] returns the context of the [n]th subgoal of the current focused proof or raises a [UserError] if there is no focused proof or if there is no more subgoals *) -val get_goal_context : int -> Evd.evar_map * env +val get_goal_context : Proof_global.t -> int -> Evd.evar_map * env (** [get_current_goal_context ()] works as [get_goal_context 1] *) - -val get_current_goal_context : unit -> Evd.evar_map * env +val get_current_goal_context : Proof_global.t -> Evd.evar_map * env (** [get_current_context ()] returns the context of the current focused goal. If there is no focused goal but there is a proof in progress, it returns the corresponding evar_map. If there is no pending proof then it returns the current global environment and empty evar_map. *) - -val get_current_context : ?p:Proof.t -> unit -> Evd.evar_map * env +val get_current_context : Proof_global.t -> Evd.evar_map * env (** {6 ... } *) (** [solve (SelectNth n) tac] applies tactic [tac] to the [n]th - subgoal of the current focused proof or raises a [UserError] if no - proof is focused or if there is no [n]th subgoal. [solve SelectAll + subgoal of the current focused proof. [solve SelectAll tac] applies [tac] to all subgoals. *) val solve : ?with_end_tac:unit Proofview.tactic -> @@ -46,11 +46,10 @@ val solve : ?with_end_tac:unit Proofview.tactic -> Proof.t -> Proof.t * bool (** [by tac] applies tactic [tac] to the 1st subgoal of the current - focused proof or raises a UserError if there is no focused proof or - if there is no more subgoals. + focused proof. Returns [false] if an unsafe tactic has been used. *) -val by : unit Proofview.tactic -> bool +val by : unit Proofview.tactic -> Proof_global.t -> Proof_global.t * bool (** Option telling if unification heuristics should be used. *) val use_unification_heuristics : unit -> bool @@ -60,7 +59,7 @@ val use_unification_heuristics : unit -> bool UserError if no proof is focused or if there is no such [n]th existential variable *) -val instantiate_nth_evar_com : int -> Constrexpr.constr_expr -> unit +val instantiate_nth_evar_com : int -> Constrexpr.constr_expr -> Proof_global.t -> Proof_global.t (** [build_by_tactic typ tac] returns a term of type [typ] by calling [tac]. The return boolean, if [false] indicates the use of an unsafe diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index 6174b75a96..86d3d9601e 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -17,7 +17,6 @@ (***********************************************************************) open Util -open Pp open Names open Context @@ -55,108 +54,66 @@ type pstate = { strength : Decl_kinds.goal_kind; } -type t = pstate list +(* The head of [t] is the actual current proof, the other ones are + to be resumed when the current proof is closed or aborted. *) +type t = pstate * pstate list + +let pstate_map f (pf, pfl) = (f pf, List.map f pfl) let make_terminator f = f let apply_terminator f = f -(* The head of [!pstates] is the actual current proof, the other ones are - to be resumed when the current proof is closed or aborted. *) -let pstates = ref ([] : pstate list) - (* combinators for the current_proof lists *) -let push a l = l := a::!l - -exception NoCurrentProof -let () = CErrors.register_handler begin function - | NoCurrentProof -> CErrors.user_err Pp.(str "No focused proof (No proof-editing in progress).") - | _ -> raise CErrors.Unhandled -end +let push ~ontop a = + match ontop with + | None -> a , [] + | Some (l,ls) -> a, (l :: ls) (*** Proof Global manipulation ***) -let get_all_proof_names () = - List.map Proof.(function pf -> (data pf.proof).name) !pstates - -let cur_pstate () = - match !pstates with - | np::_ -> np - | [] -> raise NoCurrentProof - -let give_me_the_proof () = (cur_pstate ()).proof -let give_me_the_proof_opt () = try Some (give_me_the_proof ()) with | NoCurrentProof -> None -let get_current_proof_name () = (Proof.data (cur_pstate ()).proof).Proof.name -let get_current_persistence () = (cur_pstate ()).strength - -let with_current_proof f = - match !pstates with - | [] -> raise NoCurrentProof - | p :: rest -> - let et = - match p.endline_tactic with - | None -> Proofview.tclUNIT () - | 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; - ret - -let simple_with_current_proof f = with_current_proof (fun t p -> f t p , ()) - -let compact_the_proof () = simple_with_current_proof (fun _ -> Proof.compact) +let get_all_proof_names (pf : t) = + let (pn, pns) = pstate_map Proof.(function pf -> (data pf.proof).name) pf in + pn :: pns + +let give_me_the_proof (ps,_) = ps.proof +let get_current_proof_name (ps,_) = (Proof.data ps.proof).Proof.name +let get_current_persistence (ps,_) = ps.strength + +let with_current_proof f (ps, psl) = + let et = + match ps.endline_tactic with + | None -> Proofview.tclUNIT () + | Some tac -> + let open Geninterp in + let ist = { lfun = Id.Map.empty; poly = pi2 ps.strength; 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 ps.proof in + let ps = { ps with proof = newpr } in + (ps, psl), ret + +let simple_with_current_proof f pf = + let p, () = with_current_proof (fun t p -> f t p , ()) pf in p + +let compact_the_proof pf = simple_with_current_proof (fun _ -> Proof.compact) pf (* Sets the tactic to be used when a tactic line is closed with [...] *) -let set_endline_tactic tac = - match !pstates with - | [] -> raise NoCurrentProof - | p :: rest -> pstates := { p with endline_tactic = Some tac } :: rest - -(* spiwack: it might be considered to move error messages away. - Or else to remove special exceptions from Proof_global. - Arguments for the former: there is no reason Proof_global is only - accessed directly through vernacular commands. Error message should be - pushed to external layers, and so we should be able to have a finer - control on error message on complex actions. *) -let msg_proofs () = - match get_all_proof_names () with - | [] -> (spc () ++ str"(No proof-editing in progress).") - | l -> (str"." ++ fnl () ++ str"Proofs currently edited:" ++ spc () ++ - (pr_sequence Id.print l) ++ str".") - -let there_is_a_proof () = not (List.is_empty !pstates) -let there_are_pending_proofs () = there_is_a_proof () -let check_no_pending_proof () = - if not (there_are_pending_proofs ()) then - () - else begin - CErrors.user_err - (str"Proof editing in progress" ++ msg_proofs () ++ fnl() ++ - str"Use \"Abort All\" first or complete proof(s).") - end +let set_endline_tactic tac (ps, psl) = + { ps with endline_tactic = Some tac }, psl let pf_name_eq id ps = let Proof.{ name } = Proof.data ps.proof in Id.equal name id -let discard_gen id = - pstates := List.filter (fun pf -> not (pf_name_eq id pf)) !pstates - -let discard {CAst.loc;v=id} = - let n = List.length !pstates in - discard_gen id; - if Int.equal (List.length !pstates) n then - CErrors.user_err ?loc - ~hdr:"Pfedit.delete_proof" (str"No such proof" ++ msg_proofs ()) +let discard {CAst.loc;v=id} (ps, psl) = + match List.filter (fun pf -> not (pf_name_eq id pf)) (ps :: psl) with + | [] -> None + | ps :: psl -> Some (ps, psl) -let discard_current () = - if List.is_empty !pstates then raise NoCurrentProof else pstates := List.tl !pstates -let discard_all () = pstates := [] +let discard_current (ps, psl) = + if List.is_empty psl then None else Some List.(hd psl, tl psl) (** [start_proof sigma id pl str goals terminator] starts a proof of name [id] with goals [goals] (a list of pairs of environment and @@ -166,30 +123,30 @@ let discard_all () = pstates := [] end of the proof to close the proof. The proof is started in the evar map [sigma] (which can typically contain universe constraints), and with universe bindings pl. *) -let start_proof sigma name ?(pl=UState.default_univ_decl) kind goals terminator = +let start_proof ~ontop sigma name ?(pl=UState.default_univ_decl) kind goals terminator = let initial_state = { terminator = CEphemeron.create terminator; proof = Proof.start ~name ~poly:(pi2 kind) sigma goals; endline_tactic = None; section_vars = None; - strength = kind; - universe_decl = pl } in - push initial_state pstates + universe_decl = pl; + strength = kind } in + push ~ontop initial_state -let start_dependent_proof name ?(pl=UState.default_univ_decl) kind goals terminator = +let start_dependent_proof ~ontop name ?(pl=UState.default_univ_decl) kind goals terminator = let initial_state = { terminator = CEphemeron.create terminator; proof = Proof.dependent_start ~name ~poly:(pi2 kind) goals; endline_tactic = None; section_vars = None; - strength = kind; - universe_decl = pl } in - push initial_state pstates + universe_decl = pl; + strength = kind } in + push ~ontop initial_state -let get_used_variables () = (cur_pstate ()).section_vars -let get_universe_decl () = (cur_pstate ()).universe_decl +let get_used_variables (pf,_) = pf.section_vars +let get_universe_decl (pf,_) = pf.universe_decl -let set_used_variables l = +let set_used_variables (ps,psl) l = let open Context.Named.Declaration in let env = Global.env () in let ids = List.fold_right Id.Set.add l Id.Set.empty in @@ -210,20 +167,17 @@ let set_used_variables l = else (ctx, all_safe) in let ctx, _ = Environ.fold_named_context aux env ~init:(ctx,ctx_set) in - match !pstates with - | [] -> raise NoCurrentProof - | p :: rest -> - if not (Option.is_empty p.section_vars) then - CErrors.user_err Pp.(str "Used section variables can be declared only once"); - pstates := { p with section_vars = Some ctx} :: rest; - ctx, [] - -let get_open_goals () = - let Proof.{ goals; stack; shelf } = Proof.data (cur_pstate ()).proof in + if not (Option.is_empty ps.section_vars) then + CErrors.user_err Pp.(str "Used section variables can be declared only once"); + (* EJGA: This is always empty thus we should modify the type *) + (ctx, []), ({ ps with section_vars = Some ctx}, psl) + +let get_open_goals (ps, _) = + let Proof.{ goals; stack; shelf } = Proof.data ps.proof in List.length goals + - List.fold_left (+) 0 + List.fold_left (+) 0 (List.map (fun (l1,l2) -> List.length l1 + List.length l2) stack) + - List.length shelf + List.length shelf type closed_proof_output = (Constr.t * Safe_typing.private_constants) list * UState.t @@ -240,8 +194,8 @@ let private_poly_univs = fun () -> !b let close_proof ~opaque ~keep_body_ucst_separate ?feedback_id ~now - (fpl : closed_proof_output Future.computation) = - let { section_vars; proof; terminator; universe_decl; strength } = cur_pstate () in + (fpl : closed_proof_output Future.computation) ps = + let { section_vars; proof; terminator; universe_decl; strength } = ps in let Proof.{ name; poly; entry; initial_euctx } = Proof.data proof in let opaque = match opaque with Opaque -> true | Transparent -> false in let constrain_variables ctx = @@ -339,8 +293,8 @@ let close_proof ~opaque ~keep_body_ucst_separate ?feedback_id ~now universes }, fun pr_ending -> CEphemeron.get terminator pr_ending -let return_proof ?(allow_partial=false) () = - let { proof } = cur_pstate () in +let return_proof ?(allow_partial=false) (ps,_) = + let { proof } = ps in if allow_partial then begin let proofs = Proof.partial_proof proof in let Proof.{sigma=evd} = Proof.data proof in @@ -368,43 +322,44 @@ let return_proof ?(allow_partial=false) () = List.map (fun (c, _) -> (proof_opt c, eff)) initial_goals in proofs, Evd.evar_universe_context evd -let close_future_proof ~opaque ~feedback_id proof = - close_proof ~opaque ~keep_body_ucst_separate:true ~feedback_id ~now:false proof -let close_proof ~opaque ~keep_body_ucst_separate fix_exn = +let close_future_proof ~opaque ~feedback_id (ps, psl) proof = + close_proof ~opaque ~keep_body_ucst_separate:true ~feedback_id ~now:false proof ps + +let close_proof ~opaque ~keep_body_ucst_separate fix_exn (ps, psl) = close_proof ~opaque ~keep_body_ucst_separate ~now:true - (Future.from_val ~fix_exn (return_proof ())) + (Future.from_val ~fix_exn (return_proof (ps,psl))) ps (** Gets the current terminator without checking that the proof has been completed. Useful for the likes of [Admitted]. *) -let get_terminator () = CEphemeron.get ( cur_pstate() ).terminator -let set_terminator hook = - match !pstates with - | [] -> raise NoCurrentProof - | p :: ps -> pstates := { p with terminator = CEphemeron.create hook } :: ps - -let freeze ~marshallable = - if marshallable then CErrors.anomaly (Pp.str"full marshalling of proof state not supported.") - else !pstates -let unfreeze s = pstates := s -let proof_of_state = function { proof }::_ -> proof | _ -> raise NoCurrentProof +let get_terminator (ps, _) = CEphemeron.get ps.terminator +let set_terminator hook (ps, psl) = + { ps with terminator = CEphemeron.create hook }, psl + let copy_terminators ~src ~tgt = - assert(List.length src = List.length tgt); - List.map2 (fun op p -> { p with terminator = op.terminator }) src tgt + let (ps, psl), (ts,tsl) = src, tgt in + assert(List.length psl = List.length tsl); + {ts with terminator = ps.terminator}, List.map2 (fun op p -> { p with terminator = op.terminator }) psl tsl -let update_global_env pf_info = +let update_global_env (pf : t) = + let res, () = with_current_proof (fun _ p -> Proof.in_proof p (fun sigma -> let tac = Proofview.Unsafe.tclEVARS (Evd.update_sigma_env sigma (Global.env ())) in let (p,(status,info)) = Proof.run_tactic (Global.env ()) tac p in - (p, ()))) - -(* XXX: Bullet hook, should be really moved elsewhere *) -let () = - let hook n = - try - let prf = give_me_the_proof () in - (Proof_bullet.suggest prf) - with NoCurrentProof -> mt () - in - Proofview.set_nosuchgoals_hook hook + (p, ()))) pf + in res + +(* XXX: This hook is used to provide a better error w.r.t. bullets, + however the proof engine [surprise!] knows nothing about bullets so + here we have a layering violation. The right fix is to modify the + entry point to handle this and reraise the exception with the + needed information. *) +(* let _ = + * let hook n = + * try + * let prf = give_me_the_proof pf in + * (Proof_bullet.suggest prf) + * with NoCurrentProof -> mt () + * in + * Proofview.set_nosuchgoals_hook hook *) diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli index 38e234eaee..e2e457483b 100644 --- a/proofs/proof_global.mli +++ b/proofs/proof_global.mli @@ -13,23 +13,15 @@ environment. *) type t -val there_are_pending_proofs : unit -> bool -val check_no_pending_proof : unit -> unit +val get_current_proof_name : t -> Names.Id.t +val get_current_persistence : t -> Decl_kinds.goal_kind +val get_all_proof_names : t -> Names.Id.t list -val get_current_proof_name : unit -> Names.Id.t -val get_current_persistence : unit -> Decl_kinds.goal_kind -val get_all_proof_names : unit -> Names.Id.t list +val discard : Names.lident -> t -> t option +val discard_current : t -> t option -val discard : Names.lident -> unit -val discard_current : unit -> unit -val discard_all : unit -> unit - -val give_me_the_proof_opt : unit -> Proof.t option -exception NoCurrentProof -val give_me_the_proof : unit -> Proof.t -(** @raise NoCurrentProof when outside proof mode. *) - -val compact_the_proof : unit -> unit +val give_me_the_proof : t -> Proof.t +val compact_the_proof : t -> t (** When a proof is closed, it is reified into a [proof_object], where [id] is the name of the proof, [entries] the list of the proof terms @@ -60,7 +52,7 @@ type closed_proof = proof_object * proof_terminator val make_terminator : (proof_ending -> unit) -> proof_terminator val apply_terminator : proof_terminator -> proof_ending -> unit -(** [start_proof id str pl goals terminator] starts a proof of name +(** [start_proof ~ontop id str pl goals terminator] starts a proof of name [id] with goals [goals] (a list of pairs of environment and conclusion); [str] describes what kind of theorem/definition this is; [terminator] is used at the end of the proof to close the proof @@ -68,25 +60,25 @@ val apply_terminator : proof_terminator -> proof_ending -> unit morphism). The proof is started in the evar map [sigma] (which can typically contain universe constraints), and with universe bindings pl. *) -val start_proof : +val start_proof : ontop:t option -> Evd.evar_map -> Names.Id.t -> ?pl:UState.universe_decl -> Decl_kinds.goal_kind -> (Environ.env * EConstr.types) list -> - proof_terminator -> unit + proof_terminator -> t (** Like [start_proof] except that there may be dependencies between initial goals. *) -val start_dependent_proof : +val start_dependent_proof : ontop:t option -> Names.Id.t -> ?pl:UState.universe_decl -> Decl_kinds.goal_kind -> - Proofview.telescope -> proof_terminator -> unit + Proofview.telescope -> proof_terminator -> t (** Update the proofs global environment after a side-effecting command (e.g. a sublemma definition) has been run inside it. Assumes there_are_pending_proofs. *) -val update_global_env : unit -> unit +val update_global_env : t -> t (* Takes a function to add to the exceptions data relative to the state in which the proof was built *) -val close_proof : opaque:opacity_flag -> keep_body_ucst_separate:bool -> Future.fix_exn -> closed_proof +val close_proof : opaque:opacity_flag -> keep_body_ucst_separate:bool -> Future.fix_exn -> t -> closed_proof (* Intermediate step necessary to delegate the future. * Both access the current proof state. The former is supposed to be @@ -96,39 +88,36 @@ type closed_proof_output = (Constr.t * Safe_typing.private_constants) list * USt (* If allow_partial is set (default no) then an incomplete proof * is allowed (no error), and a warn is given if the proof is complete. *) -val return_proof : ?allow_partial:bool -> unit -> closed_proof_output -val close_future_proof : opaque:opacity_flag -> feedback_id:Stateid.t -> +val return_proof : ?allow_partial:bool -> t -> closed_proof_output +val close_future_proof : opaque:opacity_flag -> feedback_id:Stateid.t -> t -> closed_proof_output Future.computation -> closed_proof (** Gets the current terminator without checking that the proof has been completed. Useful for the likes of [Admitted]. *) -val get_terminator : unit -> proof_terminator -val set_terminator : proof_terminator -> unit - -val get_open_goals : unit -> int +val get_terminator : t -> proof_terminator +val set_terminator : proof_terminator -> t -> t +val get_open_goals : t -> int (** Runs a tactic on the current proof. Raises [NoCurrentProof] is there is no current proof. The return boolean is set to [false] if an unsafe tactic has been used. *) val with_current_proof : - (unit Proofview.tactic -> Proof.t -> Proof.t * 'a) -> 'a + (unit Proofview.tactic -> Proof.t -> Proof.t * 'a) -> t -> t * 'a val simple_with_current_proof : - (unit Proofview.tactic -> Proof.t -> Proof.t) -> unit + (unit Proofview.tactic -> Proof.t -> Proof.t) -> t -> t (** Sets the tactic to be used when a tactic line is closed with [...] *) -val set_endline_tactic : Genarg.glob_generic_argument -> unit +val set_endline_tactic : Genarg.glob_generic_argument -> t -> t (** 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 -> Constr.named_context * Names.lident list -val get_used_variables : unit -> Constr.named_context option +val set_used_variables : t -> + Names.Id.t list -> (Constr.named_context * Names.lident list) * t + +val get_used_variables : t -> Constr.named_context option (** Get the universe declaration associated to the current proof. *) -val get_universe_decl : unit -> UState.universe_decl +val get_universe_decl : t -> UState.universe_decl -val freeze : marshallable:bool -> t -val unfreeze : t -> unit -val proof_of_state : t -> Proof.t val copy_terminators : src:t -> tgt:t -> t diff --git a/stm/proofBlockDelimiter.ml b/stm/proofBlockDelimiter.ml index 230a3207a8..d13763cdec 100644 --- a/stm/proofBlockDelimiter.ml +++ b/stm/proofBlockDelimiter.ml @@ -49,12 +49,13 @@ let is_focused_goal_simple ~doc id = match state_of_id ~doc id with | `Expired | `Error _ | `Valid None -> `Not | `Valid (Some { Vernacstate.proof }) -> - let proof = Proof_global.proof_of_state proof in - let Proof.{ goals=focused; stack=r1; shelf=r2; given_up=r3; sigma } = Proof.data proof in - let rest = List.(flatten (map (fun (x,y) -> x @ y) r1)) @ r2 @ r3 in - if List.for_all (fun x -> simple_goal sigma x rest) focused - then `Simple focused - else `Not + Option.cata (fun proof -> + let proof = Proof_global.give_me_the_proof proof in + let Proof.{ goals=focused; stack=r1; shelf=r2; given_up=r3; sigma } = Proof.data proof in + let rest = List.(flatten (map (fun (x,y) -> x @ y) r1)) @ r2 @ r3 in + if List.for_all (fun x -> simple_goal sigma x rest) focused + then `Simple focused + else `Not) `Not proof type 'a until = [ `Stop | `Found of static_block_declaration | `Cont of 'a ] diff --git a/stm/stm.ml b/stm/stm.ml index ab388977a5..cc0de0e9df 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -139,8 +139,8 @@ let may_pierce_opaque = function | _ -> false let update_global_env () = - if Proof_global.there_are_pending_proofs () then - Proof_global.update_global_env () + if Vernacstate.Proof_global.there_are_pending_proofs () then + Vernacstate.Proof_global.update_global_env () module Vcs_ = Vcs.Make(Stateid.Self) type future_proof = Proof_global.closed_proof_output Future.computation @@ -872,7 +872,7 @@ end = struct (* {{{ *) let invalidate_cur_state () = cur_id := Stateid.dummy type proof_part = - Proof_global.t * + Proof_global.t option * int * (* Evarutil.meta_counter_summary_tag *) int * (* Evd.evar_counter_summary_tag *) Obligations.program_info Names.Id.Map.t (* Obligations.program_tcc_summary_tag *) @@ -948,8 +948,8 @@ end = struct (* {{{ *) let prev = (VCS.visit id).next in if is_cached_and_valid prev then { s with proof = - Proof_global.copy_terminators - ~src:(get_cached prev).proof ~tgt:s.proof } + Vernacstate.Proof_global.copy_terminators + ~src:((get_cached prev).proof) ~tgt:s.proof } else s with VCS.Expired -> s in VCS.set_state id (FullState s) @@ -957,7 +957,7 @@ end = struct (* {{{ *) if is_cached_and_valid ontop then let s = get_cached ontop in let s = { s with proof = - Proof_global.copy_terminators ~src:s.proof ~tgt:pstate } in + Vernacstate.Proof_global.copy_terminators ~src:s.proof ~tgt:pstate } in let s = { s with system = States.replace_summary s.system begin @@ -1009,8 +1009,8 @@ end = struct (* {{{ *) if feedback_processed then Hooks.(call state_computed ~doc id ~in_cache:false); VCS.reached id; - if Proof_global.there_are_pending_proofs () then - VCS.goals id (Proof_global.get_open_goals ()) + if Vernacstate.Proof_global.there_are_pending_proofs () then + VCS.goals id (Vernacstate.Proof_global.get_open_goals ()) with e -> let (e, info) = CErrors.push e in let good_id = !cur_id in @@ -1121,13 +1121,18 @@ let get_script prf = in find [] (VCS.get_branch_pos branch) +let warn_show_script_deprecated = + CWarnings.create ~name:"deprecated-show-script" ~category:"deprecated" + (fun () -> Pp.str "The “Show Script” command is deprecated.") + let show_script ?proof () = + warn_show_script_deprecated (); try let prf = try match proof with - | None -> Some (Proof_global.get_current_proof_name ()) + | None -> Some (Vernacstate.Proof_global.get_current_proof_name ()) | Some (p,_) -> Some (p.Proof_global.id) - with Proof_global.NoCurrentProof -> None + with Vernacstate.Proof_global.NoCurrentProof -> None in let cmds = get_script prf in let _,_,_,indented_cmds = @@ -1250,9 +1255,8 @@ end = struct (* {{{ *) if Int.equal n 0 then `Stop id else `Cont (n-value) let get_proof ~doc id = - let open Vernacstate in match state_of_id ~doc id with - | `Valid (Some vstate) -> Some (Proof_global.proof_of_state vstate.proof) + | `Valid (Some vstate) -> Option.map Proof_global.give_me_the_proof vstate.Vernacstate.proof | _ -> None let undo_vernac_classifier v ~doc = @@ -1291,7 +1295,7 @@ end = struct (* {{{ *) | Some vcs, _ -> vcs in let cb, _ = try Vcs_aux.find_proof_at_depth vcs (Vcs_aux.proof_nesting vcs) - with Failure _ -> raise Proof_global.NoCurrentProof in + with Failure _ -> raise Vernacstate.Proof_global.NoCurrentProof in let n = fold_until (fun n (_,vcs,_,_,_) -> if List.mem cb (Vcs_.branches vcs) then `Cont (n+1) else `Stop n) 0 id in @@ -1329,7 +1333,7 @@ end = struct (* {{{ *) | None -> true done; !rv - with Not_found | Proof_global.NoCurrentProof -> None + with Not_found | Vernacstate.Proof_global.NoCurrentProof -> None end (* }}} *) @@ -1590,7 +1594,7 @@ end = struct (* {{{ *) let wall_clock2 = Unix.gettimeofday () in Aux_file.record_in_aux_at ?loc "proof_build_time" (Printf.sprintf "%.3f" (wall_clock2 -. wall_clock1)); - let p = Proof_global.return_proof ~allow_partial:drop_pt () in + let p = Vernacstate.Proof_global.return_proof ~allow_partial:drop_pt () in if drop_pt then feedback ~id Complete; p) @@ -1617,7 +1621,7 @@ end = struct (* {{{ *) to set the state manually here *) State.unfreeze st; let pobject, _ = - Proof_global.close_future_proof ~opaque ~feedback_id:stop (Future.from_val ~fix_exn p) in + Vernacstate.Proof_global.close_future_proof ~opaque ~feedback_id:stop (Future.from_val ~fix_exn p) in let terminator = (* The one sent by master is an InvalidKey *) Lemmas.(standard_proof_terminator []) in @@ -1754,15 +1758,15 @@ end = struct (* {{{ *) try Reach.known_state ~doc:dummy_doc (* XXX should be document *) ~cache:false stop; if drop then - let _proof = Proof_global.return_proof ~allow_partial:true () in + let _proof = Vernacstate.Proof_global.return_proof ~allow_partial:true () in `OK_ADMITTED else begin (* The original terminator, a hook, has not been saved in the .vio*) - Proof_global.set_terminator (Lemmas.standard_proof_terminator []); + Vernacstate.Proof_global.set_terminator (Lemmas.standard_proof_terminator []); let opaque = Proof_global.Opaque in let proof = - Proof_global.close_proof ~opaque ~keep_body_ucst_separate:true (fun x -> x) in + Vernacstate.Proof_global.close_proof ~opaque ~keep_body_ucst_separate:true (fun x -> x) in (* We jump at the beginning since the kernel handles side effects by also * looking at the ones that happen to be present in the current env *) Reach.known_state ~doc:dummy_doc (* XXX should be document *) ~cache:false start; @@ -2012,7 +2016,7 @@ end = struct (* {{{ *) try Reach.known_state ~doc:dummy_doc (* XXX should be vcs *) ~cache:false id; State.purify (fun () -> - let Proof.{sigma=sigma0} = Proof.data (Proof_global.give_me_the_proof ()) in + let Proof.{sigma=sigma0} = Proof.data (Vernacstate.Proof_global.give_me_the_proof ()) in let g = Evd.find sigma0 r_goal in let is_ground c = Evarutil.is_ground_term sigma0 c in if not ( @@ -2024,7 +2028,7 @@ end = struct (* {{{ *) "goals only")) else begin let (i, ast) = r_ast in - Proof_global.simple_with_current_proof (fun _ p -> Proof.focus focus_cond () i p); + Vernacstate.Proof_global.simple_with_current_proof (fun _ p -> Proof.focus focus_cond () i p); (* STATE SPEC: * - start : id * - return: id @@ -2033,7 +2037,7 @@ end = struct (* {{{ *) *) let st = Vernacstate.freeze_interp_state ~marshallable:false in ignore(stm_vernac_interp r_state_fb st ast); - let Proof.{sigma} = Proof.data (Proof_global.give_me_the_proof ()) in + let Proof.{sigma} = Proof.data (Vernacstate.Proof_global.give_me_the_proof ()) in match Evd.(evar_body (find sigma r_goal)) with | Evd.Evar_empty -> RespNoProgress | Evd.Evar_defined t -> @@ -2060,8 +2064,14 @@ end = struct (* {{{ *) module TaskQueue = AsyncTaskQueue.MakeQueue(TacTask) () + let stm_fail ~st fail f = + if fail then + Vernacentries.with_fail ~st f + else + f () + let vernac_interp ~solve ~abstract ~cancel_switch nworkers safe_id id - { indentation; verbose; loc; expr = e; strlen } + { indentation; verbose; loc; expr = e; strlen } : unit = let e, time, batch, fail = let rec find ~time ~batch ~fail = function @@ -2071,10 +2081,10 @@ end = struct (* {{{ *) | e -> e, time, batch, fail in find ~time:false ~batch:false ~fail:false e in let st = Vernacstate.freeze_interp_state ~marshallable:false in - Vernacentries.with_fail st fail (fun () -> + stm_fail ~st fail (fun () -> (if time then System.with_time ~batch ~header:(Pp.mt ()) else (fun x -> x)) (fun () -> ignore(TaskQueue.with_n_workers nworkers (fun queue -> - Proof_global.with_current_proof (fun _ p -> + Vernacstate.Proof_global.with_current_proof (fun _ p -> let Proof.{goals} = Proof.data p in let open TacTask in let res = CList.map_i (fun i g -> @@ -2107,7 +2117,7 @@ end = struct (* {{{ *) let open Notations in match Future.join f with | Some (pt, uc) -> - let sigma, env = Pfedit.get_current_context () in + let sigma, env = Vernacstate.Proof_global.get_current_context () in stm_pperr_endline (fun () -> hov 0 ( str"g=" ++ int (Evar.repr gid) ++ spc () ++ str"t=" ++ (Printer.pr_constr_env env sigma pt) ++ spc () ++ @@ -2387,10 +2397,10 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = (Proofview.Goal.goal gl) goals_to_admit then Proofview.give_up else Proofview.tclUNIT () end in - match VCS.get_state base_state with + match (VCS.get_info base_state).state with | FullState { Vernacstate.proof } -> - Proof_global.unfreeze proof; - Proof_global.with_current_proof (fun _ p -> + Option.iter Vernacstate.Proof_global.unfreeze proof; + Vernacstate.Proof_global.with_current_proof (fun _ p -> feedback ~id:id Feedback.AddedAxiom; fst (Pfedit.solve Goal_select.SelectAll None tac p), ()); (* STATE SPEC: @@ -2560,7 +2570,7 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = | VtKeepDefined -> Proof_global.Transparent in let proof = - Proof_global.close_future_proof ~opaque ~feedback_id:id fp in + Vernacstate.Proof_global.close_future_proof ~opaque ~feedback_id:id fp in if not delegate then ignore(Future.compute fp); reach view.next; let st = Vernacstate.freeze_interp_state ~marshallable:false in @@ -2568,13 +2578,13 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = feedback ~id:id Incomplete | { VCS.kind = `Master }, _ -> assert false end; - Proof_global.discard_all () + Vernacstate.Proof_global.discard_all () ), not redefine_qed, true | `Sync (name, `Immediate) -> (fun () -> reach eop; let st = Vernacstate.freeze_interp_state ~marshallable:false in ignore(stm_vernac_interp id st x); - Proof_global.discard_all () + Vernacstate.Proof_global.discard_all () ), true, true | `Sync (name, reason) -> (fun () -> log_processing_sync id name reason; @@ -2593,7 +2603,7 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = | VtKeepOpaque -> Opaque | VtKeepDefined -> Transparent | VtKeepAxiom -> assert false in - Some(Proof_global.close_proof ~opaque + Some(Vernacstate.Proof_global.close_proof ~opaque ~keep_body_ucst_separate:false (State.exn_on id ~valid:eop)) in if keep <> VtKeep VtKeepAxiom then @@ -2604,7 +2614,7 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = let wall_clock3 = Unix.gettimeofday () in Aux_file.record_in_aux_at ?loc:x.loc "proof_check_time" (Printf.sprintf "%.3f" (wall_clock3 -. wall_clock2)); - Proof_global.discard_all () + Vernacstate.Proof_global.discard_all () ), true, true | `MaybeASync (start, nodes, name, delegate) -> (fun () -> reach ~cache:true start; @@ -2865,7 +2875,7 @@ let merge_proof_branch ~valid ?id qast keep brname = VCS.checkout VCS.Branch.master; `Unfocus qed_id | { VCS.kind = `Master } -> - Exninfo.iraise (State.exn_on ~valid Stateid.dummy (Proof_global.NoCurrentProof, Exninfo.null)) + Exninfo.iraise (State.exn_on ~valid Stateid.dummy (Vernacstate.Proof_global.NoCurrentProof, Exninfo.null)) (* When tty is true, this code also does some of the job of the user interface: jump back to a state that is valid *) @@ -3057,7 +3067,7 @@ let process_transaction ~doc ?(newtip=Stateid.fresh ()) let st = Vernacstate.freeze_interp_state ~marshallable:false in ignore(stm_vernac_interp id st x); (* Vernac x may or may not start a proof *) - if not in_proof && Proof_global.there_are_pending_proofs () then + if not in_proof && Vernacstate.Proof_global.there_are_pending_proofs () then begin let bname = VCS.mk_branch_name x in let opacity_of_produced_term = function diff --git a/tactics/auto.ml b/tactics/auto.ml index 2619620eb8..4e0ec1f7e4 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -143,7 +143,8 @@ let conclPattern concl pat tac = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in - constr_bindings env sigma >>= fun constr_bindings -> + constr_bindings env sigma >>= fun constr_bindings -> + Proofview.tclProofInfo [@ocaml.warning "-3"] >>= fun (_name, poly) -> let open Genarg in let open Geninterp in let inj c = match val_tag (topwit Stdarg.wit_constr) with @@ -152,7 +153,9 @@ let conclPattern concl pat tac = in let fold id c accu = Id.Map.add id (inj c) accu in let lfun = Id.Map.fold fold constr_bindings Id.Map.empty in - let ist = { lfun; extra = TacStore.empty } in + let ist = { lfun + ; poly + ; extra = TacStore.empty } in match tac with | GenArg (Glbwit wit, tac) -> Ftactic.run (Geninterp.interp wit ist tac) (fun _ -> Proofview.tclUNIT ()) diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index 3b8232d20a..51708670f5 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -82,7 +82,7 @@ let print_rewrite_hintdb env sigma bas = str (if h.rew_l2r then "rewrite -> " else "rewrite <- ") ++ Printer.pr_lconstr_env env sigma h.rew_lemma ++ str " of type " ++ Printer.pr_lconstr_env env sigma h.rew_type ++ Option.cata (fun tac -> str " then use tactic " ++ - Pputils.pr_glb_generic (Global.env()) tac) (mt ()) h.rew_tac) + Pputils.pr_glb_generic env sigma tac) (mt ()) h.rew_tac) (find_rewrites bas)) type raw_rew_rule = (constr Univ.in_universe_context_set * bool * Genarg.raw_generic_argument option) CAst.t @@ -99,11 +99,15 @@ let one_base general_rewrite_maybe_in tac_main bas = Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (general_rewrite_maybe_in dir c' tc) end in - let lrul = List.map (fun h -> + let open Proofview.Notations in + Proofview.tclProofInfo [@ocaml.warning "-3"] >>= fun (_name, poly) -> + let lrul = List.map (fun h -> let tac = match h.rew_tac with | None -> Proofview.tclUNIT () | Some (Genarg.GenArg (Genarg.Glbwit wit, tac)) -> - let ist = { Geninterp.lfun = Id.Map.empty; extra = Geninterp.TacStore.empty } in + let ist = { Geninterp.lfun = Id.Map.empty + ; poly + ; extra = Geninterp.TacStore.empty } in Ftactic.run (Geninterp.interp wit ist tac) (fun _ -> Proofview.tclUNIT ()) in (h.rew_ctx,h.rew_lemma,h.rew_l2r,tac)) lrul in diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index a3620f4081..44102afd74 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -933,11 +933,12 @@ module Search = struct try (* Instance may try to call this before a proof is set up! Thus, give_me_the_proof will fail. Beware! *) - let name, poly = try - let Proof.{ name; poly } = Proof.data Proof_global.(give_me_the_proof ()) in - name, poly - with | Proof_global.NoCurrentProof -> - Id.of_string "instance", false + let name, poly = + (* try + * let Proof.{ name; poly } = Proof.data Proof_global.(give_me_the_proof ()) in + * name, poly + * with | Proof_global.NoCurrentProof -> *) + Id.of_string "instance", false in let (), pv', (unsafe, shelved, gaveup), _ = Proofview.apply ~name ~poly env tac pv diff --git a/tactics/hints.ml b/tactics/hints.ml index a04a9f9db9..3a7e67cb3f 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -1457,7 +1457,7 @@ let pr_hint env sigma h = match h.obj with | Unfold_nth c -> str"unfold " ++ pr_evaluable_reference c | Extern tac -> - str "(*external*) " ++ Pputils.pr_glb_generic env tac + str "(*external*) " ++ Pputils.pr_glb_generic env sigma tac let pr_id_hint env sigma (id, v) = let pr_pat p = str", pattern " ++ pr_lconstr_pattern_env env sigma p in @@ -1514,9 +1514,9 @@ let pr_hint_term env sigma cl = (str "No hint applicable for current goal") (* print all hints that apply to the concl of the current goal *) -let pr_applicable_hint () = +let pr_applicable_hint pf = let env = Global.env () in - let pts = Proof_global.give_me_the_proof () in + let pts = Proof_global.give_me_the_proof pf in let Proof.{goals;sigma} = Proof.data pts in match goals with | [] -> CErrors.user_err Pp.(str "No focused goal.") diff --git a/tactics/hints.mli b/tactics/hints.mli index dd2c63d351..e84e423faa 100644 --- a/tactics/hints.mli +++ b/tactics/hints.mli @@ -294,7 +294,7 @@ val wrap_hint_warning_fun : env -> evar_map -> (** Printing hints *) val pr_searchtable : env -> evar_map -> Pp.t -val pr_applicable_hint : unit -> Pp.t +val pr_applicable_hint : Proof_global.t -> Pp.t val pr_hint_ref : env -> evar_map -> GlobRef.t -> Pp.t val pr_hint_db_by_name : env -> evar_map -> hint_db_name -> Pp.t val pr_hint_db_env : env -> evar_map -> Hint_db.t -> Pp.t diff --git a/tactics/ppred.mli b/tactics/ppred.mli index b3a306a36f..be21236f4e 100644 --- a/tactics/ppred.mli +++ b/tactics/ppred.mli @@ -9,6 +9,7 @@ val pr_red_flag : ('a -> Pp.t) -> 'a glob_red_flag -> Pp.t val pr_red_expr : ('a -> Pp.t) * ('a -> Pp.t) * ('b -> Pp.t) * ('c -> Pp.t) -> (string -> Pp.t) -> ('a,'b,'c) red_expr_gen -> Pp.t + [@@ocaml.deprecated "Use pr_red_expr_env instead"] val pr_red_expr_env : Environ.env -> Evd.evar_map -> (Environ.env -> Evd.evar_map -> 'a -> Pp.t) * diff --git a/tactics/tactics.ml b/tactics/tactics.ml index b8308dc49b..206f35c8ba 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -1161,6 +1161,7 @@ let tactic_infer_flags with_evar = { Pretyping.fail_evar = not with_evar; Pretyping.expand_evars = true; Pretyping.program_mode = false; + Pretyping.polymorphic = false; } type evars_flag = bool (* true = pose evars false = fail on evars *) diff --git a/test-suite/bugs/closed/bug_4157.v b/test-suite/bugs/closed/bug_4157.v new file mode 100644 index 0000000000..a9e96fcdde --- /dev/null +++ b/test-suite/bugs/closed/bug_4157.v @@ -0,0 +1,272 @@ +(** The following proof is due to a bug in `vm_compute` and was found by + Maxime Dénès and Pierre-Marie Pédrot. *) +Inductive t := +| C_0 : nat -> t +| C_1 : nat -> t +| C_2 : nat -> t +| C_3 : nat -> t +| C_4 : nat -> t +| C_5 : nat -> t +| C_6 : nat -> t +| C_7 : nat -> t +| C_8 : nat -> t +| C_9 : nat -> t +| C_10 : nat -> t +| C_11 : nat -> t +| C_12 : nat -> t +| C_13 : nat -> t +| C_14 : nat -> t +| C_15 : nat -> t +| C_16 : nat -> t +| C_17 : nat -> t +| C_18 : nat -> t +| C_19 : nat -> t +| C_20 : nat -> t +| C_21 : nat -> t +| C_22 : nat -> t +| C_23 : nat -> t +| C_24 : nat -> t +| C_25 : nat -> t +| C_26 : nat -> t +| C_27 : nat -> t +| C_28 : nat -> t +| C_29 : nat -> t +| C_30 : nat -> t +| C_31 : nat -> t +| C_32 : nat -> t +| C_33 : nat -> t +| C_34 : nat -> t +| C_35 : nat -> t +| C_36 : nat -> t +| C_37 : nat -> t +| C_38 : nat -> t +| C_39 : nat -> t +| C_40 : nat -> t +| C_41 : nat -> t +| C_42 : nat -> t +| C_43 : nat -> t +| C_44 : nat -> t +| C_45 : nat -> t +| C_46 : nat -> t +| C_47 : nat -> t +| C_48 : nat -> t +| C_49 : nat -> t +| C_50 : nat -> t +| C_51 : nat -> t +| C_52 : nat -> t +| C_53 : nat -> t +| C_54 : nat -> t +| C_55 : nat -> t +| C_56 : nat -> t +| C_57 : nat -> t +| C_58 : nat -> t +| C_59 : nat -> t +| C_60 : nat -> t +| C_61 : nat -> t +| C_62 : nat -> t +| C_63 : nat -> t +| C_64 : nat -> t +| C_65 : nat -> t +| C_66 : nat -> t +| C_67 : nat -> t +| C_68 : nat -> t +| C_69 : nat -> t +| C_70 : nat -> t +| C_71 : nat -> t +| C_72 : nat -> t +| C_73 : nat -> t +| C_74 : nat -> t +| C_75 : nat -> t +| C_76 : nat -> t +| C_77 : nat -> t +| C_78 : nat -> t +| C_79 : nat -> t +| C_80 : nat -> t +| C_81 : nat -> t +| C_82 : nat -> t +| C_83 : nat -> t +| C_84 : nat -> t +| C_85 : nat -> t +| C_86 : nat -> t +| C_87 : nat -> t +| C_88 : nat -> t +| C_89 : nat -> t +| C_90 : nat -> t +| C_91 : nat -> t +| C_92 : nat -> t +| C_93 : nat -> t +| C_94 : nat -> t +| C_95 : nat -> t +| C_96 : nat -> t +| C_97 : nat -> t +| C_98 : nat -> t +| C_99 : nat -> t +| C_100 : nat -> t +| C_101 : nat -> t +| C_102 : nat -> t +| C_103 : nat -> t +| C_104 : nat -> t +| C_105 : nat -> t +| C_106 : nat -> t +| C_107 : nat -> t +| C_108 : nat -> t +| C_109 : nat -> t +| C_110 : nat -> t +| C_111 : nat -> t +| C_112 : nat -> t +| C_113 : nat -> t +| C_114 : nat -> t +| C_115 : nat -> t +| C_116 : nat -> t +| C_117 : nat -> t +| C_118 : nat -> t +| C_119 : nat -> t +| C_120 : nat -> t +| C_121 : nat -> t +| C_122 : nat -> t +| C_123 : nat -> t +| C_124 : nat -> t +| C_125 : nat -> t +| C_126 : nat -> t +| C_127 : nat -> t +| C_128 : nat -> t +| C_129 : nat -> t +| C_130 : nat -> t +| C_131 : nat -> t +| C_132 : nat -> t +| C_133 : nat -> t +| C_134 : nat -> t +| C_135 : nat -> t +| C_136 : nat -> t +| C_137 : nat -> t +| C_138 : nat -> t +| C_139 : nat -> t +| C_140 : nat -> t +| C_141 : nat -> t +| C_142 : nat -> t +| C_143 : nat -> t +| C_144 : nat -> t +| C_145 : nat -> t +| C_146 : nat -> t +| C_147 : nat -> t +| C_148 : nat -> t +| C_149 : nat -> t +| C_150 : nat -> t +| C_151 : nat -> t +| C_152 : nat -> t +| C_153 : nat -> t +| C_154 : nat -> t +| C_155 : nat -> t +| C_156 : nat -> t +| C_157 : nat -> t +| C_158 : nat -> t +| C_159 : nat -> t +| C_160 : nat -> t +| C_161 : nat -> t +| C_162 : nat -> t +| C_163 : nat -> t +| C_164 : nat -> t +| C_165 : nat -> t +| C_166 : nat -> t +| C_167 : nat -> t +| C_168 : nat -> t +| C_169 : nat -> t +| C_170 : nat -> t +| C_171 : nat -> t +| C_172 : nat -> t +| C_173 : nat -> t +| C_174 : nat -> t +| C_175 : nat -> t +| C_176 : nat -> t +| C_177 : nat -> t +| C_178 : nat -> t +| C_179 : nat -> t +| C_180 : nat -> t +| C_181 : nat -> t +| C_182 : nat -> t +| C_183 : nat -> t +| C_184 : nat -> t +| C_185 : nat -> t +| C_186 : nat -> t +| C_187 : nat -> t +| C_188 : nat -> t +| C_189 : nat -> t +| C_190 : nat -> t +| C_191 : nat -> t +| C_192 : nat -> t +| C_193 : nat -> t +| C_194 : nat -> t +| C_195 : nat -> t +| C_196 : nat -> t +| C_197 : nat -> t +| C_198 : nat -> t +| C_199 : nat -> t +| C_200 : nat -> t +| C_201 : nat -> t +| C_202 : nat -> t +| C_203 : nat -> t +| C_204 : nat -> t +| C_205 : nat -> t +| C_206 : nat -> t +| C_207 : nat -> t +| C_208 : nat -> t +| C_209 : nat -> t +| C_210 : nat -> t +| C_211 : nat -> t +| C_212 : nat -> t +| C_213 : nat -> t +| C_214 : nat -> t +| C_215 : nat -> t +| C_216 : nat -> t +| C_217 : nat -> t +| C_218 : nat -> t +| C_219 : nat -> t +| C_220 : nat -> t +| C_221 : nat -> t +| C_222 : nat -> t +| C_223 : nat -> t +| C_224 : nat -> t +| C_225 : nat -> t +| C_226 : nat -> t +| C_227 : nat -> t +| C_228 : nat -> t +| C_229 : nat -> t +| C_230 : nat -> t +| C_231 : nat -> t +| C_232 : nat -> t +| C_233 : nat -> t +| C_234 : nat -> t +| C_235 : nat -> t +| C_236 : nat -> t +| C_237 : nat -> t +| C_238 : nat -> t +| C_239 : nat -> t +| C_240 : nat -> t +| C_241 : nat -> t +| C_242 : nat -> t +| C_243 : nat -> t +| C_244 : nat -> t +| C_245 : nat -> t +| C_246 : nat -> t +| C_247 : nat -> t +| C_248 : nat -> t +| C_249 : nat -> t +| C_250 : nat -> t +| C_251 : nat -> t +| C_252 : nat -> t +| C_253 : nat -> t +| C_254 : nat -> t +| C_255 : nat -> t +| C_256 : nat -> t. + +Definition is_256 (x : t) : bool := + match x with + | C_256 _ => true + | _ => false + end. + +Lemma falso : False. + assert (is_256 (C_256 0) = true) by reflexivity. + (* The next line was successful in 8.2pl3 *) + Fail assert (is_256 (C_256 0) = false) by (vm_compute; reflexivity). +Abort. diff --git a/test-suite/bugs/closed/bug_9598.v b/test-suite/bugs/closed/bug_9598.v new file mode 100644 index 0000000000..00bbfcf5d9 --- /dev/null +++ b/test-suite/bugs/closed/bug_9598.v @@ -0,0 +1,36 @@ +Module case. + + Inductive pair := K (n1 : nat) (n2 : nat). + Definition fst (p : pair) : nat := match p with K n _ => n end. + + Definition alias_K a b := K a b. + + Fixpoint rec (x : nat) : nat := fst (K 0 (rec x)). + Fixpoint rec_ko (x : nat) : nat := fst (alias_K 0 (rec_ko x)). + +End case. + +Module fixpoint. + + Inductive pair := K (n1 : nat) (n2 : nat). + Fixpoint fst (p : pair) : nat := match p with K n _ => n end. + + Definition alias_K a b := K a b. + + Fixpoint rec (x : nat) : nat := fst (K 0 (rec x)). + Fixpoint rec_ko (x : nat) : nat := fst (alias_K 0 (rec_ko x)). + +End fixpoint. + +Module primproj. + + Set Primitive Projections. + + Inductive pair := K { fst : nat; snd : nat }. + + Definition alias_K a b := K a b. + + Fixpoint rec (x : nat) : nat := fst (K 0 (rec x)). + Fixpoint rec_ko (x : nat) : nat := fst (alias_K 0 (rec_ko x)). + +End primproj. diff --git a/test-suite/bugs/closed/bug_9663.v b/test-suite/bugs/closed/bug_9663.v new file mode 100644 index 0000000000..b5fa601278 --- /dev/null +++ b/test-suite/bugs/closed/bug_9663.v @@ -0,0 +1,2 @@ +Definition id_depfn S T (f : forall x : S, T x) := f. +Definition idn : nat -> nat := @id_depfn _ _ (fun x => x). diff --git a/test-suite/output/Error_msg_diffs.out b/test-suite/output/Error_msg_diffs.out new file mode 100644 index 0000000000..3e337e892d --- /dev/null +++ b/test-suite/output/Error_msg_diffs.out @@ -0,0 +1,12 @@ +File "stdin", line 32, characters 0-12: +[37;41;1mError:[0m +In environment +T : [33;1mType[0m +p : T[37m ->[0m bool +a : T +t1, t2 : btree T +IH1 : count p (rev_tree t1)[37m =[0m count p t1 +IH2 : count p (rev_tree t2)[37m =[0m count p t2 +Unable to unify "[48;2;91;0;0m([1mif[22m p a [1mthen[22m 1 [1melse[22m 0)[37m +[39m (count p [48;2;170;0;0;4mt1[48;2;91;0;0;24m[37m +[39m count p [48;2;170;0;0;4mt2[48;2;91;0;0;24m)[0m" with + "[48;2;0;91;0m([1mif[22m p a [1mthen[22m 1 [1melse[22m 0)[37m +[39m (count p [48;2;0;141;0;4mt2[48;2;0;91;0;24m[37m +[39m count p [48;2;0;141;0;4mt1[48;2;0;91;0;24m)[0m". + diff --git a/test-suite/output/Error_msg_diffs.v b/test-suite/output/Error_msg_diffs.v new file mode 100644 index 0000000000..11c766b210 --- /dev/null +++ b/test-suite/output/Error_msg_diffs.v @@ -0,0 +1,35 @@ +(* coq-prog-args: ("-color" "on" "-async-proofs" "off") *) +(* Re: -async-proofs off, see https://github.com/coq/coq/issues/9671 *) +(* Shows diffs in an error message for an "Unable to unify" error *) +Require Import Arith List Bool. + +Inductive btree (T : Type) : Type := + Leaf | Node (val : T) (t1 t2 : btree T). + +Arguments Leaf {T}. +Arguments Node {T}. + +Fixpoint rev_tree {T : Type} (t : btree T) : btree T := +match t with +| Leaf => Leaf +| Node x t1 t2 => Node x (rev_tree t2) (rev_tree t1) +end. + +Fixpoint count {T : Type} (p : T -> bool) (t : btree T) : nat := +match t with +| Leaf => 0 +| Node x t1 t2 => + (if p x then 1 else 0) + (count p t1 + count p t2) +end. + +Lemma count_rev_tree {T} (p : T -> bool) t : count p (rev_tree t) = count p t. +Proof. +induction t as [ | a t1 IH1 t2 IH2]. + easy. +simpl. +rewrite IH1. +rewrite IH2. +reflexivity. +rewrite (Nat.add_comm (count p t2)). +easy. +Qed. diff --git a/test-suite/output/relaxed_ambiguous_paths.out b/test-suite/output/relaxed_ambiguous_paths.out new file mode 100644 index 0000000000..2a7ce806d7 --- /dev/null +++ b/test-suite/output/relaxed_ambiguous_paths.out @@ -0,0 +1,33 @@ +File "stdin", line 10, characters 0-28: +Warning: Ambiguous paths: [ac; cd] : A >-> D [ambiguous-paths,typechecker] +[ab] : A >-> B +[ab; bd] : A >-> D +[ac] : A >-> C +[bd] : B >-> D +[cd] : C >-> D +[B_A] : B >-> A +[C_A] : C >-> A +[D_B] : D >-> B +[D_A] : D >-> A +[D_C] : D >-> C +[A'_A] : A' >-> A +[B_A'] : B >-> A' +[B_A'; A'_A] : B >-> A +[C_A'] : C >-> A' +[C_A'; A'_A] : C >-> A +[D_B; B_A'] : D >-> A' +[D_A] : D >-> A +[D_B] : D >-> B +[D_C] : D >-> C +File "stdin", line 103, characters 0-86: +Warning: Ambiguous paths: [D_C; C_A'] : D >-> A' +[ambiguous-paths,typechecker] +[A'_A] : A' >-> A +[B_A'] : B >-> A' +[B_A'; A'_A] : B >-> A +[C_A'] : C >-> A' +[C_A'; A'_A] : C >-> A +[D_B; B_A'] : D >-> A' +[D_A] : D >-> A +[D_B] : D >-> B +[D_C] : D >-> C diff --git a/test-suite/output/relaxed_ambiguous_paths.v b/test-suite/output/relaxed_ambiguous_paths.v new file mode 100644 index 0000000000..a4af27539c --- /dev/null +++ b/test-suite/output/relaxed_ambiguous_paths.v @@ -0,0 +1,109 @@ +Module test1. +Section test1. + +Variable (A B C D : Type). +Variable (ab : A -> B) (bd : B -> D) (ac : A -> C) (cd : C -> D). + +Local Coercion ab : A >-> B. +Local Coercion bd : B >-> D. +Local Coercion ac : A >-> C. +Local Coercion cd : C >-> D. + +Print Graph. + +End test1. +End test1. + +Module test2. +Section test2. +Variable (A : Type) (P Q : A -> Prop). + +Record B := { + B_A : A; + B_P : P B_A }. + +Record C := { + C_A : A; + C_Q : Q C_A }. + +Record D := { + D_A : A; + D_P : P D_A; + D_Q : Q D_A }. + +Local Coercion B_A : B >-> A. +Local Coercion C_A : C >-> A. +Local Coercion D_A : D >-> A. +Local Coercion D_B (d : D) : B := Build_B (D_A d) (D_P d). +Local Coercion D_C (d : D) : C := Build_C (D_A d) (D_Q d). + +Print Graph. + +End test2. +End test2. + +Module test3. +Section test3. + +Variable (A : Type) (P Q : A -> Prop). + +Definition A' (x : bool) := A. + +Record B (x : bool) := { + B_A' : A' x; + B_P : P B_A' }. + +Record C (x : bool) := { + C_A' : A' x; + C_Q : Q C_A' }. + +Record D := { + D_A : A; + D_P : P D_A; + D_Q : Q D_A }. + +Local Coercion A'_A (x : bool) (a : A' x) : A := a. +Local Coercion B_A' : B >-> A'. +Local Coercion C_A' : C >-> A'. +Local Coercion D_A : D >-> A. +Local Coercion D_B (d : D) : B false := Build_B false (D_A d) (D_P d). +Local Coercion D_C (d : D) : C true := Build_C true (D_A d) (D_Q d). + +Print Graph. + +End test3. +End test3. + +Module test4. +Section test4. + +Variable (A : Type) (P Q : A -> Prop). + +Record A' (x : bool) := { A'_A : A }. + +Record B (x : bool) := { + B_A' : A' x; + B_P : P (A'_A x B_A') }. + +Record C (x : bool) := { + C_A' : A' x; + C_Q : Q (A'_A x C_A') }. + +Record D := { + D_A : A; + D_P : P D_A; + D_Q : Q D_A }. + +Local Coercion A'_A : A' >-> A. +Local Coercion B_A' : B >-> A'. +Local Coercion C_A' : C >-> A'. +Local Coercion D_A : D >-> A. +Local Coercion D_B (d : D) : B false := + Build_B false (Build_A' false (D_A d)) (D_P d). +Local Coercion D_C (d : D) : C true := + Build_C true (Build_A' true (D_A d)) (D_Q d). + +Print Graph. + +End test4. +End test4. diff --git a/test-suite/ssr/elim_noquant.v b/test-suite/ssr/elim_noquant.v new file mode 100644 index 0000000000..e6662203e9 --- /dev/null +++ b/test-suite/ssr/elim_noquant.v @@ -0,0 +1,29 @@ +Require Import ssreflect. + + +Axiom app : forall T, list T -> list T -> list T. +Arguments app {_}. +Infix "++" := app. + +Lemma test (aT rT : Type) + (pmap : (aT -> option rT) -> list aT -> list rT) + (perm_eq : list rT -> list rT -> Prop) + (f : aT -> option rT) + (g : rT -> aT) + (s t : list aT) + (E : forall T : list aT -> Type, + (forall s1 s2 s3 : list aT, + T (s1 ++ s2 ++ s3) -> T (s2 ++ s1 ++ s3)) -> + T s -> T t) : + perm_eq (pmap f s) (pmap f t). +Proof. +elim/E: (t). +Admitted. + + +Lemma test2 (a b : nat) : a = b -> b = 1. +Proof. +elim. +match goal with |- a = 1 => idtac end. +Admitted. + diff --git a/test-suite/success/cumulativity.v b/test-suite/success/cumulativity.v index 3d97f27b16..31fed98952 100644 --- a/test-suite/success/cumulativity.v +++ b/test-suite/success/cumulativity.v @@ -137,3 +137,12 @@ Module WithIndex. Monomorphic Constraint i < j. Definition bar : eq mkfoo@{i} mkfoo@{j} := eq_refl _. End WithIndex. + +Module CumulApp. + + (* i is covariant here, and we have one parameter *) + Inductive foo@{i} (A : nat) : Type@{i+1} := mkfoo (B : Type@{i}). + + Definition bar@{i j|i<=j} := fun x : foo@{i} 0 => x : foo@{j} 0. + +End CumulApp. diff --git a/toplevel/ccompile.ml b/toplevel/ccompile.ml index 3fe6ad0718..416ea88c1b 100644 --- a/toplevel/ccompile.ml +++ b/toplevel/ccompile.ml @@ -85,7 +85,7 @@ let ensure_exists f = let compile opts copts ~echo ~f_in ~f_out = let open Vernac.State in let check_pending_proofs () = - let pfs = Proof_global.get_all_proof_names () in + let pfs = Vernacstate.Proof_global.get_all_proof_names () in if not (CList.is_empty pfs) then fatal_error (str "There are pending proofs: " ++ (pfs diff --git a/toplevel/coqc.ml b/toplevel/coqc.ml index d4107177a7..fd4c515209 100644 --- a/toplevel/coqc.ml +++ b/toplevel/coqc.ml @@ -46,8 +46,9 @@ let coqc_main () = outputstate copts; flush_all(); + if opts.Coqargs.output_context then begin - let sigma, env = Pfedit.get_current_context () in + let sigma, env = let e = Global.env () in Evd.from_env e, e in Feedback.msg_notice Pp.(Flags.(with_option raw_print (Prettyp.print_full_pure_context env) sigma) ++ fnl ()) end; CProfile.print_profile () diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index 1094fc86b4..b3de8dd85f 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -191,8 +191,8 @@ end from cycling. *) let make_prompt () = try - (Names.Id.to_string (Proof_global.get_current_proof_name ())) ^ " < " - with Proof_global.NoCurrentProof -> + (Names.Id.to_string (Vernacstate.Proof_global.get_current_proof_name ())) ^ " < " + with Vernacstate.Proof_global.NoCurrentProof -> "Coq < " (* the coq prompt added to the default one when in emacs mode @@ -353,7 +353,7 @@ let print_anyway c = let top_goal_print ~doc c oldp newp = try let proof_changed = not (Option.equal cproof oldp newp) in - let print_goals = proof_changed && Proof_global.there_are_pending_proofs () || + let print_goals = proof_changed && Vernacstate.Proof_global.there_are_pending_proofs () || print_anyway c in if not !Flags.quiet && print_goals then begin let dproof = Stm.get_prev_proof ~doc (Stm.get_current_state ~doc) in diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index f7fb26fe3a..626023737b 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -94,9 +94,12 @@ let init_color opts = | Some "" -> false (* No color output *) | Some s -> Topfmt.parse_color_config s; true (* Overwrite all colors *) end - else - false + else begin + Topfmt.default_styles (); false (* textual markers, no color *) + end in + if not term_color then + Proof_diffs.write_color_enabled term_color; if Proof_diffs.show_diffs () && not term_color then (prerr_endline "Error: -diffs requires enabling -color"; exit 1); Topfmt.init_terminal_output ~color:term_color diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index ef1dc6993b..038ff54bf6 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -70,7 +70,7 @@ let interp_vernac ~check ~interactive ~state ({CAst.loc;_} as com) = (* Force the command *) let ndoc = if check then Stm.observe ~doc nsid else doc in - let new_proof = Proof_global.give_me_the_proof_opt () in + let new_proof = Vernacstate.Proof_global.give_me_the_proof_opt () in { state with doc = ndoc; sid = nsid; proof = new_proof; } with reraise -> (* XXX: In non-interactive mode edit_at seems to do very weird @@ -91,7 +91,8 @@ let load_vernac_core ~echo ~check ~interactive ~state file = let input_cleanup () = close_in in_chan; Option.iter close_in in_echo in let in_pa = - Pcoq.Parsable.make ~file:(Loc.InFile file) (Stream.of_channel in_chan) in + Pcoq.Parsable.make ~loc:(Loc.initial (Loc.InFile file)) + (Stream.of_channel in_chan) in let open State in (* ids = For beautify, list of parsed sids *) diff --git a/vernac/classes.ml b/vernac/classes.ml index 1981e24ae4..6a67a1b5d0 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -31,7 +31,7 @@ open Entries let refine_instance = ref false let () = Goptions.(declare_bool_option { - optdepr = false; + optdepr = true; optname = "definition of instances by refining"; optkey = ["Refine";"Instance";"Mode"]; optread = (fun () -> !refine_instance); @@ -144,7 +144,7 @@ let do_declare_instance env sigma ~global ~poly k u ctx ctx' pri decl imps subst Declare.declare_univ_binders (ConstRef cst) (Evd.universe_binders sigma); instance_hook k pri global imps (ConstRef cst) -let declare_instance_open env sigma ?hook ~tac ~program_mode ~global ~poly k id pri imps decl ids term termtype = +let declare_instance_open ~pstate env sigma ?hook ~tac ~program_mode ~global ~poly k id pri imps decl ids term termtype = let kind = Decl_kinds.Global, poly, Decl_kinds.DefinitionBody Decl_kinds.Instance in if program_mode then let hook _ _ vis gr = @@ -163,33 +163,44 @@ let declare_instance_open env sigma ?hook ~tac ~program_mode ~global ~poly k id in let hook = Lemmas.mk_hook hook in let ctx = Evd.evar_universe_context sigma in - ignore (Obligations.add_definition id ?term:constr - ~univdecl:decl typ ctx ~kind:(Global,poly,Instance) ~hook obls) + let _progress = Obligations.add_definition id ?term:constr + ~univdecl:decl typ ctx ~kind:(Global,poly,Instance) ~hook obls in + pstate else - Flags.silently (fun () -> + Some Flags.(silently (fun () -> (* spiwack: it is hard to reorder the actions to do the pretyping after the proof has opened. As a consequence, we use the low-level primitives to code the refinement manually.*) let gls = List.rev (Evd.future_goals sigma) in let sigma = Evd.reset_future_goals sigma in - Lemmas.start_proof id ~pl:decl kind sigma (EConstr.of_constr termtype) + let pstate = Lemmas.start_proof ~ontop:pstate id ~pl:decl kind sigma (EConstr.of_constr termtype) ~hook:(Lemmas.mk_hook - (fun _ _ _ -> instance_hook k pri global imps ?hook)); + (fun _ _ _ -> instance_hook k pri global imps ?hook)) in (* spiwack: I don't know what to do with the status here. *) - if not (Option.is_empty term) then - let init_refine = - Tacticals.New.tclTHENLIST [ - Refine.refine ~typecheck:false (fun sigma -> (sigma,EConstr.of_constr (Option.get term))); - Proofview.Unsafe.tclNEWGOALS (CList.map Proofview.with_empty_state gls); - Tactics.New.reduce_after_refine; - ] - in - ignore (Pfedit.by init_refine) - else ignore (Pfedit.by (Tactics.auto_intros_tac ids)); - (match tac with Some tac -> ignore (Pfedit.by tac) | None -> ())) () + let pstate = + if not (Option.is_empty term) then + let init_refine = + Tacticals.New.tclTHENLIST [ + Refine.refine ~typecheck:false (fun sigma -> (sigma,EConstr.of_constr (Option.get term))); + Proofview.Unsafe.tclNEWGOALS (CList.map Proofview.with_empty_state gls); + Tactics.New.reduce_after_refine; + ] + in + let pstate, _ = Pfedit.by init_refine pstate in + pstate + else + let pstate, _ = Pfedit.by (Tactics.auto_intros_tac ids) pstate in + pstate + in + match tac with + | Some tac -> + let pstate, _ = Pfedit.by tac pstate in + pstate + | None -> + pstate) ()) -let do_instance env env' sigma ?hook ~refine ~tac ~global ~poly ~program_mode cty k u ctx ctx' pri decl imps subst id props = +let do_instance ~pstate env env' sigma ?hook ~refine ~tac ~global ~poly ~program_mode cty k u ctx ctx' pri decl imps subst id props = let props = match props with | Some (true, { CAst.v = CRecord fs }) -> @@ -269,12 +280,14 @@ let do_instance env env' sigma ?hook ~refine ~tac ~global ~poly ~program_mode ct Pretyping.check_evars env (Evd.from_env env) sigma termtype; let termtype = to_constr sigma termtype in let term = Option.map (to_constr ~abort_on_undefined_evars:false sigma) term in - if not (Evd.has_undefined sigma) && not (Option.is_empty props) then - declare_instance_constant k pri global imps ?hook id decl poly sigma (Option.get term) termtype - else if program_mode || refine || Option.is_empty props then - declare_instance_open env sigma ?hook ~tac ~program_mode ~global ~poly k id pri imps decl (List.map RelDecl.get_name ctx) term termtype - else CErrors.user_err Pp.(str "Unsolved obligations remaining."); - id + let pstate = + if not (Evd.has_undefined sigma) && not (Option.is_empty props) then + (declare_instance_constant k pri global imps ?hook id decl poly sigma (Option.get term) termtype; + None) + else if program_mode || refine || Option.is_empty props then + declare_instance_open ~pstate env sigma ?hook ~tac ~program_mode ~global ~poly k id pri imps decl (List.map RelDecl.get_name ctx) term termtype + else CErrors.user_err Pp.(str "Unsolved obligations remaining.") in + id, pstate let interp_instance_context ~program_mode env ctx ?(generalize=false) pl bk cl = let sigma, decl = Constrexpr_ops.interp_univ_decl_opt env pl in @@ -318,7 +331,7 @@ let interp_instance_context ~program_mode env ctx ?(generalize=false) pl bk cl = sigma, cl, u, c', ctx', ctx, imps, args, decl -let new_instance ?(global=false) ?(refine= !refine_instance) ~program_mode +let new_instance ~pstate ?(global=false) ?(refine= !refine_instance) ~program_mode poly ctx (instid, bk, cl) props ?(generalize=true) ?(tac:unit Proofview.tactic option) ?hook pri = let env = Global.env() in @@ -334,7 +347,7 @@ let new_instance ?(global=false) ?(refine= !refine_instance) ~program_mode Namegen.next_global_ident_away i (Termops.vars_of_env env) in let env' = push_rel_context ctx env in - do_instance env env' sigma ?hook ~refine ~tac ~global ~poly ~program_mode + do_instance ~pstate env env' sigma ?hook ~refine ~tac ~global ~poly ~program_mode cty k u ctx ctx' pri decl imps subst id props let declare_new_instance ?(global=false) ~program_mode poly ctx (instid, bk, cl) pri = @@ -358,7 +371,7 @@ let named_of_rel_context l = l ([], []) in ctx -let context poly l = +let context ~pstate poly l = let env = Global.env() in let sigma = Evd.from_env env in let sigma, (_, ((env', fullctx), impls)) = interp_context_evars ~program_mode:false env sigma l in @@ -426,12 +439,12 @@ let context poly l = let decl = (Discharge, poly, Definitional) in let nstatus = match b with | None -> - pi3 (ComAssumption.declare_assumption false decl (t, univs) UnivNames.empty_binders [] impl + pi3 (ComAssumption.declare_assumption ~pstate false decl (t, univs) UnivNames.empty_binders [] impl Declaremods.NoInline (CAst.make id)) | Some b -> let decl = (Discharge, poly, Definition) in let entry = Declare.definition_entry ~univs ~types:t b in - let _ = DeclareDef.declare_definition id decl entry UnivNames.empty_binders [] in + let _gr = DeclareDef.declare_definition ~ontop:pstate id decl entry UnivNames.empty_binders [] in Lib.sections_are_opened () || Lib.is_modtype_strict () in status && nstatus diff --git a/vernac/classes.mli b/vernac/classes.mli index 7e0ec42625..73e4b024ef 100644 --- a/vernac/classes.mli +++ b/vernac/classes.mli @@ -40,6 +40,7 @@ val declare_instance_constant : unit val new_instance : + pstate:Proof_global.t option -> ?global:bool (** Not global by default. *) -> ?refine:bool (** Allow refinement *) -> program_mode:bool -> @@ -51,7 +52,8 @@ val new_instance : ?tac:unit Proofview.tactic -> ?hook:(GlobRef.t -> unit) -> Hints.hint_info_expr -> - Id.t + (* May open a proof *) + Id.t * Proof_global.t option val declare_new_instance : ?global:bool (** Not global by default. *) -> @@ -74,4 +76,8 @@ val id_of_class : typeclass -> Id.t (** returns [false] if, for lack of section, it declares an assumption (unless in a module type). *) -val context : Decl_kinds.polymorphic -> local_binder_expr list -> bool +val context + : pstate:Proof_global.t option + -> Decl_kinds.polymorphic + -> local_binder_expr list + -> bool diff --git a/vernac/comAssumption.ml b/vernac/comAssumption.ml index 37a33daf8f..d7bd64067b 100644 --- a/vernac/comAssumption.ml +++ b/vernac/comAssumption.ml @@ -42,7 +42,7 @@ let should_axiom_into_instance = function true | Global | Local -> !axiom_into_instance -let declare_assumption is_coe (local,p,kind) (c,ctx) pl imps impl nl {CAst.v=ident} = +let declare_assumption ~pstate is_coe (local,p,kind) (c,ctx) pl imps impl nl {CAst.v=ident} = match local with | Discharge when Lib.sections_are_opened () -> let ctx = match ctx with @@ -53,7 +53,7 @@ match local with let _ = declare_variable ident decl in let () = assumption_message ident in let () = - if not !Flags.quiet && Proof_global.there_are_pending_proofs () then + if not !Flags.quiet && Option.has_some pstate then Feedback.msg_info Pp.(str"Variable" ++ spc () ++ Id.print ident ++ strbrk " is not visible from current goals") in @@ -96,11 +96,11 @@ let next_uctx = | Polymorphic_entry _ as uctx -> uctx | Monomorphic_entry _ -> empty_uctx -let declare_assumptions idl is_coe k (c,uctx) pl imps nl = +let declare_assumptions ~pstate idl is_coe k (c,uctx) pl imps nl = let refs, status, _ = List.fold_left (fun (refs,status,uctx) id -> let ref',u',status' = - declare_assumption is_coe k (c,uctx) pl imps false nl id in + declare_assumption ~pstate is_coe k (c,uctx) pl imps false nl id in (ref',u')::refs, status' && status, next_uctx uctx) ([],true,uctx) idl in @@ -132,7 +132,7 @@ let process_assumptions_udecls kind l = in udecl, List.map (fun (coe, (idl, c)) -> coe, (List.map fst idl, c)) l -let do_assumptions ~program_mode kind nl l = +let do_assumptions ~pstate ~program_mode kind nl l = let open Context.Named.Declaration in let env = Global.env () in let udecl, l = process_assumptions_udecls kind l in @@ -173,7 +173,7 @@ let do_assumptions ~program_mode kind nl l = let ubinders = Evd.universe_binders sigma in pi2 (List.fold_left (fun (subst,status,uctx) ((is_coe,idl),t,imps) -> let t = replace_vars subst t in - let refs, status' = declare_assumptions idl is_coe kind (t,uctx) ubinders imps nl in + let refs, status' = declare_assumptions ~pstate idl is_coe kind (t,uctx) ubinders imps nl in let subst' = List.map2 (fun {CAst.v=id} (c,u) -> (id, Constr.mkRef (c,u))) idl refs diff --git a/vernac/comAssumption.mli b/vernac/comAssumption.mli index 2b794b001a..32914cc11b 100644 --- a/vernac/comAssumption.mli +++ b/vernac/comAssumption.mli @@ -17,8 +17,13 @@ open Decl_kinds (** {6 Parameters/Assumptions} *) -val do_assumptions : program_mode:bool -> locality * polymorphic * assumption_object_kind -> - Declaremods.inline -> (ident_decl list * constr_expr) with_coercion list -> bool +val do_assumptions + : pstate:Proof_global.t option + -> program_mode:bool + -> locality * polymorphic * assumption_object_kind + -> Declaremods.inline + -> (ident_decl list * constr_expr) with_coercion list + -> bool (************************************************************************) (** Internal API *) @@ -28,10 +33,16 @@ val do_assumptions : program_mode:bool -> locality * polymorphic * assumption_ob (** returns [false] if the assumption is neither local to a section, nor in a module type and meant to be instantiated. *) -val declare_assumption : coercion_flag -> assumption_kind -> - types in_universes_entry -> - UnivNames.universe_binders -> Impargs.manual_implicits -> - bool (** implicit *) -> Declaremods.inline -> variable CAst.t -> - GlobRef.t * Univ.Instance.t * bool +val declare_assumption + : pstate:Proof_global.t option + -> coercion_flag + -> assumption_kind + -> types in_universes_entry + -> UnivNames.universe_binders + -> Impargs.manual_implicits + -> bool (** implicit *) + -> Declaremods.inline + -> variable CAst.t + -> GlobRef.t * Univ.Instance.t * bool val do_primitive : lident -> CPrimitives.op_or_type -> constr_expr option -> unit diff --git a/vernac/comDefinition.ml b/vernac/comDefinition.ml index 28773a3965..feaf47df18 100644 --- a/vernac/comDefinition.ml +++ b/vernac/comDefinition.ml @@ -90,7 +90,7 @@ let check_definition ~program_mode (ce, evd, _, imps) = check_evars_are_solved ~program_mode env evd; ce -let do_definition ~program_mode ?hook ident k univdecl bl red_option c ctypopt = +let do_definition ~ontop ~program_mode ?hook ident k univdecl bl red_option c ctypopt = let (ce, evd, univdecl, imps as def) = interp_definition ~program_mode univdecl bl (pi2 k) red_option c ctypopt in @@ -114,4 +114,4 @@ let do_definition ~program_mode ?hook ident k univdecl bl red_option c ctypopt = let ce = check_definition ~program_mode def in let uctx = Evd.evar_universe_context evd in let hook_data = Option.map (fun hook -> hook, uctx, []) hook in - ignore(DeclareDef.declare_definition ident k ?hook_data ce (Evd.universe_binders evd) imps ) + ignore(DeclareDef.declare_definition ~ontop ident k ?hook_data ce (Evd.universe_binders evd) imps) diff --git a/vernac/comDefinition.mli b/vernac/comDefinition.mli index 9cb6190fcc..12853d83e0 100644 --- a/vernac/comDefinition.mli +++ b/vernac/comDefinition.mli @@ -16,11 +16,18 @@ open Constrexpr (** {6 Definitions/Let} *) -val do_definition : program_mode:bool -> - ?hook:Lemmas.declaration_hook -> - Id.t -> definition_kind -> universe_decl_expr option -> - local_binder_expr list -> red_expr option -> constr_expr -> - constr_expr option -> unit +val do_definition + : ontop:Proof_global.t option + -> program_mode:bool + -> ?hook:Lemmas.declaration_hook + -> Id.t + -> definition_kind + -> universe_decl_expr option + -> local_binder_expr list + -> red_expr option + -> constr_expr + -> constr_expr option + -> unit (************************************************************************) (** Internal API *) diff --git a/vernac/comFixpoint.ml b/vernac/comFixpoint.ml index 2f00b41b7c..2aadbd224f 100644 --- a/vernac/comFixpoint.ml +++ b/vernac/comFixpoint.ml @@ -255,7 +255,8 @@ let interp_fixpoint ~cofix l ntns = let uctx,fix = ground_fixpoint env evd fix in (fix,pl,uctx,info) -let declare_fixpoint local poly ((fixnames,fixrs,fixdefs,fixtypes),pl,ctx,fiximps) indexes ntns = +let declare_fixpoint ~ontop local poly ((fixnames,fixrs,fixdefs,fixtypes),pl,ctx,fiximps) indexes ntns = + let pstate = if List.exists Option.is_empty fixdefs then (* Some bodies to define by proof *) let thms = @@ -265,8 +266,9 @@ let declare_fixpoint local poly ((fixnames,fixrs,fixdefs,fixtypes),pl,ctx,fiximp Some (List.map (Option.cata (EConstr.of_constr %> Tactics.exact_no_check) Tacticals.New.tclIDTAC) fixdefs) in let evd = Evd.from_ctx ctx in - Lemmas.start_proof_with_initialization (local,poly,DefinitionBody Fixpoint) - evd pl (Some(false,indexes,init_tac)) thms None + Some + (Lemmas.start_proof_with_initialization ~ontop (local,poly,DefinitionBody Fixpoint) + evd pl (Some(false,indexes,init_tac)) thms None) else begin (* We shortcut the proof process *) let fixdefs = List.map Option.get fixdefs in @@ -282,15 +284,18 @@ let declare_fixpoint local poly ((fixnames,fixrs,fixdefs,fixtypes),pl,ctx,fiximp let ctx = Evd.check_univ_decl ~poly evd pl in let pl = Evd.universe_binders evd in let fixdecls = List.map Safe_typing.mk_pure_proof fixdecls in - ignore (List.map4 (DeclareDef.declare_fix (local, poly, Fixpoint) pl ctx) + ignore (List.map4 (DeclareDef.declare_fix ~ontop (local, poly, Fixpoint) pl ctx) fixnames fixdecls fixtypes fiximps); (* Declare the recursive definitions *) fixpoint_message (Some indexes) fixnames; - end; + None + end in (* Declare notations *) - List.iter (Metasyntax.add_notation_interpretation (Global.env())) ntns + List.iter (Metasyntax.add_notation_interpretation (Global.env())) ntns; + pstate -let declare_cofixpoint local poly ((fixnames,fixrs,fixdefs,fixtypes),pl,ctx,fiximps) ntns = +let declare_cofixpoint ~ontop local poly ((fixnames,fixrs,fixdefs,fixtypes),pl,ctx,fiximps) ntns = + let pstate = if List.exists Option.is_empty fixdefs then (* Some bodies to define by proof *) let thms = @@ -300,8 +305,8 @@ let declare_cofixpoint local poly ((fixnames,fixrs,fixdefs,fixtypes),pl,ctx,fixi Some (List.map (Option.cata (EConstr.of_constr %> Tactics.exact_no_check) Tacticals.New.tclIDTAC) fixdefs) in let evd = Evd.from_ctx ctx in - Lemmas.start_proof_with_initialization (Global,poly, DefinitionBody CoFixpoint) - evd pl (Some(true,[],init_tac)) thms None + Some (Lemmas.start_proof_with_initialization ~ontop (Global,poly, DefinitionBody CoFixpoint) + evd pl (Some(true,[],init_tac)) thms None) else begin (* We shortcut the proof process *) let fixdefs = List.map Option.get fixdefs in @@ -314,13 +319,15 @@ let declare_cofixpoint local poly ((fixnames,fixrs,fixdefs,fixtypes),pl,ctx,fixi let evd = Evd.restrict_universe_context evd vars in let ctx = Evd.check_univ_decl ~poly evd pl in let pl = Evd.universe_binders evd in - ignore (List.map4 (DeclareDef.declare_fix (local, poly, CoFixpoint) pl ctx) + ignore (List.map4 (DeclareDef.declare_fix ~ontop (local, poly, CoFixpoint) pl ctx) fixnames fixdecls fixtypes fiximps); (* Declare the recursive definitions *) - cofixpoint_message fixnames - end; + cofixpoint_message fixnames; + None + end in (* Declare notations *) - List.iter (Metasyntax.add_notation_interpretation (Global.env())) ntns + List.iter (Metasyntax.add_notation_interpretation (Global.env())) ntns; + pstate let extract_decreasing_argument limit = function | (na,CStructRec) -> na @@ -348,16 +355,18 @@ let check_safe () = let flags = Environ.typing_flags (Global.env ()) in flags.check_universes && flags.check_guarded -let do_fixpoint local poly l = +let do_fixpoint ~ontop local poly l = let fixl, ntns = extract_fixpoint_components true l in let (_, _, _, info as fix) = interp_fixpoint ~cofix:false fixl ntns in let possible_indexes = List.map compute_possible_guardness_evidences info in - declare_fixpoint local poly fix possible_indexes ntns; - if not (check_safe ()) then Feedback.feedback Feedback.AddedAxiom else () + let pstate = declare_fixpoint ~ontop local poly fix possible_indexes ntns in + if not (check_safe ()) then Feedback.feedback Feedback.AddedAxiom else (); + pstate -let do_cofixpoint local poly l = +let do_cofixpoint ~ontop local poly l = let fixl,ntns = extract_cofixpoint_components l in let cofix = interp_fixpoint ~cofix:true fixl ntns in - declare_cofixpoint local poly cofix ntns; - if not (check_safe ()) then Feedback.feedback Feedback.AddedAxiom else () + let pstate = declare_cofixpoint ~ontop local poly cofix ntns in + if not (check_safe ()) then Feedback.feedback Feedback.AddedAxiom else (); + pstate diff --git a/vernac/comFixpoint.mli b/vernac/comFixpoint.mli index 9bcb53697b..15ff5f4498 100644 --- a/vernac/comFixpoint.mli +++ b/vernac/comFixpoint.mli @@ -19,12 +19,14 @@ open Vernacexpr (** Entry points for the vernacular commands Fixpoint and CoFixpoint *) val do_fixpoint : + ontop:Proof_global.t option -> (* When [false], assume guarded. *) - locality -> polymorphic -> (fixpoint_expr * decl_notation list) list -> unit + locality -> polymorphic -> (fixpoint_expr * decl_notation list) list -> Proof_global.t option val do_cofixpoint : + ontop:Proof_global.t option -> (* When [false], assume guarded. *) - locality -> polymorphic -> (cofixpoint_expr * decl_notation list) list -> unit + locality -> polymorphic -> (cofixpoint_expr * decl_notation list) list -> Proof_global.t option (************************************************************************) (** Internal API *) @@ -81,15 +83,20 @@ val interp_fixpoint : (** [Not used so far] *) val declare_fixpoint : + ontop:Proof_global.t option -> locality -> polymorphic -> recursive_preentry * UState.universe_decl * UState.t * (Constr.rel_context * Impargs.manual_implicits * int option) list -> - Proof_global.lemma_possible_guards -> decl_notation list -> unit + Proof_global.lemma_possible_guards -> decl_notation list -> + Proof_global.t option -val declare_cofixpoint : locality -> polymorphic -> +val declare_cofixpoint : + ontop:Proof_global.t option -> + locality -> polymorphic -> recursive_preentry * UState.universe_decl * UState.t * (Constr.rel_context * Impargs.manual_implicits * int option) list -> - decl_notation list -> unit + decl_notation list -> + Proof_global.t option (** Very private function, do not use *) val compute_possible_guardness_evidences : diff --git a/vernac/declareDef.ml b/vernac/declareDef.ml index 7dcd098183..052832244b 100644 --- a/vernac/declareDef.ml +++ b/vernac/declareDef.ml @@ -33,12 +33,12 @@ let get_locality id ~kind = function | Local -> true | Global -> false -let declare_definition ident (local, p, k) ?hook_data ce pl imps = +let declare_definition ~ontop ident (local, p, k) ?hook_data ce pl imps = let fix_exn = Future.fix_exn_of ce.const_entry_body in let gr = match local with | Discharge when Lib.sections_are_opened () -> let _ = declare_variable ident (Lib.cwd(), SectionLocalDef ce, IsDefinition k) in - let () = if Proof_global.there_are_pending_proofs () then warn_definition_not_visible ident in + let () = if Option.has_some ontop then warn_definition_not_visible ident in VarRef ident | Discharge | Local | Global -> let local = get_locality ident ~kind:"definition" local in @@ -57,9 +57,9 @@ let declare_definition ident (local, p, k) ?hook_data ce pl imps = end; gr -let declare_fix ?(opaque = false) ?hook_data (_,poly,_ as kind) pl univs f ((def,_),eff) t imps = +let declare_fix ~ontop ?(opaque = false) ?hook_data (_,poly,_ as kind) pl univs f ((def,_),eff) t imps = let ce = definition_entry ~opaque ~types:t ~univs ~eff def in - declare_definition f kind ?hook_data ce pl imps + declare_definition ~ontop f kind ?hook_data ce pl imps let check_definition_evars ~allow_evars sigma = let env = Global.env () in diff --git a/vernac/declareDef.mli b/vernac/declareDef.mli index 3f95ec7107..8e4f4bf7fb 100644 --- a/vernac/declareDef.mli +++ b/vernac/declareDef.mli @@ -14,7 +14,8 @@ open Decl_kinds val get_locality : Id.t -> kind:string -> Decl_kinds.locality -> bool val declare_definition - : Id.t + : ontop:Proof_global.t option + -> Id.t -> definition_kind -> ?hook_data:(Lemmas.declaration_hook * UState.t * (Id.t * Constr.t) list) -> Safe_typing.private_constants Entries.definition_entry @@ -23,7 +24,8 @@ val declare_definition -> GlobRef.t val declare_fix - : ?opaque:bool + : ontop:Proof_global.t option + -> ?opaque:bool -> ?hook_data:(Lemmas.declaration_hook * UState.t * (Id.t * Constr.t) list) -> definition_kind -> UnivNames.universe_binders diff --git a/vernac/himsg.ml b/vernac/himsg.ml index 1c58abc2fd..32754478a5 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -126,7 +126,7 @@ let display_eq ~flags env sigma t1 t2 = let rec pr_explicit_aux env sigma t1 t2 = function | [] -> (* no specified flags: default. *) - (quote (Printer.pr_leconstr_env env sigma t1), quote (Printer.pr_leconstr_env env sigma t2)) + Printer.pr_leconstr_env env sigma t1, Printer.pr_leconstr_env env sigma t2 | flags :: rem -> let equal = display_eq ~flags env sigma t1 t2 in if equal then @@ -138,7 +138,7 @@ let rec pr_explicit_aux env sigma t1 t2 = function in let ct2 = Flags.with_options flags (fun () -> extern_constr false env sigma t2) () in - quote (Ppconstr.pr_lconstr_expr ct1), quote (Ppconstr.pr_lconstr_expr ct2) + Ppconstr.pr_lconstr_expr env sigma ct1, Ppconstr.pr_lconstr_expr env sigma ct2 let explicit_flags = let open Constrextern in @@ -149,8 +149,25 @@ let explicit_flags = [print_implicits; print_coercions; print_no_symbol]; (* Then more! *) [print_universes; print_implicits; print_coercions; print_no_symbol] (* and more! *) ] +let with_diffs pm pn = + try + let tokenize_string = Proof_diffs.tokenize_string in + Pp_diff.diff_pp ~tokenize_string pm pn + with Pp_diff.Diff_Failure msg -> + begin + try ignore(Sys.getenv("HIDEDIFFFAILUREMSG")) + with Not_found -> + Feedback.msg_warning Pp.( + hov 0 (str ("Diff failure: " ^ msg) ++ spc () ++ + hov 0 (str "Showing message without diff highlighting" ++ spc () ++ + hov 0 (str "Please report at " ++ str Coq_config.wwwbugtracker ++ str ".")))) + end; + pm, pn + let pr_explicit env sigma t1 t2 = - pr_explicit_aux env sigma t1 t2 explicit_flags + let p1, p2 = pr_explicit_aux env sigma t1 t2 explicit_flags in + let p1, p2 = with_diffs p1 p2 in + quote p1, quote p2 let pr_db env i = try @@ -1074,16 +1091,18 @@ let explain_unbound_method env sigma cid { CAst.v = id } = str "Unbound method name " ++ Id.print (id) ++ spc () ++ str"of class" ++ spc () ++ pr_global cid ++ str "." -let pr_constr_exprs exprs = +let pr_constr_exprs env sigma exprs = hv 0 (List.fold_right - (fun d pps -> ws 2 ++ Ppconstr.pr_constr_expr d ++ pps) + (fun d pps -> ws 2 ++ Ppconstr.pr_constr_expr env sigma d ++ pps) exprs (mt ())) let explain_mismatched_contexts env c i j = + let sigma = Evd.from_env env in + let pm, pn = with_diffs (pr_rel_context env sigma j) (pr_constr_exprs env sigma i) in str"Mismatched contexts while declaring instance: " ++ brk (1,1) ++ - hov 1 (str"Expected:" ++ brk (1, 1) ++ pr_rel_context env (Evd.from_env env) j) ++ + hov 1 (str"Expected:" ++ brk (1, 1) ++ pm) ++ fnl () ++ brk (1,1) ++ - hov 1 (str"Found:" ++ brk (1, 1) ++ pr_constr_exprs i) + hov 1 (str"Found:" ++ brk (1, 1) ++ pn) let explain_typeclass_error env sigma = function | NotAClass c -> explain_not_a_class env sigma c @@ -1092,10 +1111,11 @@ let explain_typeclass_error env sigma = function (* Refiner errors *) let explain_refiner_bad_type env sigma arg ty conclty = + let pm, pn = with_diffs (pr_lconstr_env env sigma ty) (pr_lconstr_env env sigma conclty) in str "Refiner was given an argument" ++ brk(1,1) ++ pr_lconstr_env env sigma arg ++ spc () ++ - str "of type" ++ brk(1,1) ++ pr_lconstr_env env sigma ty ++ spc () ++ - str "instead of" ++ brk(1,1) ++ pr_lconstr_env env sigma conclty ++ str "." + str "of type" ++ brk(1,1) ++ pm ++ spc () ++ + str "instead of" ++ brk(1,1) ++ pn ++ str "." let explain_refiner_unresolved_bindings l = str "Unable to find an instance for the " ++ diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml index 0d0732cbb4..1c7cc5e636 100644 --- a/vernac/lemmas.ml +++ b/vernac/lemmas.ml @@ -213,8 +213,11 @@ let save ?export_seff id const uctx do_guard (locality,poly,kind) hook universes let default_thm_id = Id.of_string "Unnamed_thm" -let fresh_name_for_anonymous_theorem () = - let avoid = Id.Set.of_list (Proof_global.get_all_proof_names ()) in +let fresh_name_for_anonymous_theorem ~pstate = + let avoid = match pstate with + | None -> Id.Set.empty + | Some pstate -> Id.Set.of_list (Proof_global.get_all_proof_names pstate) + in next_global_ident_away default_thm_id avoid let check_name_freshness locality {CAst.loc;v=id} : unit = @@ -224,7 +227,7 @@ let check_name_freshness locality {CAst.loc;v=id} : unit = then user_err ?loc (Id.print id ++ str " already exists.") -let save_remaining_recthms (locality,p,kind) norm univs body opaq i (id,(t_i,(_,imps))) = +let save_remaining_recthms env sigma (locality,p,kind) norm univs body opaq i (id,(t_i,(_,imps))) = let t_i = norm t_i in let k = IsAssumption Conjectural in match body with @@ -260,7 +263,6 @@ let save_remaining_recthms (locality,p,kind) norm univs body opaq i (id,(t_i,(_, | Lambda(na,ty,t) -> mkLambda(na,ty,body_i t) | App (t, args) -> mkApp (body_i t, args) | _ -> - let sigma, env = Pfedit.get_current_context () in anomaly Pp.(str "Not a proof by induction: " ++ Printer.pr_constr_env env sigma body ++ str ".") in let body_i = body_i body in match locality with @@ -333,7 +335,7 @@ let initialize_named_context_for_proof () = let d = if variable_opacity id then NamedDecl.drop_body d else d in Environ.push_named_context_val d signv) sign Environ.empty_named_context_val -let start_proof id ?pl kind sigma ?terminator ?sign ?(compute_guard=[]) ?(hook : declaration_hook option) c = +let start_proof ~ontop id ?pl kind sigma ?terminator ?sign ?(compute_guard=[]) ?hook c = let terminator = match terminator with | None -> standard_proof_terminator ?hook compute_guard | Some terminator -> terminator ?hook compute_guard @@ -344,7 +346,7 @@ let start_proof id ?pl kind sigma ?terminator ?sign ?(compute_guard=[]) ?(hook : | None -> initialize_named_context_for_proof () in let goals = [ Global.env_of_context sign , c ] in - Proof_global.start_proof sigma id ?pl kind goals terminator + Proof_global.start_proof ~ontop sigma id ?pl kind goals terminator let rec_tac_initializer finite guard thms snl = if finite then @@ -360,7 +362,7 @@ let rec_tac_initializer finite guard thms snl = | (id,n,_)::l -> Tactics.mutual_fix id n l 0 | _ -> assert false -let start_proof_with_initialization ?hook kind sigma decl recguard thms snl = +let start_proof_with_initialization ~ontop ?hook kind sigma decl recguard thms snl = let intro_tac (_, (_, (ids, _))) = Tactics.auto_intros_tac ids in let init_tac,guard = match recguard with | Some (finite,guard,init_tac) -> @@ -386,18 +388,20 @@ let start_proof_with_initialization ?hook kind sigma decl recguard thms snl = let norm c = EConstr.to_constr (Evd.from_ctx ctx) c in let body = Option.map EConstr.of_constr body in let uctx = UState.check_univ_decl ~poly:(pi2 kind) ctx decl in - List.map_i (save_remaining_recthms kind norm uctx body opaq) 1 other_thms in + let env = Global.env () in + List.map_i (save_remaining_recthms env sigma kind norm uctx body opaq) 1 other_thms in let thms_data = (strength,ref,imps)::other_thms_data in List.iter (fun (strength,ref,imps) -> maybe_declare_manual_implicits false ref imps; call_hook ?hook ctx [] strength ref) thms_data in - start_proof id ~pl:decl kind sigma t ~hook ~compute_guard:guard; - ignore (Proof_global.with_current_proof (fun _ p -> + let pstate = start_proof ~ontop id ~pl:decl kind sigma t ~hook ~compute_guard:guard in + let pstate, _ = Proof_global.with_current_proof (fun _ p -> match init_tac with | None -> p,(true,[]) - | Some tac -> Proof.run_tactic Global.(env ()) tac p)) + | Some tac -> Proof.run_tactic Global.(env ()) tac p) pstate in + pstate -let start_proof_com ~program_mode ?inference_hook ?hook kind thms = +let start_proof_com ~program_mode ~ontop ?inference_hook ?hook kind thms = let env0 = Global.env () in let decl = fst (List.hd thms) in let evd, decl = Constrexpr_ops.interp_univ_decl_opt env0 (snd decl) in @@ -429,7 +433,7 @@ let start_proof_com ~program_mode ?inference_hook ?hook kind thms = else (* We fix the variables to ensure they won't be lowered to Set *) Evd.fix_undefined_variables evd in - start_proof_with_initialization ?hook kind evd decl recguard thms snl + start_proof_with_initialization ~ontop ?hook kind evd decl recguard thms snl (* Saving a proof *) @@ -444,58 +448,65 @@ let () = optread = (fun () -> !keep_admitted_vars); optwrite = (fun b -> keep_admitted_vars := b) } -let save_proof ?proof = function - | Vernacexpr.Admitted -> - let pe = - let open Proof_global in - match proof with - | Some ({ id; entries; persistence = k; universes }, _) -> - if List.length entries <> 1 then - user_err Pp.(str "Admitted does not support multiple statements"); - let { const_entry_secctx; const_entry_type } = List.hd entries in - if const_entry_type = None then - user_err Pp.(str "Admitted requires an explicit statement"); - let typ = Option.get const_entry_type in - let ctx = UState.univ_entry ~poly:(pi2 k) universes in - let sec_vars = if !keep_admitted_vars then const_entry_secctx else None in - Admitted(id, k, (sec_vars, (typ, ctx), None), universes) - | None -> - let pftree = Proof_global.give_me_the_proof () in - let gk = Proof_global.get_current_persistence () in - let Proof.{ name; poly; entry } = Proof.data pftree in - let typ = match Proofview.initial_goals entry with - | [typ] -> snd typ - | _ -> - CErrors.anomaly - ~label:"Lemmas.save_proof" (Pp.str "more than one statement.") - in - let typ = EConstr.Unsafe.to_constr typ in - let universes = Proof.((data pftree).initial_euctx) in - (* This will warn if the proof is complete *) - let pproofs, _univs = - Proof_global.return_proof ~allow_partial:true () in - let sec_vars = - if not !keep_admitted_vars then None - else match Proof_global.get_used_variables(), pproofs with - | Some _ as x, _ -> x - | None, (pproof, _) :: _ -> - let env = Global.env () in - let ids_typ = Environ.global_vars_set env typ in - let ids_def = Environ.global_vars_set env pproof in - Some (Environ.keep_hyps env (Id.Set.union ids_typ ids_def)) - | _ -> None in - let decl = Proof_global.get_universe_decl () in - let ctx = UState.check_univ_decl ~poly universes decl in - Admitted(name,gk,(sec_vars, (typ, ctx), None), universes) - in - Proof_global.apply_terminator (Proof_global.get_terminator ()) pe - | Vernacexpr.Proved (opaque,idopt) -> - let (proof_obj,terminator) = - match proof with - | None -> - Proof_global.close_proof ~opaque ~keep_body_ucst_separate:false (fun x -> x) - | Some proof -> proof +let save_proof_admitted ?proof ~pstate = + let pe = + let open Proof_global in + match proof with + | Some ({ id; entries; persistence = k; universes }, _) -> + if List.length entries <> 1 then + user_err Pp.(str "Admitted does not support multiple statements"); + let { const_entry_secctx; const_entry_type } = List.hd entries in + if const_entry_type = None then + user_err Pp.(str "Admitted requires an explicit statement"); + let typ = Option.get const_entry_type in + let ctx = UState.univ_entry ~poly:(pi2 k) universes in + let sec_vars = if !keep_admitted_vars then const_entry_secctx else None in + Admitted(id, k, (sec_vars, (typ, ctx), None), universes) + | None -> + let pftree = Proof_global.give_me_the_proof pstate in + let gk = Proof_global.get_current_persistence pstate in + let Proof.{ name; poly; entry } = Proof.data pftree in + let typ = match Proofview.initial_goals entry with + | [typ] -> snd typ + | _ -> + CErrors.anomaly + ~label:"Lemmas.save_proof" (Pp.str "more than one statement.") in - (* if the proof is given explicitly, nothing has to be deleted *) - if Option.is_empty proof then Proof_global.discard_current (); - Proof_global.(apply_terminator terminator (Proved (opaque,idopt,proof_obj))) + let typ = EConstr.Unsafe.to_constr typ in + let universes = Proof.((data pftree).initial_euctx) in + (* This will warn if the proof is complete *) + let pproofs, _univs = + Proof_global.return_proof ~allow_partial:true pstate in + let sec_vars = + if not !keep_admitted_vars then None + else match Proof_global.get_used_variables pstate, pproofs with + | Some _ as x, _ -> x + | None, (pproof, _) :: _ -> + let env = Global.env () in + let ids_typ = Environ.global_vars_set env typ in + let ids_def = Environ.global_vars_set env pproof in + Some (Environ.keep_hyps env (Id.Set.union ids_typ ids_def)) + | _ -> None in + let decl = Proof_global.get_universe_decl pstate in + let ctx = UState.check_univ_decl ~poly universes decl in + Admitted(name,gk,(sec_vars, (typ, ctx), None), universes) + in + Proof_global.apply_terminator (Proof_global.get_terminator pstate) pe + +let save_proof_proved ?proof ?pstate ~opaque ~idopt = + (* Invariant (uh) *) + if Option.is_empty pstate && Option.is_empty proof then + user_err (str "No focused proof (No proof-editing in progress)."); + let (proof_obj,terminator) = + match proof with + | None -> + (* XXX: The close_proof and proof state API should be refactored + so it is possible to insert proofs properly into the state *) + let pstate = Option.get pstate in + Proof_global.close_proof ~opaque ~keep_body_ucst_separate:false (fun x -> x) pstate + | Some proof -> proof + in + (* if the proof is given explicitly, nothing has to be deleted *) + let pstate = if Option.is_empty proof then Proof_global.discard_current Option.(get pstate) else pstate in + Proof_global.(apply_terminator terminator (Proved (opaque,idopt,proof_obj))); + pstate diff --git a/vernac/lemmas.mli b/vernac/lemmas.mli index 72c666e903..1f70cfa1ad 100644 --- a/vernac/lemmas.mli +++ b/vernac/lemmas.mli @@ -37,30 +37,32 @@ val call_hook -> ?fix_exn:Future.fix_exn -> hook_type -val start_proof : Id.t -> ?pl:UState.universe_decl -> goal_kind -> Evd.evar_map -> +val start_proof : ontop:Proof_global.t option -> Id.t -> ?pl:UState.universe_decl -> goal_kind -> Evd.evar_map -> ?terminator:(?hook:declaration_hook -> Proof_global.lemma_possible_guards -> Proof_global.proof_terminator) -> ?sign:Environ.named_context_val -> ?compute_guard:Proof_global.lemma_possible_guards -> - ?hook:declaration_hook -> EConstr.types -> unit + ?hook:declaration_hook -> EConstr.types -> Proof_global.t -val start_proof_com : - program_mode:bool -> ?inference_hook:Pretyping.inference_hook -> - ?hook:declaration_hook -> goal_kind -> Vernacexpr.proof_expr list -> - unit +val start_proof_com + : program_mode:bool + -> ontop:Proof_global.t option + -> ?inference_hook:Pretyping.inference_hook + -> ?hook:declaration_hook -> goal_kind -> Vernacexpr.proof_expr list + -> Proof_global.t -val start_proof_with_initialization : +val start_proof_with_initialization : ontop:Proof_global.t option -> ?hook:declaration_hook -> goal_kind -> Evd.evar_map -> UState.universe_decl -> (bool * Proof_global.lemma_possible_guards * unit Proofview.tactic list option) option -> (Id.t (* name of thm *) * - (EConstr.types (* type of thm *) * (Name.t list (* names to pre-introduce *) * Impargs.manual_explicitation list))) list -> - int list option -> unit + (EConstr.types (* type of thm *) * (Name.t list (* names to pre-introduce *) * Impargs.manual_explicitation list))) list + -> int list option -> Proof_global.t val standard_proof_terminator : ?hook:declaration_hook -> Proof_global.lemma_possible_guards -> Proof_global.proof_terminator -val fresh_name_for_anonymous_theorem : unit -> Id.t +val fresh_name_for_anonymous_theorem : pstate:Proof_global.t option -> Id.t (* Prepare global named context for proof session: remove proofs of opaque section definitions and remove vm-compiled code *) @@ -69,4 +71,14 @@ val initialize_named_context_for_proof : unit -> Environ.named_context_val (** {6 ... } *) -val save_proof : ?proof:Proof_global.closed_proof -> Vernacexpr.proof_end -> unit +val save_proof_admitted + : ?proof:Proof_global.closed_proof + -> pstate:Proof_global.t + -> unit + +val save_proof_proved + : ?proof:Proof_global.closed_proof + -> ?pstate:Proof_global.t + -> opaque:Proof_global.opacity_flag + -> idopt:Names.lident option + -> Proof_global.t option diff --git a/vernac/obligations.ml b/vernac/obligations.ml index 9aca48f529..07194578c1 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -456,7 +456,7 @@ let obligation_substitution expand prg = let ints = intset_to (pred (Array.length obls)) in obl_substitution expand obls ints -let declare_definition prg = +let declare_definition ~ontop prg = let varsubst = obligation_substitution true prg in let body, typ = subst_prog varsubst prg in let nf = UnivSubst.nf_evars_and_universes_opt_subst (fun x -> None) @@ -475,7 +475,7 @@ let declare_definition prg = let () = progmap_remove prg in let ubinders = UState.universe_binders uctx in let hook_data = Option.map (fun hook -> hook, uctx, obls) prg.prg_hook in - DeclareDef.declare_definition prg.prg_name + DeclareDef.declare_definition ~ontop prg.prg_name prg.prg_kind ce ubinders prg.prg_implicits ?hook_data let rec lam_index n t acc = @@ -554,16 +554,14 @@ let declare_mutual_definition l = (* Declare the recursive definitions *) let univs = UState.univ_entry ~poly first.prg_ctx in let fix_exn = Hook.get get_fix_exn () in - let kns = List.map4 - (DeclareDef.declare_fix ~opaque (local, poly, kind) UnivNames.empty_binders univs) - fixnames fixdecls fixtypes fiximps - in - (* Declare notations *) - List.iter (Metasyntax.add_notation_interpretation (Global.env())) first.prg_notations; - Declare.recursive_message (fixkind != IsCoFixpoint) indexes fixnames; - let gr = List.hd kns in - Lemmas.call_hook ?hook:first.prg_hook ~fix_exn first.prg_ctx obls local gr; - List.iter progmap_remove l; gr + let kns = List.map4 (DeclareDef.declare_fix ~ontop:None ~opaque (local, poly, kind) UnivNames.empty_binders univs) + fixnames fixdecls fixtypes fiximps in + (* Declare notations *) + List.iter (Metasyntax.add_notation_interpretation (Global.env())) first.prg_notations; + Declare.recursive_message (fixkind != IsCoFixpoint) indexes fixnames; + let gr = List.hd kns in + Lemmas.call_hook ?hook:first.prg_hook ~fix_exn first.prg_ctx obls local gr; + List.iter progmap_remove l; gr let decompose_lam_prod c ty = let open Context.Rel.Declaration in @@ -763,7 +761,7 @@ let update_obls prg obls rem = else ( match prg'.prg_deps with | [] -> - let kn = declare_definition prg' in + let kn = declare_definition ~ontop:None prg' in progmap_remove prg'; Defined kn | l -> @@ -948,7 +946,7 @@ let obligation_hook prg obl num auto ctx' _ _ gr = ignore (auto (Some prg.prg_name) None deps) end -let rec solve_obligation prg num tac = +let rec solve_obligation ~ontop prg num tac = let user_num = succ num in let obls, rem = prg.prg_obligations in let obl = obls.(num) in @@ -967,20 +965,21 @@ let rec solve_obligation prg num tac = let auto n tac oblset = auto_solve_obligations n ~oblset tac in let terminator ?hook guard = Proof_global.make_terminator - (obligation_terminator ?hook prg.prg_name num guard auto) in + (obligation_terminator prg.prg_name num guard ?hook auto) in let hook = Lemmas.mk_hook (obligation_hook prg obl num auto) in - let () = Lemmas.start_proof ~sign:prg.prg_sign obl.obl_name kind evd (EConstr.of_constr obl.obl_type) ~terminator ~hook in - let _ = Pfedit.by !default_tactic in - Option.iter (fun tac -> Proof_global.set_endline_tactic tac) tac + let pstate = Lemmas.start_proof ~ontop ~sign:prg.prg_sign obl.obl_name kind evd (EConstr.of_constr obl.obl_type) ~terminator ~hook in + let pstate = fst @@ Pfedit.by !default_tactic pstate in + let pstate = Option.cata (fun tac -> Proof_global.set_endline_tactic tac pstate) pstate tac in + pstate -and obligation (user_num, name, typ) tac = +and obligation ~ontop (user_num, name, typ) tac = let num = pred user_num in let prg = get_prog_err name in let obls, rem = prg.prg_obligations in if num >= 0 && num < Array.length obls then let obl = obls.(num) in match obl.obl_body with - None -> solve_obligation prg num tac + | None -> solve_obligation ~ontop prg num tac | Some r -> error "Obligation already solved" else error (sprintf "Unknown obligation number %i" (succ num)) @@ -1113,7 +1112,7 @@ let add_definition n ?term t ctx ?(univdecl=UState.default_univ_decl) let obls,_ = prg.prg_obligations in if Int.equal (Array.length obls) 0 then ( Flags.if_verbose Feedback.msg_info (info ++ str "."); - let cst = declare_definition prg in + let cst = declare_definition ~ontop:None prg in Defined cst) else ( let len = Array.length obls in @@ -1180,7 +1179,7 @@ let admit_obligations n = let prg = get_prog_err n in admit_prog prg -let next_obligation n tac = +let next_obligation ~ontop n tac = let prg = match n with | None -> get_any_prog_err () | Some _ -> get_prog_err n @@ -1191,7 +1190,7 @@ let next_obligation n tac = | Some i -> i | None -> anomaly (Pp.str "Could not find a solvable obligation.") in - solve_obligation prg i tac + solve_obligation ~ontop prg i tac let check_program_libraries () = Coqlib.check_required_library Coqlib.datatypes_module_name; diff --git a/vernac/obligations.mli b/vernac/obligations.mli index c5720363b4..b1b7b1ec90 100644 --- a/vernac/obligations.mli +++ b/vernac/obligations.mli @@ -85,10 +85,17 @@ val add_mutual_definitions : notations -> fixpoint_kind -> unit -val obligation : int * Names.Id.t option * Constrexpr.constr_expr option -> - Genarg.glob_generic_argument option -> unit - -val next_obligation : Names.Id.t option -> Genarg.glob_generic_argument option -> unit +val obligation + : ontop:Proof_global.t option + -> int * Names.Id.t option * Constrexpr.constr_expr option + -> Genarg.glob_generic_argument option + -> Proof_global.t + +val next_obligation + : ontop:Proof_global.t option + -> Names.Id.t option + -> Genarg.glob_generic_argument option + -> Proof_global.t 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/vernac/ppvernac.ml b/vernac/ppvernac.ml index f705f347a3..506c3f9f49 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -33,7 +33,10 @@ open Pputils let pr_constr = pr_constr_expr let pr_lconstr = pr_lconstr_expr - let pr_spc_lconstr = pr_sep_com spc pr_lconstr_expr + let pr_spc_lconstr = + let env = Global.env () in + let sigma = Evd.from_env env in + pr_sep_com spc @@ pr_lconstr_expr env sigma let pr_uconstraint (l, d, r) = pr_glob_level l ++ spc () ++ Univ.pr_constraint_type d ++ spc () ++ @@ -92,7 +95,10 @@ open Pputils | VernacEndSubproof -> str"" | _ -> str"." - let pr_gen t = Pputils.pr_raw_generic (Global.env ()) t + let pr_gen t = + let env = Global.env () in + let sigma = Evd.from_env env in + Pputils.pr_raw_generic env sigma t let sep = fun _ -> spc() let sep_v2 = fun _ -> str"," ++ spc() @@ -142,7 +148,10 @@ open Pputils let pr_search_about (b,c) = (if b then str "-" else mt()) ++ match c with - | SearchSubPattern p -> pr_constr_pattern_expr p + | SearchSubPattern p -> + let env = Global.env () in + let sigma = Evd.from_env env in + pr_constr_pattern_expr env sigma p | SearchString (s,sc) -> qs s ++ pr_opt (fun sc -> str "%" ++ str sc) sc let pr_search a gopt b pr_p = @@ -225,8 +234,10 @@ open Pputils ++ spc() ++ prlist_with_sep spc pr_qualid c | HintsExtern (n,c,tac) -> let pat = match c with None -> mt () | Some pat -> pr_pat pat in + let env = Global.env () in + let sigma = Evd.from_env env in keyword "Extern" ++ spc() ++ int n ++ spc() ++ pat ++ str" =>" ++ - spc() ++ Pputils.pr_raw_generic (Global.env ()) tac + spc() ++ Pputils.pr_raw_generic env sigma tac in hov 2 (keyword "Hint "++ pph ++ opth) @@ -298,7 +309,9 @@ open Pputils pr_opt (fun sc -> str ": " ++ str sc) scopt let pr_binders_arg = - pr_non_empty_arg pr_binders + let env = Global.env () in + let sigma = Evd.from_env env in + pr_non_empty_arg @@ pr_binders env sigma let pr_and_type_binders_arg bl = pr_binders_arg bl @@ -402,25 +415,35 @@ open Pputils hov 1 (str"(" ++ prlist_with_sep sep_v2 pr_syntax_modifier l ++ str")") let pr_rec_definition ((iddecl,ro,bl,type_,def),ntn) = + let env = Global.env () in + let sigma = Evd.from_env env in let pr_pure_lconstr c = Flags.without_option Flags.beautify pr_lconstr c in - let annot = pr_guard_annot pr_lconstr_expr bl ro in + let annot = pr_guard_annot (pr_lconstr_expr env sigma) bl ro in pr_ident_decl iddecl ++ pr_binders_arg bl ++ annot - ++ pr_type_option (fun c -> spc() ++ pr_lconstr_expr c) type_ - ++ pr_opt (fun def -> str":=" ++ brk(1,2) ++ pr_pure_lconstr def) def - ++ prlist (pr_decl_notation pr_constr) ntn + ++ pr_type_option (fun c -> spc() ++ pr_lconstr_expr env sigma c) type_ + ++ pr_opt (fun def -> str":=" ++ brk(1,2) ++ pr_pure_lconstr env sigma def) def + ++ prlist (pr_decl_notation @@ pr_constr env sigma) ntn let pr_statement head (idpl,(bl,c)) = + let env = Global.env () in + let sigma = Evd.from_env env in hov 2 (head ++ spc() ++ pr_ident_decl idpl ++ spc() ++ - (match bl with [] -> mt() | _ -> pr_binders bl ++ spc()) ++ + (match bl with [] -> mt() | _ -> pr_binders env sigma bl ++ spc()) ++ str":" ++ pr_spc_lconstr c) (**************************************) (* Pretty printer for vernac commands *) (**************************************) - let pr_constrarg c = spc () ++ pr_constr c - let pr_lconstrarg c = spc () ++ pr_lconstr c + let pr_constrarg c = + let env = Global.env () in + let sigma = Evd.from_env env in + spc () ++ pr_constr env sigma c + let pr_lconstrarg c = + let env = Global.env () in + let sigma = Evd.from_env env in + spc () ++ pr_lconstr env sigma c let pr_intarg n = spc () ++ int n let pr_oc = function @@ -429,21 +452,23 @@ open Pputils | Some false -> str" :>>" let pr_record_field ((x, pri), ntn) = + let env = Global.env () in + let sigma = Evd.from_env env in let prx = match x with | (oc,AssumExpr (id,t)) -> hov 1 (pr_lname id ++ pr_oc oc ++ spc() ++ - pr_lconstr_expr t) + pr_lconstr_expr env sigma t) | (oc,DefExpr(id,b,opt)) -> (match opt with | Some t -> hov 1 (pr_lname id ++ pr_oc oc ++ spc() ++ - pr_lconstr_expr t ++ str" :=" ++ pr_lconstr b) + pr_lconstr_expr env sigma t ++ str" :=" ++ pr_lconstr env sigma b) | None -> hov 1 (pr_lname id ++ str" :=" ++ spc() ++ - pr_lconstr b)) in + pr_lconstr env sigma b)) in let prpri = match pri with None -> mt() | Some i -> str "| " ++ int i in - prx ++ prpri ++ prlist (pr_decl_notation pr_constr) ntn + prx ++ prpri ++ prlist (pr_decl_notation @@ pr_constr env sigma) ntn let pr_record_decl b c fs = pr_opt pr_lident c ++ (if c = None then str"{" else str" {") ++ @@ -566,6 +591,8 @@ open Pputils let pr_vernac_expr v = let return = tag_vernac v in + let env = Global.env () in + let sigma = Evd.from_env env in match v with | VernacLoad (f,s) -> return ( @@ -700,7 +727,7 @@ open Pputils | None -> mt() | Some r -> keyword "Eval" ++ spc() ++ - Ppred.pr_red_expr (pr_constr, pr_lconstr, pr_smart_global, pr_constr) keyword r ++ + Ppred.pr_red_expr_env env sigma (pr_constr, pr_lconstr, pr_smart_global, pr_constr) keyword r ++ keyword " in" ++ spc() in let pr_def_body = function @@ -709,7 +736,7 @@ open Pputils | None -> mt() | Some ty -> spc() ++ str":" ++ pr_spc_lconstr ty in - (pr_binders_arg bl,ty,Some (pr_reduce red ++ pr_lconstr body)) + (pr_binders_arg bl,ty,Some (pr_reduce red ++ pr_lconstr env sigma body)) | ProveBody (bl,t) -> let typ u = if (fst id).v = Anonymous then (assert (bl = []); u) else (str" :" ++ u) in (pr_binders_arg bl, typ (pr_spc_lconstr t), None) in @@ -746,7 +773,7 @@ open Pputils let n = List.length (List.flatten (List.map fst (List.map snd l))) in let pr_params (c, (xl, t)) = hov 2 (prlist_with_sep sep pr_ident_decl xl ++ spc() ++ - (if c then str":>" else str":" ++ spc() ++ pr_lconstr_expr t)) in + (if c then str":>" else str":" ++ spc() ++ pr_lconstr_expr env sigma t)) in let assumptions = prlist_with_sep spc (fun p -> hov 1 (str "(" ++ pr_params p ++ str ")")) l in return (hov 2 (pr_assumption_token (n > 1) discharge kind ++ pr_non_empty_arg pr_assumption_inline t ++ spc() ++ assumptions)) @@ -771,9 +798,9 @@ open Pputils str key ++ spc() ++ (if coe then str"> " else str"") ++ pr_ident_decl iddecl ++ pr_and_type_binders_arg indpar ++ - pr_opt (fun s -> str":" ++ spc() ++ pr_lconstr_expr s) s ++ + pr_opt (fun s -> str":" ++ spc() ++ pr_lconstr_expr env sigma s) s ++ str" :=") ++ pr_constructor_list k lc ++ - prlist (pr_decl_notation pr_constr) ntn + prlist (pr_decl_notation @@ pr_constr env sigma) ntn in let key = let (_,_,_,k,_),_ = List.hd l in @@ -814,10 +841,10 @@ open Pputils | NoDischarge -> str "" in let pr_onecorec ((iddecl,bl,c,def),ntn) = - pr_ident_decl iddecl ++ spc() ++ pr_binders bl ++ spc() ++ str":" ++ - spc() ++ pr_lconstr_expr c ++ - pr_opt (fun def -> str":=" ++ brk(1,2) ++ pr_lconstr def) def ++ - prlist (pr_decl_notation pr_constr) ntn + pr_ident_decl iddecl ++ spc() ++ pr_binders env sigma bl ++ spc() ++ str":" ++ + spc() ++ pr_lconstr_expr env sigma c ++ + pr_opt (fun def -> str":=" ++ brk(1,2) ++ pr_lconstr env sigma def) def ++ + prlist (pr_decl_notation @@ pr_constr env sigma) ntn in return ( hov 0 (local ++ keyword "CoFixpoint" ++ spc() ++ @@ -897,11 +924,11 @@ open Pputils pr_and_type_binders_arg sup ++ str":" ++ spc () ++ (match bk with Implicit -> str "! " | Explicit -> mt ()) ++ - pr_constr cl ++ pr_hint_info pr_constr_pattern_expr info ++ + pr_constr env sigma cl ++ pr_hint_info (pr_constr_pattern_expr env sigma) info ++ (match props with | Some (true, { v = CRecord l}) -> spc () ++ str":=" ++ spc () ++ str"{" ++ pr_record_body l ++ str "}" | Some (true,_) -> assert false - | Some (false,p) -> spc () ++ str":=" ++ spc () ++ pr_constr p + | Some (false,p) -> spc () ++ str":=" ++ spc () ++ pr_constr env sigma p | None -> mt())) ) @@ -912,7 +939,7 @@ open Pputils pr_and_type_binders_arg sup ++ str":" ++ spc () ++ (match bk with Implicit -> str "! " | Explicit -> mt ()) ++ - pr_constr cl ++ pr_hint_info pr_constr_pattern_expr info) + pr_constr env sigma cl ++ pr_hint_info (pr_constr_pattern_expr env sigma) info) ) | VernacContext l -> @@ -922,8 +949,8 @@ open Pputils ) | VernacExistingInstance insts -> - let pr_inst (id, info) = - pr_qualid id ++ pr_hint_info pr_constr_pattern_expr info + let pr_inst (id, info) = + pr_qualid id ++ pr_hint_info (pr_constr_pattern_expr env sigma) info in return ( hov 1 (keyword "Existing" ++ spc () ++ @@ -938,25 +965,25 @@ open Pputils (* Modules and Module Types *) | VernacDefineModule (export,m,bl,tys,bd) -> - let b = pr_module_binders bl pr_lconstr in + let b = pr_module_binders bl (pr_lconstr env sigma) in return ( hov 2 (keyword "Module" ++ spc() ++ pr_require_token export ++ pr_lident m ++ b ++ - pr_of_module_type pr_lconstr tys ++ + pr_of_module_type (pr_lconstr env sigma) tys ++ (if List.is_empty bd then mt () else str ":= ") ++ prlist_with_sep (fun () -> str " <+") - (pr_module_ast_inl true pr_lconstr) bd) + (pr_module_ast_inl true (pr_lconstr env sigma)) bd) ) | VernacDeclareModule (export,id,bl,m1) -> - let b = pr_module_binders bl pr_lconstr in + let b = pr_module_binders bl (pr_lconstr env sigma) in return ( hov 2 (keyword "Declare Module" ++ spc() ++ pr_require_token export ++ pr_lident id ++ b ++ str " :" ++ - pr_module_ast_inl true pr_lconstr m1) + pr_module_ast_inl true (pr_lconstr env sigma) m1) ) | VernacDeclareModuleType (id,bl,tyl,m) -> - let b = pr_module_binders bl pr_lconstr in - let pr_mt = pr_module_ast_inl true pr_lconstr in + let b = pr_module_binders bl (pr_lconstr env sigma) in + let pr_mt = pr_module_ast_inl true (pr_lconstr env sigma) in return ( hov 2 (keyword "Module Type " ++ pr_lident id ++ b ++ prlist_strict (fun m -> str " <:" ++ pr_mt m) tyl ++ @@ -964,7 +991,7 @@ open Pputils prlist_with_sep (fun () -> str " <+ ") pr_mt m) ) | VernacInclude (mexprs) -> - let pr_m = pr_module_ast_inl false pr_lconstr in + let pr_m = pr_module_ast_inl false (pr_lconstr env sigma) in return ( hov 2 (keyword "Include" ++ spc() ++ prlist_with_sep (fun () -> str " <+ ") pr_m mexprs) @@ -1013,7 +1040,7 @@ open Pputils pr_opt_hintbases dbnames) ) | VernacHints (dbnames,h) -> - return (pr_hints dbnames h pr_constr pr_constr_pattern_expr) + return (pr_hints dbnames h (pr_constr env sigma) (pr_constr_pattern_expr env sigma)) | VernacSyntacticDefinition (id,(ids,c),compat) -> return ( hov 2 @@ -1071,7 +1098,7 @@ open Pputils let n = List.length (List.flatten (List.map fst bl)) in return ( hov 2 (tag_keyword (str"Implicit Type" ++ str (if n > 1 then "s " else " ")) - ++ pr_ne_params_list pr_lconstr_expr (List.map (fun sb -> false,sb) bl)) + ++ pr_ne_params_list (pr_lconstr_expr env sigma) (List.map (fun sb -> false,sb) bl)) ) | VernacGeneralizable g -> return ( @@ -1143,9 +1170,9 @@ open Pputils let pr_mayeval r c = match r with | Some r0 -> hov 2 (keyword "Eval" ++ spc() ++ - Ppred.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) + Ppred.pr_red_expr_env env sigma (pr_constr,pr_lconstr,pr_smart_global, pr_constr) keyword r0 ++ + spc() ++ keyword "in" ++ spc () ++ pr_lconstr env sigma c) + | None -> hov 2 (keyword "Check" ++ spc() ++ pr_lconstr env sigma c) in let pr_i = match io with None -> mt () | Some i -> Goal_select.pr_goal_selector i ++ str ": " in @@ -1155,12 +1182,12 @@ open Pputils | VernacDeclareReduction (s,r) -> return ( keyword "Declare Reduction" ++ spc () ++ str s ++ str " := " ++ - Ppred.pr_red_expr (pr_constr,pr_lconstr,pr_smart_global, pr_constr) keyword r + Ppred.pr_red_expr_env env sigma (pr_constr,pr_lconstr,pr_smart_global, pr_constr) keyword r ) | VernacPrint p -> return (pr_printable p) | VernacSearch (sea,g,sea_r) -> - return (pr_search sea g sea_r pr_constr_pattern_expr) + return (pr_search sea g sea_r @@ pr_constr_pattern_expr env sigma) | VernacLocate loc -> let pr_locate =function | LocateAny qid -> pr_smart_global qid @@ -1192,7 +1219,7 @@ open Pputils return ( hov 2 (keyword "Comments" ++ spc() - ++ prlist_with_sep sep (pr_comment pr_constr) l) + ++ prlist_with_sep sep (pr_comment (pr_constr env sigma)) l) ) (* For extension *) @@ -1204,12 +1231,12 @@ open Pputils return (keyword "Proof " ++ spc () ++ keyword "using" ++ spc() ++ pr_using e) | VernacProof (Some te, None) -> - return (keyword "Proof with" ++ spc() ++ Pputils.pr_raw_generic (Global.env ()) te) + return (keyword "Proof with" ++ spc() ++ Pputils.pr_raw_generic env sigma te) | VernacProof (Some te, Some e) -> return ( keyword "Proof" ++ spc () ++ keyword "using" ++ spc() ++ pr_using e ++ spc() ++ - keyword "with" ++ spc() ++ Pputils.pr_raw_generic (Global.env ()) te + keyword "with" ++ spc() ++ Pputils.pr_raw_generic env sigma te ) | VernacProofMode s -> return (keyword "Proof Mode" ++ str s) diff --git a/vernac/search.ml b/vernac/search.ml index 6610789626..e41378908f 100644 --- a/vernac/search.ml +++ b/vernac/search.ml @@ -59,11 +59,16 @@ let iter_constructors indsp u fn env nconstr = let iter_named_context_name_type f = List.iter (fun decl -> f (NamedDecl.get_id decl) (NamedDecl.get_type decl)) +let get_current_or_goal_context ?pstate glnum = + match pstate with + | None -> let env = Global.env () in Evd.(from_env env, env) + | Some p -> Pfedit.get_goal_context p glnum + (* General search over hypothesis of a goal *) -let iter_hypothesis glnum (fn : GlobRef.t -> env -> constr -> unit) = +let iter_hypothesis ?pstate glnum (fn : GlobRef.t -> env -> constr -> unit) = let env = Global.env () in let iter_hyp idh typ = fn (VarRef idh) env typ in - let evmap,e = Pfedit.get_goal_context glnum in + let evmap,e = get_current_or_goal_context ?pstate glnum in let pfctxt = named_context e in iter_named_context_name_type iter_hyp pfctxt @@ -99,10 +104,10 @@ let iter_declarations (fn : GlobRef.t -> env -> constr -> unit) = try Declaremods.iter_all_segments iter_obj with Not_found -> () -let generic_search glnumopt fn = +let generic_search ?pstate glnumopt fn = (match glnumopt with | None -> () - | Some glnum -> iter_hypothesis glnum fn); + | Some glnum -> iter_hypothesis ?pstate glnum fn); iter_declarations fn (** This module defines a preference on constrs in the form of a @@ -221,7 +226,7 @@ let search_about_filter query gr env typ = match query with (** SearchPattern *) -let search_pattern gopt pat mods pr_search = +let search_pattern ?pstate gopt pat mods pr_search = let blacklist_filter = blacklist_filter_aux () in let filter ref env typ = module_filter mods ref env typ && @@ -231,7 +236,7 @@ let search_pattern gopt pat mods pr_search = let iter ref env typ = if filter ref env typ then pr_search ref env typ in - generic_search gopt iter + generic_search ?pstate gopt iter (** SearchRewrite *) @@ -243,7 +248,7 @@ let rewrite_pat1 pat = let rewrite_pat2 pat = PApp (PRef (eq ()), [| PMeta None; PMeta None; pat |]) -let search_rewrite gopt pat mods pr_search = +let search_rewrite ?pstate gopt pat mods pr_search = let pat1 = rewrite_pat1 pat in let pat2 = rewrite_pat2 pat in let blacklist_filter = blacklist_filter_aux () in @@ -256,11 +261,11 @@ let search_rewrite gopt pat mods pr_search = let iter ref env typ = if filter ref env typ then pr_search ref env typ in - generic_search gopt iter + generic_search ?pstate gopt iter (** Search *) -let search_by_head gopt pat mods pr_search = +let search_by_head ?pstate gopt pat mods pr_search = let blacklist_filter = blacklist_filter_aux () in let filter ref env typ = module_filter mods ref env typ && @@ -270,11 +275,11 @@ let search_by_head gopt pat mods pr_search = let iter ref env typ = if filter ref env typ then pr_search ref env typ in - generic_search gopt iter + generic_search ?pstate gopt iter (** SearchAbout *) -let search_about gopt items mods pr_search = +let search_about ?pstate gopt items mods pr_search = let blacklist_filter = blacklist_filter_aux () in let filter ref env typ = let eqb b1 b2 = if b1 then b2 else not b2 in @@ -286,7 +291,7 @@ let search_about gopt items mods pr_search = let iter ref env typ = if filter ref env typ then pr_search ref env typ in - generic_search gopt iter + generic_search ?pstate gopt iter type search_constraint = | Name_Pattern of Str.regexp @@ -301,7 +306,7 @@ type 'a coq_object = { coq_object_object : 'a; } -let interface_search = +let interface_search ?pstate = let rec extract_flags name tpe subtpe mods blacklist = function | [] -> (name, tpe, subtpe, mods, blacklist) | (Name_Pattern regexp, b) :: l -> @@ -371,7 +376,7 @@ let interface_search = let iter ref env typ = if filter_function ref env typ then print_function ref env typ in - let () = generic_search glnum iter in + let () = generic_search ?pstate glnum iter in !ans let blacklist_filter ref env typ = diff --git a/vernac/search.mli b/vernac/search.mli index ecbb02bc68..0f94ddc5b6 100644 --- a/vernac/search.mli +++ b/vernac/search.mli @@ -39,13 +39,13 @@ val search_about_filter : glob_search_about_item -> filter_function goal and the global environment for things matching [pattern] and satisfying module exclude/include clauses of [modinout]. *) -val search_by_head : int option -> constr_pattern -> DirPath.t list * bool +val search_by_head : ?pstate:Proof_global.t -> int option -> constr_pattern -> DirPath.t list * bool -> display_function -> unit -val search_rewrite : int option -> constr_pattern -> DirPath.t list * bool +val search_rewrite : ?pstate:Proof_global.t -> int option -> constr_pattern -> DirPath.t list * bool -> display_function -> unit -val search_pattern : int option -> constr_pattern -> DirPath.t list * bool +val search_pattern : ?pstate:Proof_global.t -> int option -> constr_pattern -> DirPath.t list * bool -> display_function -> unit -val search_about : int option -> (bool * glob_search_about_item) list +val search_about : ?pstate:Proof_global.t -> int option -> (bool * glob_search_about_item) list -> DirPath.t list * bool -> display_function -> unit type search_constraint = @@ -66,12 +66,12 @@ type 'a coq_object = { coq_object_object : 'a; } -val interface_search : ?glnum:int -> (search_constraint * bool) list -> +val interface_search : ?pstate:Proof_global.t -> ?glnum:int -> (search_constraint * bool) list -> constr coq_object list (** {6 Generic search function} *) -val generic_search : int option -> display_function -> unit +val generic_search : ?pstate:Proof_global.t -> int option -> display_function -> unit (** This function iterates over all hypothesis of the goal numbered [glnum] (if present) and all known declarations. *) diff --git a/vernac/topfmt.ml b/vernac/topfmt.ml index ed93267665..60b0bdc7e7 100644 --- a/vernac/topfmt.ml +++ b/vernac/topfmt.ml @@ -196,8 +196,8 @@ let init_tag_map styles = let default_styles () = init_tag_map (default_tag_map ()) -let parse_color_config file = - let styles = Terminal.parse file in +let parse_color_config str = + let styles = Terminal.parse str in init_tag_map styles let dump_tags () = CString.Map.bindings !tag_map diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 4250ddb02c..d2ba882521 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -44,6 +44,28 @@ let vernac_pperr_endline pp = (* Misc *) +let there_are_pending_proofs ~pstate = + not Option.(is_empty pstate) + +let check_no_pending_proof ~pstate = + if there_are_pending_proofs ~pstate then + user_err Pp.(str "Command not supported (Open proofs remain)") + +let vernac_require_open_proof ~pstate f = + match pstate with + | Some pstate -> f ~pstate + | None -> user_err Pp.(str "Command not supported (No proof-editing in progress)") + +let get_current_or_global_context ~pstate = + match pstate with + | None -> let env = Global.env () in Evd.(from_env env, env) + | Some p -> Pfedit.get_current_context p + +let get_goal_or_global_context ~pstate glnum = + match pstate with + | None -> let env = Global.env () in Evd.(from_env env, env) + | Some p -> Pfedit.get_goal_context p glnum + let cl_of_qualid = function | FunClass -> Classops.CL_FUN | SortClass -> Classops.CL_SORT @@ -72,30 +94,37 @@ end (*******************) (* "Show" commands *) -let show_proof () = +let show_proof ~pstate = (* spiwack: this would probably be cooler with a bit of polishing. *) - let p = Proof_global.give_me_the_proof () in - let sigma, env = Pfedit.get_current_context () in - let pprf = Proof.partial_proof p in - Pp.prlist_with_sep Pp.fnl (Printer.pr_econstr_env env sigma) pprf + try + let pstate = Option.get pstate in + let p = Proof_global.give_me_the_proof pstate in + let sigma, env = Pfedit.get_current_context pstate in + let pprf = Proof.partial_proof p in + Pp.prlist_with_sep Pp.fnl (Printer.pr_econstr_env env sigma) pprf + (* We print nothing if there are no goals left *) + with + | Pfedit.NoSuchGoal + | Option.IsNone -> + user_err (str "No goals to show.") -let show_top_evars () = +let show_top_evars ~pstate = (* spiwack: new as of Feb. 2010: shows goal evars in addition to non-goal evars. *) - let pfts = Proof_global.give_me_the_proof () in + let pfts = Proof_global.give_me_the_proof pstate in let Proof.{goals;shelf;given_up;sigma} = Proof.data pfts in pr_evars_int sigma ~shelf ~given_up 1 (Evd.undefined_map sigma) -let show_universes () = - let pfts = Proof_global.give_me_the_proof () in +let show_universes ~pstate = + let pfts = Proof_global.give_me_the_proof pstate in let Proof.{goals;sigma} = Proof.data pfts in let ctx = Evd.universe_context_set (Evd.minimize_universes sigma) in Termops.pr_evar_universe_context (Evd.evar_universe_context sigma) ++ fnl () ++ str "Normalized constraints: " ++ Univ.pr_universe_context_set (Termops.pr_evd_level sigma) ctx (* Simulate the Intro(s) tactic *) -let show_intro all = +let show_intro ~pstate all = let open EConstr in - let pf = Proof_global.give_me_the_proof() in + let pf = Proof_global.give_me_the_proof pstate in let Proof.{goals;sigma} = Proof.data pf in if not (List.is_empty goals) then begin let gl = {Evd.it=List.hd goals ; sigma = sigma; } in @@ -224,7 +253,7 @@ let print_modtype qid = with Not_found -> user_err (str"Unknown Module Type or Module " ++ pr_qualid qid) -let print_namespace ns = +let print_namespace ~pstate ns = let ns = List.rev (Names.DirPath.repr ns) in (* [match_dirpath], [match_modulpath] are helpers for [matches] which checks whether a constant is in the namespace [ns]. *) @@ -272,10 +301,10 @@ let print_namespace ns = let qn = (qualified_minus (List.length ns) mp)@[Names.Label.to_id lbl] in print_list Id.print qn in - let print_constant k body = + let print_constant ~pstate k body = (* FIXME: universes *) let t = body.Declarations.const_type in - let sigma, env = Pfedit.get_current_context () in + let sigma, env = get_current_or_global_context ~pstate in print_kn k ++ str":" ++ spc() ++ Printer.pr_type_env env sigma t in let matches mp = match match_modulepath ns mp with @@ -285,7 +314,7 @@ let print_namespace ns = Environ.fold_constants (fun c body acc -> let kn = Constant.user c in if matches (KerName.modpath kn) - then acc++fnl()++hov 2 (print_constant kn body) + then acc++fnl()++hov 2 (print_constant ~pstate kn body) else acc) (Global.env ()) (str"") in @@ -515,7 +544,7 @@ let () = (***********) (* Gallina *) -let start_proof_and_print ~program_mode ?hook k l = +let start_proof_and_print ~program_mode ~pstate ?hook k l = let inference_hook = if program_mode then let hook env sigma ev = @@ -537,7 +566,7 @@ let start_proof_and_print ~program_mode ?hook k l = in Some hook else None in - start_proof_com ~program_mode ?inference_hook ?hook k l + start_proof_com ~program_mode ~ontop:pstate ?inference_hook ?hook k l let vernac_definition_hook p = function | Coercion -> @@ -548,7 +577,7 @@ let vernac_definition_hook p = function Some (Class.add_subclass_hook p) | _ -> None -let vernac_definition ~atts discharge kind ({loc;v=id}, pl) def = +let vernac_definition ~atts ~pstate discharge kind ({loc;v=id}, pl) def = let open DefAttributes in let local = enforce_locality_exp atts.locality discharge in let hook = vernac_definition_hook atts.polymorphic kind in @@ -563,41 +592,47 @@ let vernac_definition ~atts discharge kind ({loc;v=id}, pl) def = let program_mode = atts.program in let name = match id with - | Anonymous -> fresh_name_for_anonymous_theorem () + | Anonymous -> fresh_name_for_anonymous_theorem ~pstate | Name n -> n in (match def with | ProveBody (bl,t) -> (* local binders, typ *) - start_proof_and_print ~program_mode (local, atts.polymorphic, DefinitionBody kind) - ?hook [(CAst.make ?loc name, pl), (bl, t)] + Some (start_proof_and_print ~program_mode ~pstate (local, atts.polymorphic, DefinitionBody kind) + ?hook [(CAst.make ?loc name, pl), (bl, t)]) | DefineBody (bl,red_option,c,typ_opt) -> let red_option = match red_option with - | None -> None - | Some r -> - let sigma, env = Pfedit.get_current_context () in - Some (snd (Hook.get f_interp_redexp env sigma r)) in - ComDefinition.do_definition ~program_mode name - (local, atts.polymorphic, kind) pl bl red_option c typ_opt ?hook) - -let vernac_start_proof ~atts kind l = + | None -> None + | Some r -> + let sigma, env = get_current_or_global_context ~pstate in + Some (snd (Hook.get f_interp_redexp env sigma r)) in + ComDefinition.do_definition ~ontop:pstate ~program_mode name + (local, atts.polymorphic, kind) pl bl red_option c typ_opt ?hook; + pstate + ) + +let vernac_start_proof ~atts ~pstate kind l = let open DefAttributes in let local = enforce_locality_exp atts.locality NoDischarge in if Dumpglob.dump () then List.iter (fun ((id, _), _) -> Dumpglob.dump_definition id false "prf") l; - start_proof_and_print ~program_mode:atts.program (local, atts.polymorphic, Proof kind) l + Some (start_proof_and_print ~pstate ~program_mode:atts.program (local, atts.polymorphic, Proof kind) l) -let vernac_end_proof ?proof = function - | Admitted -> save_proof ?proof Admitted - | Proved (_,_) as e -> save_proof ?proof e +let vernac_end_proof ?pstate ?proof = function + | Admitted -> + vernac_require_open_proof ~pstate (save_proof_admitted ?proof); + pstate + | Proved (opaque,idopt) -> + save_proof_proved ?pstate ?proof ~opaque ~idopt -let vernac_exact_proof c = +let vernac_exact_proof ~pstate c = (* spiwack: for simplicity I do not enforce that "Proof proof_term" is called only at the begining of a proof. *) - let status = Pfedit.by (Tactics.exact_proof c) in - save_proof (Vernacexpr.(Proved(Proof_global.Opaque,None))); - if not status then Feedback.feedback Feedback.AddedAxiom + let pstate, status = Pfedit.by (Tactics.exact_proof c) pstate in + let pstate = save_proof_proved ?proof:None ~pstate ~opaque:Proof_global.Opaque ~idopt:None in + if not status then Feedback.feedback Feedback.AddedAxiom; + pstate -let vernac_assumption ~atts discharge kind l nl = +let vernac_assumption ~atts ~pstate discharge kind l nl = let open DefAttributes in let local = enforce_locality_exp atts.locality discharge in let global = local == Global in @@ -607,7 +642,7 @@ let vernac_assumption ~atts discharge kind l nl = List.iter (fun (lid, _) -> if global then Dumpglob.dump_definition lid false "ax" else Dumpglob.dump_definition lid true "var") idl) l; - let status = ComAssumption.do_assumptions ~program_mode:atts.program kind nl l in + let status = ComAssumption.do_assumptions ~pstate ~program_mode:atts.program kind nl l in if not status then Feedback.feedback Feedback.AddedAxiom let is_polymorphic_inductive_cumulativity = @@ -772,28 +807,28 @@ let vernac_inductive ~atts cum lo finite indl = in vernac_record cum (Class true) atts.polymorphic finite [id, bl, c, None, [f]] *) -let vernac_fixpoint ~atts discharge l = +let vernac_fixpoint ~atts ~pstate discharge l : Proof_global.t option = let open DefAttributes in let local = enforce_locality_exp atts.locality discharge in if Dumpglob.dump () then List.iter (fun (((lid,_), _, _, _, _), _) -> Dumpglob.dump_definition lid false "def") l; (* XXX: Switch to the attribute system and match on ~atts *) let do_fixpoint = if atts.program then - ComProgramFixpoint.do_fixpoint + fun local sign l -> ComProgramFixpoint.do_fixpoint local sign l; None else - ComFixpoint.do_fixpoint + ComFixpoint.do_fixpoint ~ontop:pstate in do_fixpoint local atts.polymorphic l -let vernac_cofixpoint ~atts discharge l = +let vernac_cofixpoint ~atts ~pstate discharge l = let open DefAttributes in let local = enforce_locality_exp atts.locality discharge in if Dumpglob.dump () then List.iter (fun (((lid,_), _, _, _), _) -> Dumpglob.dump_definition lid false "def") l; let do_cofixpoint = if atts.program then - ComProgramFixpoint.do_cofixpoint + fun local sign l -> ComProgramFixpoint.do_cofixpoint local sign l; None else - ComFixpoint.do_cofixpoint + ComFixpoint.do_cofixpoint ~ontop:pstate in do_cofixpoint local atts.polymorphic l @@ -851,14 +886,14 @@ let vernac_declare_module export {loc;v=id} binders_ast mty_ast = Flags.if_verbose Feedback.msg_info (str "Module " ++ Id.print id ++ str " is declared"); Option.iter (fun export -> vernac_import export [qualid_of_ident id]) export -let vernac_define_module export {loc;v=id} (binders_ast : module_binder list) mty_ast_o mexpr_ast_l = +let vernac_define_module ~pstate export {loc;v=id} (binders_ast : module_binder list) mty_ast_o mexpr_ast_l = (* We check the state of the system (in section, in module type) and what module information is supplied *) if Lib.sections_are_opened () then user_err Pp.(str "Modules and Module Types are not allowed inside sections."); match mexpr_ast_l with | [] -> - Proof_global.check_no_pending_proof (); + check_no_pending_proof ~pstate; let binders_ast,argsexport = List.fold_right (fun (export,idl,ty) (args,argsexport) -> @@ -898,13 +933,13 @@ let vernac_end_module export {loc;v=id} = Flags.if_verbose Feedback.msg_info (str "Module " ++ Id.print id ++ str " is defined"); Option.iter (fun export -> vernac_import export [qualid_of_ident ?loc id]) export -let vernac_declare_module_type {loc;v=id} binders_ast mty_sign mty_ast_l = +let vernac_declare_module_type ~pstate {loc;v=id} binders_ast mty_sign mty_ast_l = if Lib.sections_are_opened () then user_err Pp.(str "Modules and Module Types are not allowed inside sections."); match mty_ast_l with | [] -> - Proof_global.check_no_pending_proof (); + check_no_pending_proof ~pstate; let binders_ast,argsexport = List.fold_right (fun (export,idl,ty) (args,argsexport) -> @@ -951,8 +986,8 @@ let vernac_include l = (* Sections *) -let vernac_begin_section ({v=id} as lid) = - Proof_global.check_no_pending_proof (); +let vernac_begin_section ~pstate ({v=id} as lid) = + check_no_pending_proof ~pstate; Dumpglob.dump_definition lid true "sec"; Lib.open_section id @@ -965,8 +1000,8 @@ let vernac_name_sec_hyp {v=id} set = Proof_using.name_set id set (* Dispatcher of the "End" command *) -let vernac_end_segment ({v=id} as lid) = - Proof_global.check_no_pending_proof (); +let vernac_end_segment ~pstate ({v=id} as lid) = + check_no_pending_proof ~pstate; match Lib.find_opening_node id with | Lib.OpenedModule (false,export,_,_) -> vernac_end_module export lid | Lib.OpenedModule (true,_,_,_) -> vernac_end_modtype lid @@ -1031,7 +1066,7 @@ let vernac_instance ~atts sup inst props pri = let global = not (make_section_locality atts.locality) in Dumpglob.dump_constraint (fst (pi1 inst)) false "inst"; let program_mode = atts.program in - ignore(Classes.new_instance ~program_mode ~global atts.polymorphic sup inst props pri) + Classes.new_instance ~program_mode ~global atts.polymorphic sup inst props pri let vernac_declare_instance ~atts sup inst pri = let open DefAttributes in @@ -1039,8 +1074,8 @@ let vernac_declare_instance ~atts sup inst pri = Dumpglob.dump_definition (fst (pi1 inst)) false "inst"; Classes.declare_new_instance ~program_mode:atts.program ~global atts.polymorphic sup inst pri -let vernac_context ~poly l = - if not (Classes.context poly l) then Feedback.feedback Feedback.AddedAxiom +let vernac_context ~pstate ~poly l = + if not (Classes.context ~pstate poly l) then Feedback.feedback Feedback.AddedAxiom let vernac_existing_instance ~section_local insts = let glob = not section_local in @@ -1061,21 +1096,19 @@ let focus_command_cond = Proof.no_cond command_focus there are no more goals to solve. It cannot be a tactic since all tactics fail if there are no further goals to prove. *) -let vernac_solve_existential = Pfedit.instantiate_nth_evar_com +let vernac_solve_existential ~pstate i e = Pfedit.instantiate_nth_evar_com i e pstate -let vernac_set_end_tac tac = +let vernac_set_end_tac ~pstate tac = let env = Genintern.empty_glob_sign (Global.env ()) in let _, tac = Genintern.generic_intern env tac in - if not (Proof_global.there_are_pending_proofs ()) then - user_err Pp.(str "Unknown command of the non proof-editing mode."); - Proof_global.set_endline_tactic tac - (* TO DO verifier s'il faut pas mettre exist s | TacId s ici*) + (* TO DO verifier s'il faut pas mettre exist s | TacId s ici*) + Proof_global.set_endline_tactic tac pstate -let vernac_set_used_variables e = +let vernac_set_used_variables ~(pstate : Proof_global.t) e : Proof_global.t = let env = Global.env () in let initial_goals pf = Proofview.initial_goals Proof.(data pf).Proof.entry in let tys = - List.map snd (initial_goals (Proof_global.give_me_the_proof ())) in + List.map snd (initial_goals (Proof_global.give_me_the_proof pstate)) in let tys = List.map EConstr.Unsafe.to_constr tys in let l = Proof_using.process_expr env e tys in let vars = Environ.named_context env in @@ -1084,10 +1117,10 @@ let vernac_set_used_variables e = user_err ~hdr:"vernac_set_used_variables" (str "Unknown variable: " ++ Id.print id)) l; - ignore (Proof_global.set_used_variables l); - Proof_global.with_current_proof begin fun _ p -> + let _, pstate = Proof_global.set_used_variables pstate l in + fst @@ Proof_global.with_current_proof begin fun _ p -> (p, ()) - end + end pstate (*****************************) (* Auxiliary file management *) @@ -1132,12 +1165,10 @@ let vernac_chdir = function (* State management *) let vernac_write_state file = - Proof_global.discard_all (); let file = CUnix.make_suffix file ".coq" in States.extern_state file let vernac_restore_state file = - Proof_global.discard_all (); let file = Loadpath.locate_file (CUnix.make_suffix file ".coq") in States.intern_state file @@ -1730,9 +1761,14 @@ let vernac_print_option key = try print_option_value key with Not_found -> error_undeclared_key key -let get_current_context_of_args = function - | Some n -> Pfedit.get_goal_context n - | None -> Pfedit.get_current_context () +let get_current_context_of_args ~pstate = + match pstate with + | None -> fun _ -> + let env = Global.env () in Evd.(from_env env, env) + | Some pstate -> + function + | Some n -> Pfedit.get_goal_context pstate n + | None -> Pfedit.get_current_context pstate let query_command_selector ?loc = function | None -> None @@ -1740,9 +1776,9 @@ let query_command_selector ?loc = function | _ -> user_err ?loc ~hdr:"query_command_selector" (str "Query commands only support the single numbered goal selector.") -let vernac_check_may_eval ~atts redexp glopt rc = +let vernac_check_may_eval ~pstate ~atts redexp glopt rc = let glopt = query_command_selector glopt in - let (sigma, env) = get_current_context_of_args glopt in + let sigma, env = get_current_context_of_args ~pstate glopt in let sigma, c = interp_open_constr env sigma rc in let sigma = Evarconv.solve_unif_constraints_with_heuristics env sigma in Evarconv.check_problems_are_solved env sigma; @@ -1796,27 +1832,33 @@ let vernac_global_check c = pr_universe_ctx_set sigma uctx -let get_nth_goal n = - let pf = Proof_global.give_me_the_proof() in +let get_nth_goal ~pstate n = + let pf = Proof_global.give_me_the_proof pstate in let Proof.{goals;sigma} = Proof.data pf in let gl = {Evd.it=List.nth goals (n-1) ; sigma = sigma; } in gl exception NoHyp + (* Printing "About" information of a hypothesis of the current goal. We only print the type and a small statement to this comes from the goal. Precondition: there must be at least one current goal. *) -let print_about_hyp_globs ?loc ref_or_by_not udecl glopt = +let print_about_hyp_globs ~pstate ?loc ref_or_by_not udecl glopt = let open Context.Named.Declaration in try + (* Fallback early to globals *) + let pstate = match pstate with + | None -> raise Not_found + | Some pstate -> pstate + in (* FIXME error on non None udecl if we find the hyp. *) let glnumopt = query_command_selector ?loc glopt in let gl,id = match glnumopt, ref_or_by_not.v with | None,AN qid when qualid_is_ident qid -> (* goal number not given, catch any failure *) - (try get_nth_goal 1, qualid_basename qid with _ -> raise NoHyp) + (try get_nth_goal ~pstate 1, qualid_basename qid with _ -> raise NoHyp) | Some n,AN qid when qualid_is_ident qid -> (* goal number given, catch if wong *) - (try get_nth_goal n, qualid_basename qid + (try get_nth_goal ~pstate n, qualid_basename qid with Failure _ -> user_err ?loc ~hdr:"print_about_hyp_globs" (str "No such goal: " ++ int n ++ str ".")) @@ -1826,15 +1868,16 @@ let print_about_hyp_globs ?loc ref_or_by_not udecl glopt = let natureofid = match decl with | LocalAssum _ -> "Hypothesis" | LocalDef (_,bdy,_) ->"Constant (let in)" in - let sigma, env = Pfedit.get_current_context () in + let sigma, env = Pfedit.get_current_context pstate in v 0 (Id.print id ++ str":" ++ pr_econstr_env env sigma (NamedDecl.get_type decl) ++ fnl() ++ fnl() ++ str natureofid ++ str " of the goal context.") with (* fallback to globals *) | NoHyp | Not_found -> - let sigma, env = Pfedit.get_current_context () in + let sigma, env = get_current_or_global_context ~pstate in print_about env sigma ref_or_by_not udecl -let vernac_print ~atts env sigma = +let vernac_print ~(pstate : Proof_global.t option) ~atts = + let sigma, env = get_current_or_global_context ~pstate in function | PrintTables -> print_tables () | PrintFullContext-> print_full_context_typ env sigma @@ -1845,7 +1888,7 @@ let vernac_print ~atts env sigma = | PrintModules -> print_modules () | PrintModule qid -> print_module qid | PrintModuleType qid -> print_modtype qid - | PrintNamespace ns -> print_namespace ns + | PrintNamespace ns -> print_namespace ~pstate ns | PrintMLLoadPath -> Mltop.print_ml_path () | PrintMLModules -> Mltop.print_ml_modules () | PrintDebugGC -> Mltop.print_gc () @@ -1862,7 +1905,13 @@ let vernac_print ~atts env sigma = | PrintCanonicalConversions -> Prettyp.print_canonical_projections env sigma | PrintUniverses (sort, subgraph, dst) -> print_universes ~sort ~subgraph dst | PrintHint r -> Hints.pr_hint_ref env sigma (smart_global r) - | PrintHintGoal -> Hints.pr_applicable_hint () + | PrintHintGoal -> + begin match pstate with + | Some pstate -> + Hints.pr_applicable_hint pstate + | None -> + str "No proof in progress" + end | PrintHintDbName s -> Hints.pr_hint_db_by_name env sigma s | PrintHintDb -> Hints.pr_searchtable env sigma | PrintScopes -> @@ -1872,7 +1921,7 @@ let vernac_print ~atts env sigma = | PrintVisibility s -> Notation.pr_visibility (Constrextern.without_symbols (pr_lglob_constr_env env)) s | PrintAbout (ref_or_by_not,udecl,glnumopt) -> - print_about_hyp_globs ref_or_by_not udecl glnumopt + print_about_hyp_globs ~pstate ref_or_by_not udecl glnumopt | PrintImplicit qid -> dump_global qid; print_impargs qid @@ -1937,16 +1986,16 @@ let () = optread = (fun () -> !search_output_name_only); optwrite = (:=) search_output_name_only } -let vernac_search ~atts s gopt r = +let vernac_search ~pstate ~atts s gopt r = let gopt = query_command_selector gopt in let r = interp_search_restriction r in let env,gopt = match gopt with | None -> (* 1st goal by default if it exists, otherwise no goal at all *) - (try snd (Pfedit.get_goal_context 1) , Some 1 + (try snd (get_goal_or_global_context ~pstate 1) , Some 1 with _ -> Global.env (),None) (* if goal selector is given and wrong, then let exceptions be raised. *) - | Some g -> snd (Pfedit.get_goal_context g) , Some g + | Some g -> snd (get_goal_or_global_context ~pstate g) , Some g in let get_pattern c = snd (intern_constr_pattern env Evd.(from_env env) c) in let pr_search ref env c = @@ -1961,21 +2010,21 @@ let vernac_search ~atts s gopt r = in match s with | SearchPattern c -> - (Search.search_pattern gopt (get_pattern c) r |> Search.prioritize_search) pr_search + (Search.search_pattern ?pstate gopt (get_pattern c) r |> Search.prioritize_search) pr_search | SearchRewrite c -> - (Search.search_rewrite gopt (get_pattern c) r |> Search.prioritize_search) pr_search + (Search.search_rewrite ?pstate gopt (get_pattern c) r |> Search.prioritize_search) pr_search | SearchHead c -> - (Search.search_by_head gopt (get_pattern c) r |> Search.prioritize_search) pr_search + (Search.search_by_head ?pstate 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 Evd.(from_env env))) sl) r |> + (Search.search_about ?pstate gopt (List.map (on_snd (interp_search_about_item env Evd.(from_env env))) sl) r |> Search.prioritize_search) pr_search -let vernac_locate = function +let vernac_locate ~pstate = function | LocateAny {v=AN qid} -> print_located_qualid qid | LocateTerm {v=AN qid} -> print_located_term qid | LocateAny {v=ByNotation (ntn, sc)} (* TODO : handle Ltac notations *) | LocateTerm {v=ByNotation (ntn, sc)} -> - let _, env = Pfedit.get_current_context () in + let _, env = get_current_or_global_context ~pstate in Notation.locate_notation (Constrextern.without_symbols (pr_lglob_constr_env env)) ntn sc | LocateLibrary qid -> print_located_library qid @@ -1983,9 +2032,9 @@ let vernac_locate = function | LocateOther (s, qid) -> print_located_other s qid | LocateFile f -> locate_file f -let vernac_register qid r = +let vernac_register ~pstate qid r = let gr = Smartlocate.global_with_alias qid in - if Proof_global.there_are_pending_proofs () then + if there_are_pending_proofs ~pstate then user_err Pp.(str "Cannot register a primitive while in proof editing mode."); match r with | RegisterInline -> @@ -2029,8 +2078,8 @@ let vernac_unfocus () = (fun _ p -> Proof.unfocus command_focus p ()) (* Checks that a proof is fully unfocused. Raises an error if not. *) -let vernac_unfocused () = - let p = Proof_global.give_me_the_proof () in +let vernac_unfocused ~pstate = + let p = Proof_global.give_me_the_proof pstate in if Proof.unfocused p then str"The proof is indeed fully unfocused." else @@ -2060,25 +2109,39 @@ let vernac_bullet (bullet : Proof_bullet.t) = Proof_global.simple_with_current_proof (fun _ p -> Proof_bullet.put p bullet) -let vernac_show = function - | ShowScript -> assert false (* Only the stm knows the script *) - | ShowGoal goalref -> - let proof = Proof_global.give_me_the_proof () in - begin match goalref with - | OpenSubgoals -> pr_open_subgoals ~proof - | NthGoal n -> pr_nth_open_subgoal ~proof n - | GoalId id -> pr_goal_by_id ~proof id +let vernac_show ~pstate = + match pstate with + (* Show functions that don't require a proof state *) + | None -> + begin function + | ShowProof -> show_proof ~pstate + | ShowMatch id -> show_match id + | ShowScript -> assert false (* Only the stm knows the script *) + | _ -> + user_err (str "This command requires an open proof.") end - | ShowProof -> show_proof () - | ShowExistentials -> show_top_evars () - | ShowUniverses -> show_universes () - | ShowProofNames -> - pr_sequence Id.print (Proof_global.get_all_proof_names()) - | ShowIntros all -> show_intro all - | ShowMatch id -> show_match id - -let vernac_check_guard () = - let pts = Proof_global.give_me_the_proof () in + (* Show functions that require a proof state *) + | Some pstate -> + begin function + | ShowGoal goalref -> + let proof = Proof_global.give_me_the_proof pstate in + begin match goalref with + | OpenSubgoals -> pr_open_subgoals ~proof + | NthGoal n -> pr_nth_open_subgoal ~proof n + | GoalId id -> pr_goal_by_id ~proof id + end + | ShowExistentials -> show_top_evars ~pstate + | ShowUniverses -> show_universes ~pstate + | ShowProofNames -> + pr_sequence Id.print (Proof_global.get_all_proof_names pstate) + | ShowIntros all -> show_intro ~pstate all + | ShowProof -> show_proof ~pstate:(Some pstate) + | ShowMatch id -> show_match id + | ShowScript -> assert false (* Only the stm knows the script *) + end + +let vernac_check_guard ~pstate = + let pts = Proof_global.give_me_the_proof pstate in let pfterm = List.hd (Proof.partial_proof pts) in let message = try @@ -2097,8 +2160,9 @@ exception End_of_input the way the proof mode is set there makes the task non trivial without a considerable amount of refactoring. *) -let vernac_load interp fname = - if Proof_global.there_are_pending_proofs () then +let vernac_load ~st interp fname = + let pstate = st.Vernacstate.proof in + if there_are_pending_proofs ~pstate then CErrors.user_err Pp.(str "Load is not supported inside proofs."); let parse_sentence proof_mode = Flags.with_option Flags.we_are_parsing (fun po -> @@ -2111,22 +2175,22 @@ let vernac_load interp fname = let input = let longfname = Loadpath.locate_file fname in let in_chan = open_utf8_file_in longfname in - Pcoq.Parsable.make ~file:(Loc.InFile longfname) (Stream.of_channel in_chan) in - begin - try while true do - let proof_mode = - if Proof_global.there_are_pending_proofs () then - Some (get_default_proof_mode ()) - else - None - in - interp (parse_sentence proof_mode input).CAst.v; - done - with End_of_input -> () - end; + Pcoq.Parsable.make ~loc:(Loc.initial (Loc.InFile longfname)) (Stream.of_channel in_chan) in + let rec load_loop ~pstate = + try + let proof_mode = Option.map (fun _ -> get_default_proof_mode ()) pstate in + let pstate = interp ~st:{ st with Vernacstate.proof = pstate } + (parse_sentence proof_mode input).CAst.v in + load_loop ~pstate + with + End_of_input -> + pstate + in + let pstate = load_loop ~pstate in (* If Load left a proof open, we fail too. *) - if Proof_global.there_are_pending_proofs () then - CErrors.user_err Pp.(str "Files processed by Load cannot leave open proofs.") + if there_are_pending_proofs ~pstate then + CErrors.user_err Pp.(str "Files processed by Load cannot leave open proofs."); + pstate let with_locality ~atts f = let local = Attributes.(parse locality atts) in @@ -2151,7 +2215,8 @@ let with_def_attributes ~atts f = * is the outdated/deprecated "Local" attribute of some vernacular commands * still parsed as the obsolete_locality grammar entry for retrocompatibility. * loc is the Loc.t of the vernacular command being interpreted. *) -let interp ?proof ~atts ~st c = +let interp ?proof ~atts ~st c : Proof_global.t option = + let pstate = st.Vernacstate.proof in vernac_pperr_endline (fun () -> str "interpreting: " ++ Ppvernac.pr_vernac_expr c); match c with @@ -2175,145 +2240,309 @@ let interp ?proof ~atts ~st c = (* Syntax *) | VernacSyntaxExtension (infix, sl) -> - with_module_locality ~atts vernac_syntax_extension infix sl - | VernacDeclareScope sc -> with_module_locality ~atts vernac_declare_scope sc - | VernacDelimiters (sc,lr) -> with_module_locality ~atts vernac_delimiters sc lr - | VernacBindScope (sc,rl) -> with_module_locality ~atts vernac_bind_scope sc rl - | VernacOpenCloseScope (b, s) -> with_section_locality ~atts vernac_open_close_scope (b,s) - | VernacInfix (mv,qid,sc) -> with_module_locality ~atts vernac_infix mv qid sc - | VernacNotation (c,infpl,sc) -> with_module_locality ~atts vernac_notation c infpl sc + with_module_locality ~atts vernac_syntax_extension infix sl; + pstate + | VernacDeclareScope sc -> + with_module_locality ~atts vernac_declare_scope sc; + pstate + | VernacDelimiters (sc,lr) -> + with_module_locality ~atts vernac_delimiters sc lr; + pstate + | VernacBindScope (sc,rl) -> + with_module_locality ~atts vernac_bind_scope sc rl; + pstate + | VernacOpenCloseScope (b, s) -> + with_section_locality ~atts vernac_open_close_scope (b,s); + pstate + | VernacInfix (mv,qid,sc) -> + with_module_locality ~atts vernac_infix mv qid sc; + pstate + | VernacNotation (c,infpl,sc) -> + with_module_locality ~atts vernac_notation c infpl sc; + pstate | VernacNotationAddFormat(n,k,v) -> unsupported_attributes atts; - Metasyntax.add_notation_extra_printing_rule n k v + Metasyntax.add_notation_extra_printing_rule n k v; + pstate | VernacDeclareCustomEntry s -> - with_module_locality ~atts vernac_custom_entry s + with_module_locality ~atts vernac_custom_entry s; + pstate (* Gallina *) | VernacDefinition ((discharge,kind),lid,d) -> - with_def_attributes ~atts vernac_definition discharge kind lid d - | VernacStartTheoremProof (k,l) -> with_def_attributes vernac_start_proof ~atts k l - | VernacEndProof e -> unsupported_attributes atts; vernac_end_proof ?proof e - | VernacExactProof c -> unsupported_attributes atts; vernac_exact_proof c + with_def_attributes ~atts vernac_definition ~pstate discharge kind lid d + | VernacStartTheoremProof (k,l) -> + with_def_attributes ~atts vernac_start_proof ~pstate k l + | VernacEndProof e -> + unsupported_attributes atts; + vernac_end_proof ?proof ?pstate e + | VernacExactProof c -> + unsupported_attributes atts; + vernac_require_open_proof ~pstate (vernac_exact_proof c) | VernacAssumption ((discharge,kind),nl,l) -> - with_def_attributes vernac_assumption ~atts discharge kind l nl - | VernacInductive (cum, priv, finite, l) -> vernac_inductive ~atts cum priv finite l - | VernacFixpoint (discharge, l) -> with_def_attributes vernac_fixpoint ~atts discharge l - | VernacCoFixpoint (discharge, l) -> with_def_attributes vernac_cofixpoint ~atts discharge l - | VernacScheme l -> unsupported_attributes atts; vernac_scheme l - | VernacCombinedScheme (id, l) -> unsupported_attributes atts; vernac_combined_scheme id l - | VernacUniverse l -> vernac_universe ~poly:(only_polymorphism atts) l - | VernacConstraint l -> vernac_constraint ~poly:(only_polymorphism atts) l + with_def_attributes ~atts vernac_assumption ~pstate discharge kind l nl; + pstate + | VernacInductive (cum, priv, finite, l) -> + vernac_inductive ~atts cum priv finite l; + pstate + | VernacFixpoint (discharge, l) -> + with_def_attributes ~atts vernac_fixpoint ~pstate discharge l + | VernacCoFixpoint (discharge, l) -> + with_def_attributes ~atts vernac_cofixpoint ~pstate discharge l + | VernacScheme l -> + unsupported_attributes atts; + vernac_scheme l; + pstate + | VernacCombinedScheme (id, l) -> + unsupported_attributes atts; + vernac_combined_scheme id l; + pstate + | VernacUniverse l -> + vernac_universe ~poly:(only_polymorphism atts) l; + pstate + | VernacConstraint l -> + vernac_constraint ~poly:(only_polymorphism atts) l; + pstate (* Modules *) | VernacDeclareModule (export,lid,bl,mtyo) -> - unsupported_attributes atts; vernac_declare_module export lid bl mtyo + unsupported_attributes atts; + vernac_declare_module export lid bl mtyo; + pstate | VernacDefineModule (export,lid,bl,mtys,mexprl) -> - unsupported_attributes atts; vernac_define_module export lid bl mtys mexprl + unsupported_attributes atts; + vernac_define_module ~pstate export lid bl mtys mexprl; + pstate | VernacDeclareModuleType (lid,bl,mtys,mtyo) -> - unsupported_attributes atts; vernac_declare_module_type lid bl mtys mtyo + unsupported_attributes atts; + vernac_declare_module_type ~pstate lid bl mtys mtyo; + pstate | VernacInclude in_asts -> - unsupported_attributes atts; vernac_include in_asts + unsupported_attributes atts; + vernac_include in_asts; + pstate (* Gallina extensions *) - | VernacBeginSection lid -> unsupported_attributes atts; vernac_begin_section lid + | VernacBeginSection lid -> + unsupported_attributes atts; + vernac_begin_section ~pstate lid; + pstate - | VernacEndSegment lid -> unsupported_attributes atts; vernac_end_segment lid + | VernacEndSegment lid -> + unsupported_attributes atts; + vernac_end_segment ~pstate lid; + pstate - | VernacNameSectionHypSet (lid, set) -> unsupported_attributes atts; vernac_name_sec_hyp lid set + | VernacNameSectionHypSet (lid, set) -> + unsupported_attributes atts; + vernac_name_sec_hyp lid set; + pstate - | VernacRequire (from, export, qidl) -> unsupported_attributes atts; vernac_require from export qidl - | VernacImport (export,qidl) -> unsupported_attributes atts; vernac_import export qidl - | VernacCanonical qid -> unsupported_attributes atts; vernac_canonical qid - | VernacCoercion (r,s,t) -> vernac_coercion ~atts r s t + | VernacRequire (from, export, qidl) -> + unsupported_attributes atts; + vernac_require from export qidl; + pstate + | VernacImport (export,qidl) -> + unsupported_attributes atts; + vernac_import export qidl; + pstate + | VernacCanonical qid -> + unsupported_attributes atts; + vernac_canonical qid; + pstate + | VernacCoercion (r,s,t) -> + vernac_coercion ~atts r s t; + pstate | VernacIdentityCoercion ({v=id},s,t) -> - vernac_identity_coercion ~atts id s t + vernac_identity_coercion ~atts id s t; + pstate (* Type classes *) | VernacInstance (sup, inst, props, info) -> - with_def_attributes vernac_instance ~atts sup inst props info + snd @@ with_def_attributes ~atts (vernac_instance ~pstate sup inst props info) | VernacDeclareInstance (sup, inst, info) -> - with_def_attributes vernac_declare_instance ~atts sup inst info - | VernacContext sup -> vernac_context ~poly:(only_polymorphism atts) sup - | VernacExistingInstance insts -> with_section_locality ~atts vernac_existing_instance insts - | VernacExistingClass id -> unsupported_attributes atts; vernac_existing_class id + with_def_attributes ~atts vernac_declare_instance sup inst info; + pstate + | VernacContext sup -> + let () = vernac_context ~pstate ~poly:(only_polymorphism atts) sup in + pstate + | VernacExistingInstance insts -> + with_section_locality ~atts vernac_existing_instance insts; + pstate + | VernacExistingClass id -> + unsupported_attributes atts; + vernac_existing_class id; + pstate (* Solving *) - | VernacSolveExistential (n,c) -> unsupported_attributes atts; vernac_solve_existential n c + | VernacSolveExistential (n,c) -> + unsupported_attributes atts; + Some (vernac_require_open_proof ~pstate (vernac_solve_existential n c)) (* Auxiliary file and library management *) - | VernacAddLoadPath (isrec,s,alias) -> unsupported_attributes atts; vernac_add_loadpath isrec s alias - | VernacRemoveLoadPath s -> unsupported_attributes atts; vernac_remove_loadpath s - | VernacAddMLPath (isrec,s) -> unsupported_attributes atts; vernac_add_ml_path isrec s - | VernacDeclareMLModule l -> with_locality ~atts vernac_declare_ml_module l - | VernacChdir s -> unsupported_attributes atts; vernac_chdir s + | VernacAddLoadPath (isrec,s,alias) -> + unsupported_attributes atts; + vernac_add_loadpath isrec s alias; + pstate + | VernacRemoveLoadPath s -> + unsupported_attributes atts; + vernac_remove_loadpath s; + pstate + | VernacAddMLPath (isrec,s) -> + unsupported_attributes atts; + vernac_add_ml_path isrec s; + pstate + | VernacDeclareMLModule l -> + with_locality ~atts vernac_declare_ml_module l; + pstate + | VernacChdir s -> + unsupported_attributes atts; + vernac_chdir s; + pstate (* State management *) - | VernacWriteState s -> unsupported_attributes atts; vernac_write_state s - | VernacRestoreState s -> unsupported_attributes atts; vernac_restore_state s + | VernacWriteState s -> + unsupported_attributes atts; + vernac_write_state s; + pstate + | VernacRestoreState s -> + unsupported_attributes atts; + vernac_restore_state s; + pstate (* Commands *) | VernacCreateHintDb (dbname,b) -> - with_module_locality ~atts vernac_create_hintdb dbname b + with_module_locality ~atts vernac_create_hintdb dbname b; + pstate | VernacRemoveHints (dbnames,ids) -> - with_module_locality ~atts vernac_remove_hints dbnames ids + with_module_locality ~atts vernac_remove_hints dbnames ids; + pstate | VernacHints (dbnames,hints) -> - vernac_hints ~atts dbnames hints + vernac_hints ~atts dbnames hints; + pstate | VernacSyntacticDefinition (id,c,b) -> - with_module_locality ~atts vernac_syntactic_definition id c b + with_module_locality ~atts vernac_syntactic_definition id c b; + pstate | VernacArguments (qid, args, more_implicits, nargs, flags) -> - with_section_locality ~atts vernac_arguments qid args more_implicits nargs flags - | VernacReserve bl -> unsupported_attributes atts; vernac_reserve bl - | VernacGeneralizable gen -> with_locality ~atts vernac_generalizable gen - | VernacSetOpacity qidl -> with_locality ~atts vernac_set_opacity qidl - | VernacSetStrategy l -> with_locality ~atts vernac_set_strategy l - | VernacSetOption (export, key,v) -> vernac_set_option ~local:(only_locality atts) export key v - | VernacUnsetOption (export, key) -> vernac_unset_option ~local:(only_locality atts) export key - | VernacRemoveOption (key,v) -> unsupported_attributes atts; vernac_remove_option key v - | VernacAddOption (key,v) -> unsupported_attributes atts; vernac_add_option key v - | VernacMemOption (key,v) -> unsupported_attributes atts; vernac_mem_option key v - | VernacPrintOption key -> unsupported_attributes atts; vernac_print_option key + with_section_locality ~atts vernac_arguments qid args more_implicits nargs flags; + pstate + | VernacReserve bl -> + unsupported_attributes atts; + vernac_reserve bl; + pstate + | VernacGeneralizable gen -> + with_locality ~atts vernac_generalizable gen; + pstate + | VernacSetOpacity qidl -> + with_locality ~atts vernac_set_opacity qidl; + pstate + | VernacSetStrategy l -> + with_locality ~atts vernac_set_strategy l; + pstate + | VernacSetOption (export, key,v) -> + vernac_set_option ~local:(only_locality atts) export key v; + pstate + | VernacUnsetOption (export, key) -> + vernac_unset_option ~local:(only_locality atts) export key; + pstate + | VernacRemoveOption (key,v) -> + unsupported_attributes atts; + vernac_remove_option key v; + pstate + | VernacAddOption (key,v) -> + unsupported_attributes atts; + vernac_add_option key v; + pstate + | VernacMemOption (key,v) -> + unsupported_attributes atts; + vernac_mem_option key v; + pstate + | VernacPrintOption key -> + unsupported_attributes atts; + vernac_print_option key; + pstate | VernacCheckMayEval (r,g,c) -> - Feedback.msg_notice @@ vernac_check_may_eval ~atts r g c - | VernacDeclareReduction (s,r) -> with_locality ~atts vernac_declare_reduction s r + Feedback.msg_notice @@ + vernac_check_may_eval ~pstate ~atts r g c; + pstate + | VernacDeclareReduction (s,r) -> + with_locality ~atts vernac_declare_reduction s r; + pstate | VernacGlobalCheck c -> unsupported_attributes atts; - Feedback.msg_notice @@ vernac_global_check c + Feedback.msg_notice @@ vernac_global_check c; + pstate | VernacPrint p -> - let sigma, env = Pfedit.get_current_context () in - Feedback.msg_notice @@ vernac_print ~atts env sigma p - | VernacSearch (s,g,r) -> unsupported_attributes atts; vernac_search ~atts s g r + Feedback.msg_notice @@ vernac_print ~pstate ~atts p; + pstate + | VernacSearch (s,g,r) -> + unsupported_attributes atts; + vernac_search ~pstate ~atts s g r; + pstate | VernacLocate l -> unsupported_attributes atts; - Feedback.msg_notice @@ vernac_locate l - | VernacRegister (qid, r) -> unsupported_attributes atts; vernac_register qid r - | VernacPrimitive (id, prim, typopt) -> unsupported_attributes atts; ComAssumption.do_primitive id prim typopt - | VernacComments l -> unsupported_attributes atts; - Flags.if_verbose Feedback.msg_info (str "Comments ok\n") + Feedback.msg_notice @@ vernac_locate ~pstate l; + pstate + | VernacRegister (qid, r) -> + unsupported_attributes atts; + vernac_register ~pstate qid r; + pstate + | VernacPrimitive (id, prim, typopt) -> + unsupported_attributes atts; + ComAssumption.do_primitive id prim typopt; + pstate + | VernacComments l -> + unsupported_attributes atts; + Flags.if_verbose Feedback.msg_info (str "Comments ok\n"); + pstate (* Proof management *) - | VernacFocus n -> unsupported_attributes atts; vernac_focus n - | VernacUnfocus -> unsupported_attributes atts; vernac_unfocus () - | VernacUnfocused -> unsupported_attributes atts; - Feedback.msg_notice @@ vernac_unfocused () - | VernacBullet b -> unsupported_attributes atts; vernac_bullet b - | VernacSubproof n -> unsupported_attributes atts; vernac_subproof n - | VernacEndSubproof -> unsupported_attributes atts; vernac_end_subproof () - | VernacShow s -> unsupported_attributes atts; - Feedback.msg_notice @@ vernac_show s - | VernacCheckGuard -> unsupported_attributes atts; - Feedback.msg_notice @@ vernac_check_guard () - | VernacProof (tac, using) -> unsupported_attributes atts; + | VernacFocus n -> + unsupported_attributes atts; + Option.map (vernac_focus n) pstate + | VernacUnfocus -> + unsupported_attributes atts; + Option.map (vernac_unfocus ()) pstate + | VernacUnfocused -> + unsupported_attributes atts; + Option.iter (fun pstate -> Feedback.msg_notice @@ vernac_unfocused ~pstate) pstate; + pstate + | VernacBullet b -> + unsupported_attributes atts; + Option.map (vernac_bullet b) pstate + | VernacSubproof n -> + unsupported_attributes atts; + Option.map (vernac_subproof n) pstate + | VernacEndSubproof -> + unsupported_attributes atts; + Option.map (vernac_end_subproof ()) pstate + | VernacShow s -> + unsupported_attributes atts; + Feedback.msg_notice @@ vernac_show ~pstate s; + pstate + | VernacCheckGuard -> + unsupported_attributes atts; + Feedback.msg_notice @@ + vernac_require_open_proof ~pstate (vernac_check_guard); + pstate + | VernacProof (tac, using) -> + unsupported_attributes atts; let using = Option.append using (Proof_using.get_default_proof_using ()) in let tacs = if Option.is_empty tac then "tac:no" else "tac:yes" in let usings = if Option.is_empty using then "using:no" else "using:yes" in Aux_file.record_in_aux_at "VernacProof" (tacs^" "^usings); - Option.iter vernac_set_end_tac tac; - Option.iter vernac_set_used_variables using - | VernacProofMode mn -> unsupported_attributes atts; () + let pstate = + vernac_require_open_proof ~pstate (fun ~pstate -> + let pstate = Option.cata (vernac_set_end_tac ~pstate) pstate tac in + Option.cata (vernac_set_used_variables ~pstate) pstate using) + in Some pstate + | VernacProofMode mn -> + unsupported_attributes atts; + pstate (* Extensions *) | VernacExtend (opn,args) -> (* XXX: Here we are returning the state! :) *) - let _st : Vernacstate.t = Vernacextend.call ~atts opn args ~st in - () + let st : Vernacstate.t = Vernacextend.call ~atts opn args ~st in + st.Vernacstate.proof (** A global default timeout, controlled by option "Set Default Timeout n". Use "Unset Default Timeout" to deactivate it (or set it to 0). *) @@ -2333,12 +2562,18 @@ let () = let current_timeout = ref None -let vernac_timeout f = +let vernac_timeout (f : 'a -> 'b) (x : 'a) : 'b = match !current_timeout, !default_timeout with - | Some n, _ | None, Some n -> - let f () = f (); current_timeout := None in - Control.timeout n f () Timeout - | None, None -> f () + | Some n, _ + | None, Some n -> + let f v = + let res = f v in + current_timeout := None; + res + in + Control.timeout n f x Timeout + | None, None -> + f x let restore_timeout () = current_timeout := None @@ -2354,84 +2589,87 @@ let test_mode = ref false (* XXX STATE: this type hints that restoring the state should be the caller's responsibility *) -let with_fail st b f = - if not b - then f () - else begin try - (* If the command actually works, ignore its effects on the state. +let with_fail ~st f = + try + (* If the command actually works, ignore its effects on the state. * Note that error has to be printed in the right state, hence * within the purified function *) - try f (); raise HasNotFailed - with - | HasNotFailed as e -> raise e - | e -> - let e = CErrors.push e in - raise (HasFailed (CErrors.iprint - (ExplainErr.process_vernac_interp_error ~allow_uncaught:false e))) - with e when CErrors.noncritical e -> - (* Restore the previous state XXX Careful here with the cache! *) - Vernacstate.invalidate_cache (); - Vernacstate.unfreeze_interp_state st; - let (e, _) = CErrors.push e in - match e with - | HasNotFailed -> - user_err ~hdr:"Fail" (str "The command has not failed!") - | HasFailed msg -> - if not !Flags.quiet || !test_mode then Feedback.msg_info - (str "The command has indeed failed with message:" ++ fnl () ++ msg) - | _ -> assert false - end - -let interp ?(verbosely=true) ?proof ~st {CAst.loc;v=c} = - let rec control = function + try let _ = f () in raise HasNotFailed + with + | HasNotFailed as e -> raise e + | e -> + let e = CErrors.push e in + raise (HasFailed (CErrors.iprint + (ExplainErr.process_vernac_interp_error ~allow_uncaught:false e))) + with e when CErrors.noncritical e -> + (* Restore the previous state XXX Careful here with the cache! *) + Vernacstate.invalidate_cache (); + Vernacstate.unfreeze_interp_state st; + let (e, _) = CErrors.push e in + match e with + | HasNotFailed -> + user_err ~hdr:"Fail" (str "The command has not failed!") + | HasFailed msg -> + if not !Flags.quiet || !test_mode then Feedback.msg_info + (str "The command has indeed failed with message:" ++ fnl () ++ msg) + | _ -> assert false + +let interp ?(verbosely=true) ?proof ~st {CAst.loc;v=c} : Proof_global.t option = + let rec control ~st = function | VernacExpr (atts, v) -> - aux ~atts v - | VernacFail v -> with_fail st true (fun () -> control v) + aux ~atts ~st v + | VernacFail v -> + with_fail ~st (fun () -> ignore(control ~st v)); + st.Vernacstate.proof | VernacTimeout (n,v) -> current_timeout := Some n; - control v + control ~st v | VernacRedirect (s, {v}) -> - Topfmt.with_output_to_file s control v - | VernacTime (batch, com) -> + Topfmt.with_output_to_file s (control ~st) v + | VernacTime (batch, ({v} as com)) -> let header = if batch then Topfmt.pr_cmd_header com else Pp.mt () in - System.with_time ~batch ~header control com.CAst.v; + System.with_time ~batch ~header (control ~st) v; - and aux ~atts : _ -> unit = + and aux ~atts ~st : _ -> Proof_global.t option = function | VernacLoad (_,fname) -> unsupported_attributes atts; - vernac_load control fname + vernac_load ~st control fname | c -> (* NB: we keep polymorphism and program in the attributes, we're just parsing them to do our option magic. *) try - vernac_timeout begin fun () -> - if verbosely - then Flags.verbosely (interp ?proof ~atts ~st) c - else Flags.silently (interp ?proof ~atts ~st) c; - end - with - | reraise when - (match reraise with - | Timeout -> true - | e -> CErrors.noncritical e) - -> - let e = CErrors.push reraise in - let e = locate_if_not_already ?loc e in - let () = restore_timeout () in - iraise e + vernac_timeout begin fun st -> + let pstate : Proof_global.t option = + if verbosely + then Flags.verbosely (interp ?proof ~atts ~st) c + else Flags.silently (interp ?proof ~atts ~st) c + in + pstate + end st + with + | reraise when + (match reraise with + | Timeout -> true + | e -> CErrors.noncritical e) + -> + let e = CErrors.push reraise in + let e = locate_if_not_already ?loc e in + let () = restore_timeout () in + iraise e in if verbosely - then Flags.verbosely control c - else control c + then Flags.verbosely (control ~st) c + else (control ~st) c (* Be careful with the cache here in case of an exception. *) let interp ?verbosely ?proof ~st cmd = Vernacstate.unfreeze_interp_state st; try - interp ?verbosely ?proof ~st cmd; + let pstate = interp ?verbosely ?proof ~st cmd in + Vernacstate.Proof_global.set pstate; Vernacstate.freeze_interp_state ~marshallable:false with exn -> let exn = CErrors.push exn in diff --git a/vernac/vernacentries.mli b/vernac/vernacentries.mli index f43cec48e9..71cc29b6e1 100644 --- a/vernac/vernacentries.mli +++ b/vernac/vernacentries.mli @@ -33,15 +33,17 @@ val interp : val make_cases : string -> string list list -(* XXX STATE: this type hints that restoring the state should be the - caller's responsibility *) -val with_fail : Vernacstate.t -> bool -> (unit -> unit) -> unit +(** [with_fail ~st f] runs [f ()] and expects it to fail, otherwise it fails. *) +val with_fail : st:Vernacstate.t -> (unit -> 'a) -> unit val command_focus : unit Proof.focus_kind val interp_redexp_hook : (Environ.env -> Evd.evar_map -> Genredexpr.raw_red_expr -> Evd.evar_map * Redexpr.red_expr) Hook.t +(** Helper *) +val vernac_require_open_proof : pstate:Proof_global.t option -> (pstate:Proof_global.t -> 'a) -> 'a + (* Flag set when the test-suite is called. Its only effect to display verbose information for `Fail` *) val test_mode : bool ref diff --git a/vernac/vernacextend.ml b/vernac/vernacextend.ml index f5cf3401d0..4bfe5c66b5 100644 --- a/vernac/vernacextend.ml +++ b/vernac/vernacextend.ml @@ -235,7 +235,7 @@ type 'a argument_rule = | Arg_rules of 'a Extend.production_rule list type 'a vernac_argument = { - arg_printer : 'a -> Pp.t; + arg_printer : Environ.env -> Evd.evar_map -> 'a -> Pp.t; arg_parsing : 'a argument_rule; } @@ -251,6 +251,6 @@ let vernac_argument_extend ~name arg = e in let pr = arg.arg_printer in - let pr x = Genprint.PrinterBasic (fun () -> pr x) in + let pr x = Genprint.PrinterBasic (fun env sigma -> pr env sigma x) in let () = Genprint.register_vernac_print0 wit pr in (wit, entry) diff --git a/vernac/vernacextend.mli b/vernac/vernacextend.mli index 118907c31b..4d89eaffd9 100644 --- a/vernac/vernacextend.mli +++ b/vernac/vernacextend.mli @@ -109,7 +109,7 @@ type 'a argument_rule = entries instead of ty_user_symbol and thus arguments as roots. *) type 'a vernac_argument = { - arg_printer : 'a -> Pp.t; + arg_printer : Environ.env -> Evd.evar_map -> 'a -> Pp.t; arg_parsing : 'a argument_rule; } diff --git a/vernac/vernacstate.ml b/vernac/vernacstate.ml index c691dc8559..77f54361da 100644 --- a/vernac/vernacstate.ml +++ b/vernac/vernacstate.ml @@ -28,10 +28,10 @@ module Parser = struct end type t = { - parsing: Parser.state; - system : States.state; (* summary + libstack *) - proof : Proof_global.t; (* proof state *) - shallow : bool; (* is the state trimmed down (libstack) *) + parsing : Parser.state; + system : States.state; (* summary + libstack *) + proof : Proof_global.t option; (* proof state *) + shallow : bool (* is the state trimmed down (libstack) *) } let s_cache = ref None @@ -55,14 +55,14 @@ let do_if_not_cached rf f v = let freeze_interp_state ~marshallable = { system = update_cache s_cache (States.freeze ~marshallable); - proof = update_cache s_proof (Proof_global.freeze ~marshallable); + proof = !s_proof; shallow = false; parsing = Parser.cur_state (); } let unfreeze_interp_state { system; proof; parsing } = do_if_not_cached s_cache States.unfreeze system; - do_if_not_cached s_proof Proof_global.unfreeze proof; + s_proof := proof; Pcoq.unfreeze parsing let make_shallow st = @@ -71,3 +71,75 @@ let make_shallow st = system = States.replace_lib st.system @@ Lib.drop_objects lib; shallow = true; } + +(* Compatibility module *) +module Proof_global = struct + + let get () = !s_proof + let set x = s_proof := x + + let freeze ~marshallable:_ = get () + let unfreeze x = s_proof := Some x + + exception NoCurrentProof + + let () = + CErrors.register_handler begin function + | NoCurrentProof -> + CErrors.user_err Pp.(str "No focused proof (No proof-editing in progress).") + | _ -> raise CErrors.Unhandled + end + + open Proof_global + + let cc f = match !s_proof with + | None -> raise NoCurrentProof + | Some x -> f x + + let dd f = match !s_proof with + | None -> raise NoCurrentProof + | Some x -> s_proof := Some (f x) + + let there_are_pending_proofs () = !s_proof <> None + let get_open_goals () = cc get_open_goals + + let set_terminator x = dd (set_terminator x) + let give_me_the_proof_opt () = Option.map give_me_the_proof !s_proof + let give_me_the_proof () = cc give_me_the_proof + let get_current_proof_name () = cc get_current_proof_name + + let simple_with_current_proof f = + dd (simple_with_current_proof f) + + let with_current_proof f = + let pf, res = cc (with_current_proof f) in + s_proof := Some pf; res + + let install_state s = s_proof := Some s + + let return_proof ?allow_partial () = + cc (return_proof ?allow_partial) + + let close_future_proof ~opaque ~feedback_id pf = + cc (fun st -> close_future_proof ~opaque ~feedback_id st pf) + + let close_proof ~opaque ~keep_body_ucst_separate f = + cc (close_proof ~opaque ~keep_body_ucst_separate f) + + let discard_all () = s_proof := None + let update_global_env () = dd update_global_env + + let get_current_context () = cc Pfedit.get_current_context + + let get_all_proof_names () = + try cc get_all_proof_names + with NoCurrentProof -> [] + + let copy_terminators ~src ~tgt = + match src, tgt with + | None, None -> None + | Some _ , None -> None + | None, Some x -> Some x + | Some src, Some tgt -> Some (copy_terminators ~src ~tgt) + +end diff --git a/vernac/vernacstate.mli b/vernac/vernacstate.mli index 581c23386a..b79f97796f 100644 --- a/vernac/vernacstate.mli +++ b/vernac/vernacstate.mli @@ -19,10 +19,10 @@ module Parser : sig end type t = { - parsing: Parser.state; - system : States.state; (* summary + libstack *) - proof : Proof_global.t; (* proof state *) - shallow : bool; (* is the state trimmed down (libstack) *) + parsing : Parser.state; + system : States.state; (* summary + libstack *) + proof : Proof_global.t option; (* proof state *) + shallow : bool (* is the state trimmed down (libstack) *) } val freeze_interp_state : marshallable:bool -> t @@ -32,3 +32,53 @@ val make_shallow : t -> t (* WARNING: Do not use, it will go away in future releases *) val invalidate_cache : unit -> unit + +(* Compatibility module: Do Not Use *) +module Proof_global : sig + + open Proof_global + + (* Low-level stuff *) + val get : unit -> t option + val set : t option -> unit + + val freeze : marshallable:bool -> t option + val unfreeze : t -> unit + + exception NoCurrentProof + + val there_are_pending_proofs : unit -> bool + val get_open_goals : unit -> int + + val set_terminator : proof_terminator -> unit + val give_me_the_proof : unit -> Proof.t + val give_me_the_proof_opt : unit -> Proof.t option + val get_current_proof_name : unit -> Names.Id.t + + val simple_with_current_proof : + (unit Proofview.tactic -> Proof.t -> Proof.t) -> unit + + val with_current_proof : + (unit Proofview.tactic -> Proof.t -> Proof.t * 'a) -> 'a + + val install_state : t -> unit + + val return_proof : ?allow_partial:bool -> unit -> closed_proof_output + + val close_future_proof : + opaque:opacity_flag -> + feedback_id:Stateid.t -> + closed_proof_output Future.computation -> closed_proof + + val close_proof : opaque:opacity_flag -> keep_body_ucst_separate:bool -> Future.fix_exn -> closed_proof + + val discard_all : unit -> unit + val update_global_env : unit -> unit + + val get_current_context : unit -> Evd.evar_map * Environ.env + + val get_all_proof_names : unit -> Names.Id.t list + + val copy_terminators : src:t option -> tgt:t option -> t option + +end |
