diff options
144 files changed, 1761 insertions, 1690 deletions
diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 309044a1e9..aacd248c43 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 https://gitlab.camlcity.org/gerd/lib-findlib.git#gerd/optional-vmthreads + - 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 https://gitlab.camlcity.org/gerd/lib-findlib.git#gerd/optional-vmthreads - 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 @@ -506,6 +517,10 @@ test-suite:base+async: - build:base variables: COQFLAGS: "-async-proofs on" + 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 c1755e9271..4a66fa423e 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 @@ -239,6 +248,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 diff --git a/Makefile.doc b/Makefile.doc index 912738cd00..5ac3ecb63d 100644 --- a/Makefile.doc +++ b/Makefile.doc @@ -209,10 +209,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.ide b/Makefile.ide index efbc9ef389..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 @@ -60,11 +63,11 @@ IDEFILES=$(wildcard ide/*.lang) ide/coq_style.xml ide/coq.png ide/MacOS/default_ ## 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 @@ -102,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) @@ -112,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 $@ @@ -132,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 $< @@ -241,7 +244,7 @@ $(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 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_main.ml b/coqpp/coqpp_main.ml index cc76c44651..d33eef135f 100644 --- a/coqpp/coqpp_main.ml +++ b/coqpp/coqpp_main.ml @@ -493,7 +493,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 +579,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/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/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/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/nixpkgs.nix b/dev/nixpkgs.nix new file mode 100644 index 0000000000..4aa0f04964 --- /dev/null +++ b/dev/nixpkgs.nix @@ -0,0 +1,4 @@ +import (fetchTarball { + url = "https://github.com/NixOS/nixpkgs/archive/2923bd5d0669f1ec6ab03ddce052e9c5efb46d8f.tar.gz"; + sha256 = "16cn93rpxfql5idhigyjyhc013a3hwzyy2dl1xv7h2p78sk728vw"; +}) diff --git a/dev/top_printers.ml b/dev/top_printers.ml index 0fbb0634a5..499bbba37e 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -72,7 +72,7 @@ let pr_econstr t = 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 = Pfedit.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)) 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/type-classes.rst b/doc/sphinx/addendum/type-classes.rst index c7ea7e326f..e6a5b3972c 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``. diff --git a/doc/sphinx/language/gallina-extensions.rst b/doc/sphinx/language/gallina-extensions.rst index 59506a6ff2..18cafd1f21 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 ------------- @@ -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/proof-engine/proof-handling.rst b/doc/sphinx/proof-engine/proof-handling.rst index 27360f02d3..07215a0c7e 100644 --- a/doc/sphinx/proof-engine/proof-handling.rst +++ b/doc/sphinx/proof-engine/proof-handling.rst @@ -628,7 +628,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 +666,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 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/coqOps.ml b/ide/coqOps.ml index 8da9900724..4aa801c2b2 100644 --- a/ide/coqOps.ml +++ b/ide/coqOps.ml @@ -250,6 +250,7 @@ object(self) feedback_timer.Ideutils.run ~ms:300 ~callback:self#process_feedback; let md = segment_model document in segment#set_model md; +(* let on_click id = let find _ _ s = Int.equal s.index id in let sentence = Doc.find document find in @@ -266,6 +267,7 @@ object(self) ignore (script#scroll_to_iter ~use_align:true ~yalign:0. iter) in let _ = segment#connect#clicked ~callback:on_click in +*) () method private tooltip_callback ~x ~y ~kbd tooltip = diff --git a/ide/coqide.ml b/ide/coqide.ml index e16c7db3b4..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 @@ -816,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 @@ -943,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 @@ -976,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; @@ -1025,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 ()); ]; @@ -1226,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; @@ -1309,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 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 @@ -29,7 +29,7 @@ (wrapped false) (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) diff --git a/ide/ide.mllib b/ide/ide.mllib index f8a2d77be8..ed6520f29f 100644 --- a/ide/ide.mllib +++ b/ide/ide.mllib @@ -9,7 +9,6 @@ Config_lexer Utf8_convert Preferences Project_file -Topfmt Ideutils Unicode_bindings Coq 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 27f240a993..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) @@ -74,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 *) @@ -426,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 @@ -588,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; @@ -600,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; @@ -704,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 @@ -716,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 () @@ -737,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 @@ -753,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 @@ -763,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 @@ -934,6 +938,7 @@ let configure ?(apply=(fun () -> ())) parent = else cmd_browse#get]) cmd_browse#get in +(* let automatic_tactics = strings ~f:automatic_tactics#set @@ -942,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 @@ -977,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) *) @@ -1000,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 2c505ad180..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 @@ -112,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/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 bfa9d6e0c5..8802eb0f1c 100644 --- a/ide/wg_ScriptView.ml +++ b/ide/wg_ScriptView.ml @@ -286,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 @@ -506,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 @@ -529,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 df475f0e66..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 @@ -32,8 +32,8 @@ object 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 -> @@ -43,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..2e5de64254 100644 --- a/ide/wg_Segment.ml +++ b/ide/wg_Segment.ml @@ -8,8 +8,10 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +(* open Util open Preferences +*) type color = GDraw.color @@ -22,6 +24,7 @@ object method fold : 'a. ('a -> color -> 'a) -> 'a -> 'a end +(* let i2f = float_of_int let f2i = int_of_float @@ -32,14 +35,14 @@ let color_eq (c1 : GDraw.color) (c2 : GDraw.color) = match c1, c2 with | `RGB (r1, g1, b1), `RGB (r2, g2, b2) -> r1 = r2 && g1 = g2 && b1 = b2 | `WHITE, `WHITE -> true | _ -> false - +*) class type segment_signals = object inherit GObj.misc_signals inherit GUtil.add_ml_signals method clicked : callback:(int -> unit) -> GtkSignal.id end - +(* class segment_signals_impl obj (clicked : 'a GUtil.signal) : segment_signals = object val after = false @@ -47,11 +50,14 @@ object inherit GUtil.add_ml_signals obj [clicked#disconnect] method clicked = clicked#connect ~after 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 +*) object (self) inherit GObj.widget box#as_widget @@ -60,11 +66,13 @@ 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 = @@ -95,17 +103,18 @@ object (self) draw#set_pixmap pixmap; refresh_timer.Ideutils.run ~ms:300 ~callback:(fun () -> if need_refresh then self#refresh (); true) - +*) 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) + () +(* if self#misc#visible then self#fill_range color i (i + 1)*) in md#changed ~callback:changed_cb - +(* method private fill_range color i j = match model with | None -> () | Some md -> @@ -150,5 +159,6 @@ object (self) method connect = new segment_signals_impl box#as_widget clicked +*) end diff --git a/ide/wg_Segment.mli b/ide/wg_Segment.mli index 07f545fee7..84d487f35f 100644 --- a/ide/wg_Segment.mli +++ b/ide/wg_Segment.mli @@ -31,7 +31,9 @@ class segment : unit -> inherit GObj.widget val obj : Gtk.widget Gtk.obj method set_model : model -> unit +(* method connect : segment_signals method default_color : color method set_default_color : color -> unit +*) end 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/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/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) 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..978969bf59 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 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/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..16f376931e 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 env sigma 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 env sigma 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 env sigma 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 env sigma 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 env sigma 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 env sigma do_finalize new_infos ] g | Cast(b,_,_) -> - build_proof do_finalize {dyn_infos with info = b } g + build_proof env sigma 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 env sigma 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 env sigma do_finalize new_infos ] g | Rel _ -> anomaly (Pp.str "Free var in goal conclusion!") - and build_proof do_finalize dyn_infos g = + and build_proof env sigma 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 env sigma 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 env sigma do_finalize {dyn_infos with info = arg } g in @@ -882,7 +878,10 @@ 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 -> + let env = pf_env g in + let sigma = project g in + build_proof env sigma (clean_goal_with_heq ptes_infos do_finish_proof) dyn_infos g diff --git a/plugins/funind/g_indfun.mlg b/plugins/funind/g_indfun.mlg index c4f8843e51..6f67ab4d8b 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,7 +170,7 @@ 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 } diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 8611dcaf83..f4807954a7 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)); @@ -375,7 +375,6 @@ let add_pat_variables pat typ env : Environ.env = 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_common.ml b/plugins/funind/indfun_common.ml index 88546e9ae8..e34323abf4 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -276,12 +276,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 +287,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 +356,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..12facc5744 100644 --- a/plugins/funind/indfun_common.mli +++ b/plugins/funind/indfun_common.mli @@ -83,8 +83,8 @@ 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 *) diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 988cae8fbf..e19741a4e9 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 @@ @@ -303,7 +299,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 +326,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 *) @@ -446,7 +441,7 @@ 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 (pf_env g) 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) @@ -454,7 +449,7 @@ let rec travel_aux jinfo continuation_tac (expr_info:constr infos) g = | Lambda(n,t,b) -> begin try - check_not_nested sigma (expr_info.f_id::expr_info.forbidden_ids) expr_info.info; + check_not_nested (pf_env g) 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) @@ -507,10 +502,11 @@ 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) - (travel_aux jinfo continuation_tac expr_info) +and travel jinfo continuation_tac expr_info = + fun g -> + observe_tac + (str jinfo.message ++ Printer.pr_leconstr_env (pf_env g) (project g) expr_info.info) + (travel_aux jinfo continuation_tac expr_info) g (* Termination proof *) @@ -652,7 +648,7 @@ let terminate_letin (na,b,t,e) expr_info continuation_tac info g = let new_forbidden = let forbid = try - check_not_nested sigma (expr_info.f_id::expr_info.forbidden_ids) b; + check_not_nested (pf_env g) sigma (expr_info.f_id::expr_info.forbidden_ids) b; true with e when CErrors.noncritical e -> false in @@ -711,7 +707,7 @@ let terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos g = let sigma = project g in let f_is_present = try - check_not_nested sigma (expr_info.f_id::expr_info.forbidden_ids) a; + check_not_nested (pf_env g) sigma (expr_info.f_id::expr_info.forbidden_ids) a; false with e when CErrors.noncritical e -> true @@ -740,7 +736,7 @@ let terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos 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)) + List.iter (check_not_nested (pf_env g) sigma (expr_info.f_id::expr_info.forbidden_ids)) args; begin try @@ -987,13 +983,19 @@ let rec intros_values_eq expr_info acc = )) let equation_others _ expr_info continuation_tac infos = + fun g -> + let env = pf_env g in + let sigma = project g in 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 (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) + (fun g -> + let env = pf_env g in + let sigma = project g in + observe_tac (str "intros_values_eq equation_others " ++ Printer.pr_leconstr_env env sigma expr_info.info) (intros_values_eq expr_info []) g)) g + else observe_tac (str "equation_others (cont_tac) " ++ Printer.pr_leconstr_env env sigma expr_info.info) (continuation_tac infos) g let equation_app f_and_args expr_info continuation_tac infos = if expr_info.is_final && expr_info.is_main_branch @@ -1417,7 +1419,7 @@ let com_terminate nb_args ctx hook = let start_proof ctx (tac_start:tactic) (tac_end:tactic) = - let evd, env = Pfedit.get_current_context () in + let evd, env = Pfedit.get_current_context () in (* XXX *) Lemmas.start_proof 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; @@ -1469,7 +1471,7 @@ let (com_eqn : int -> Id.t -> | 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, env = Pfedit.get_current_context () in (* XXX *) let evd = Evd.from_ctx (Evd.evar_universe_context evd) in let f_constr = constr_of_global f_ref in let equation_lemma_type = subst1 f_constr equation_lemma_type in 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/g_auto.mlg b/plugins/ltac/g_auto.mlg index 663537f3e8..3a4b0571d4 100644 --- a/plugins/ltac/g_auto.mlg +++ b/plugins/ltac/g_auto.mlg @@ -62,21 +62,19 @@ let eval_uconstrs ist cs = 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..a348e2cea4 100644 --- a/plugins/ltac/g_ltac.mlg +++ b/plugins/ltac/g_ltac.mlg @@ -514,7 +514,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 +528,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..a12dee48a8 100644 --- a/plugins/ltac/g_obligations.mlg +++ b/plugins/ltac/g_obligations.mlg @@ -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..86a227415a 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) } @@ -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 } diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index e188971f00..1bdba699f7 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,18 @@ 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 +1325,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 +1336,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 +1394,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/tactic_debug.ml b/plugins/ltac/tactic_debug.ml index 99b9e881f6..52a83a038f 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 () 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..7db47e13a5 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 cenv sigma parse_constant parse_exp ops_spec 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 cenv sigma term); (* let constant_or_variable env term = @@ -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,8 +1031,8 @@ 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)) @@ -1048,8 +1045,8 @@ struct 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 + let (e1,env) = parse_expr gl.env sigma env lhs in + let (e2,env) = parse_expr gl.env sigma env rhs in ({Mc.flhs = e1; Mc.fop = op;Mc.frhs = e2},env) | _ -> failwith "error : parse_arith(2)" 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..3ce6478700 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,12 +74,12 @@ 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 @@ -104,26 +104,26 @@ 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 diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index 58daa7a7d4..6956120a6a 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -1232,7 +1232,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_constr_pat env sigma (EConstr.Unsafe.to_constr 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..3fc05437da 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,8 @@ 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))); + ppdebug(lazy Pp.(str"elim= "++ pr_constr_pat env (project gl) (EConstr.Unsafe.to_constr elim))); + ppdebug(lazy Pp.(str"elimty= "++ pr_constr_pat env (project gl) (EConstr.Unsafe.to_constr elimty))); let inf_deps_r = match EConstr.kind_of_type (project gl) elimty with | AtomicType (_, args) -> List.rev (Array.to_list args) | _ -> assert false in @@ -285,8 +285,8 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = (* 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_constr_pat env (project gl) (EConstr.Unsafe.to_constr (fire_subst gl t)) in let patterns, clr, gl = let rec loop patterns clr i = function | [],[] -> patterns, clr, gl @@ -300,7 +300,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_constr_pat env (project gl) (EConstr.Unsafe.to_constr c))); loop (patterns @ [i, mkTpat gl c, c, allocc]) clr (i+1) ([], inf_deps) | _::_, [] -> errorstrm Pp.(str "Too many dependent abstractions") in @@ -323,11 +323,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_constr_pat env (project gl) (EConstr.Unsafe.to_constr (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 +408,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_constr_pat env (project gl) (EConstr.Unsafe.to_constr 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..15480c7a45 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_constr_pat env sigma (EConstr.Unsafe.to_constr 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_constr_pat env sigma (EConstr.Unsafe.to_constr 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_constr_pat env sigma (EConstr.Unsafe.to_constr 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_constr_pat env0 sigma (EConstr.Unsafe.to_constr 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 @@ -412,7 +412,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_constr_pat (pf_env gl) (project gl) (EConstr.Unsafe.to_constr (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 @@ -473,7 +473,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_constr_pat env sigma (EConstr.Unsafe.to_constr t))); match EConstr.kind sigma t with | Prod (_, xt, at) -> let sigma = Evd.create_evar_defs sigma in @@ -532,8 +532,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_constr_pat env sigma (EConstr.Unsafe.to_constr t) + ++ spc() ++ str "in rule " ++ pr_constr_pat env sigma (EConstr.Unsafe.to_constr (snd rule))) in let sigma, r = rule in let t = Retyping.get_type_of env sigma r in @@ -547,9 +547,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_constr_pat env (project gl) (EConstr.Unsafe.to_constr rdx) ++ str " does not match " ++ pr_dir_side dir ++ - str " of " ++ pr_constr_pat (EConstr.Unsafe.to_constr (snd rule))) + str " of " ++ pr_constr_pat env (project gl) (EConstr.Unsafe.to_constr (snd rule))) | (d, r, lhs, rhs) :: rs -> try let ise = unify_HO env (Evd.create_evar_defs r_sigma) lhs rdx in @@ -640,7 +640,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..be9586fdd7 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_constr_pat env sigma (EConstr.Unsafe.to_constr 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/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..d3f89147fa 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,19 +558,22 @@ 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) + { + let sigma, env = Pfedit.get_current_context () 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 ] diff --git a/plugins/ssrmatching/ssrmatching.ml b/plugins/ssrmatching/ssrmatching.ml index b83a6a34cb..5eb106cc26 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,10 +368,9 @@ 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) (* Turn (new) evars into metas *) @@ -417,7 +422,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 +642,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 +689,15 @@ 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 +727,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 +772,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 +822,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_constr_pat env sigma (EConstr.Unsafe.to_constr (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,8 +1253,10 @@ 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) - ++ str " does not match any subterm of the goal") + errorstrm (str "partial term " ++ + pr_constr_pat env sigma + (EConstr.to_constr ~abort_on_undefined_evars:false sigma t) ++ + str " does not match any subterm of the goal") let pf_fill_occ_term gl occ t = let sigma0 = project gl and env = pf_env gl and concl = pf_concl gl in diff --git a/plugins/ssrmatching/ssrmatching.mli b/plugins/ssrmatching/ssrmatching.mli index ff2c900130..1143bcc813 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,7 @@ 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 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..73a2b99434 100644 --- a/plugins/syntax/g_numeral.mlg +++ b/plugins/syntax/g_numeral.mlg @@ -37,5 +37,6 @@ END VERNAC COMMAND EXTEND NumeralNotation CLASSIFIED AS SIDEFF | #[ locality = Attributes.locality; ] [ "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 } + { let (sigma, env) = Pfedit.get_current_context () in + vernac_numeral_notation env sigma (Locality.make_module_locality locality) ty f g (Id.to_string sc) o } END diff --git a/plugins/syntax/g_string.mlg b/plugins/syntax/g_string.mlg index 1e06cd8ddb..171e0e213d 100644 --- a/plugins/syntax/g_string.mlg +++ b/plugins/syntax/g_string.mlg @@ -21,5 +21,6 @@ open Stdarg VERNAC COMMAND EXTEND StringNotation CLASSIFIED AS SIDEFF | #[ locality = Attributes.locality; ] [ "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) } + { let (sigma, env) = Pfedit.get_current_context () in + vernac_string_notation env sigma (Locality.make_module_locality locality) ty f g (Id.to_string sc) } 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/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/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/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..d620e14a94 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) 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/tactics/autorewrite.ml b/tactics/autorewrite.ml index 3b8232d20a..d9c0a26f91 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 diff --git a/tactics/hints.ml b/tactics/hints.ml index a04a9f9db9..85d75f1010 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 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/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/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/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/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/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/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/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/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; } |
