diff options
142 files changed, 1439 insertions, 1516 deletions
diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 309044a1e9..e688fbd463 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 @@ -506,6 +514,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 +543,9 @@ validate:quick: extends: .validate-template dependencies: - build:quick + only: + variables: + - $UNRELIABLE =~ /enabled/ # Libraries are by convention the projects that depend on Coq # but not on its ML API diff --git a/CHANGES.md b/CHANGES.md index 3e50a13e9e..a1548f730b 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. @@ -229,6 +231,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 db1cc3746d..778863d1fc 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 @@ -56,11 +59,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 @@ -98,7 +101,7 @@ ifeq ($(HASCOQIDE),opt) $(COQIDE): $(LINKIDEOPT) $(SHOW)'OCAMLOPT -o $@' $(HIDE)$(OCAMLOPT) $(COQIDEFLAGS) $(OPTFLAGS) -o $@ \ - -linkpkg -package str,unix,dynlink,threads,lablgtk2.sourceview2 $(IDEFLAGS:.cma=.cmxa) $^ + -linkpkg -package str,unix,dynlink,threads,lablgtk3-sourceview3 -linkall $(IDEFLAGS:.cma=.cmxa) $^ $(STRIP_HIDE) $@ else $(COQIDE): $(COQIDEBYTE) @@ -108,7 +111,7 @@ endif $(COQIDEBYTE): $(LINKIDE) $(SHOW)'OCAMLC -o $@' $(HIDE)$(OCAMLC) $(COQIDEFLAGS) $(BYTEFLAGS) -o $@ \ - -linkpkg -package str,unix,dynlink,threads,lablgtk2.sourceview2 $(IDEFLAGS) $(IDECDEPSFLAGS) $^ + -linkpkg -package str,unix,dynlink,threads,lablgtk3-sourceview3 $(IDEFLAGS) $(IDECDEPSFLAGS) $^ ide/coqide_os_specific.ml: ide/coqide_$(IDEINT).ml.in config/Makefile @rm -f $@ @@ -128,7 +131,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 $< @@ -228,7 +231,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/ci-bedrock2.sh b/dev/ci/ci-bedrock2.sh index 2ac78d3c2b..2d242d80a4 100755 --- a/dev/ci/ci-bedrock2.sh +++ b/dev/ci/ci-bedrock2.sh @@ -6,4 +6,4 @@ ci_dir="$(dirname "$0")" FORCE_GIT=1 git_download bedrock2 -( cd "${CI_BUILD_DIR}/bedrock2" && git submodule update --init --recursive && COQMF_ARGS='-arg "-async-proofs-tac-j 1"' make ) +( cd "${CI_BUILD_DIR}/bedrock2" && git submodule update --init --recursive && COQMF_ARGS='-arg "-async-proofs-tac-j 1"' make | iconv -t UTF-8 -c `#9767` ) 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/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/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 94778e0c60..eaeeaa0001 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 @@ -812,7 +813,7 @@ let zoom_fit sn = let space = script#misc#allocation.Gtk.width in let cols = script#right_margin_position in let pango_ctx = script#misc#pango_context in - let layout = pango_ctx#create_layout in + let layout = pango_ctx#create_layout#as_layout in let fsize = Pango.Font.get_size (Pango.Font.from_string text_font#get) in Pango.Layout.set_text layout (String.make cols 'X'); let tlen = fst (Pango.Layout.get_pixel_size layout) in @@ -939,7 +940,7 @@ let emit_to_focus window sgn = let build_ui () = let w = GWindow.window - ~wm_class:"CoqIde" ~wm_name:"CoqIde" + ~wmclass:("CoqIde","CoqIde") ~width:window_width#get ~height:window_height#get ~title:"CoqIde" () in @@ -972,7 +973,7 @@ let build_ui () = menu file_menu [ item "File" ~label:"_File"; item "New" ~callback:File.newfile ~stock:`NEW; - item "Open" ~callback:File.load ~stock:`OPEN; + item "Open" ~callback:(File.load ~parent:w) ~stock:`OPEN; item "Save" ~callback:(File.save ~parent:w) ~stock:`SAVE ~tooltip:"Save current buffer"; item "Save as" ~label:"S_ave as" ~stock:`SAVE_AS ~callback:(File.saveas ~parent:w); item "Save all" ~label:"Sa_ve all" ~callback:File.saveall; @@ -1021,7 +1022,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 ()); ]; @@ -1220,10 +1222,10 @@ let build_ui () = ((Coqide_ui.ui_m#get_widget "/CoqIde ToolBar")#as_widget) in let () = GtkButton.Toolbar.set - ~orientation:`HORIZONTAL ~style:`ICONS ~tooltips:true tbar + ~orientation:`HORIZONTAL ~style:`ICONS tbar in - let toolbar = new GObj.widget tbar in - let () = vbox#pack toolbar in + let toolbar = new GButton.toolbar tbar in + let () = vbox#pack toolbar#coerce in (* Emacs/PG mode *) NanoPG.init w notebook all_menus; @@ -1303,11 +1305,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)) (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 a7ade71307..30ac5c9ad7 100644 --- a/ide/ide.mllib +++ b/ide/ide.mllib @@ -9,7 +9,6 @@ Config_lexer Utf8_convert Preferences Project_file -Topfmt Ideutils Coq Coq_lex diff --git a/ide/ideutils.ml b/ide/ideutils.ml index 5beaba3604..8c5b3fcc5b 100644 --- a/ide/ideutils.ml +++ b/ide/ideutils.ml @@ -8,9 +8,10 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) - open Preferences +let _ = GtkMain.Main.init () + let warn_image () = let img = GMisc.image () in img#set_stock `DIALOG_WARNING; @@ -229,14 +230,17 @@ let current_dir () = match project_path#get with | None -> "" | Some dir -> dir -let select_file_for_open ~title ?filename () = +let select_file_for_open ~title ?(filter=true) ?parent ?filename () = let file_chooser = - GWindow.file_chooser_dialog ~action:`OPEN ~modal:true ~title () + GWindow.file_chooser_dialog ~action:`OPEN ~modal:true ~title ?parent () in file_chooser#add_button_stock `CANCEL `CANCEL ; file_chooser#add_select_button_stock `OPEN `OPEN ; - file_chooser#add_filter (filter_coq_files ()); - file_chooser#add_filter (filter_all_files ()); + if filter then + begin + file_chooser#add_filter (filter_coq_files ()); + file_chooser#add_filter (filter_all_files ()) + end; file_chooser#set_default_response `OPEN; let dir = match filename with | None -> current_dir () @@ -255,10 +259,10 @@ let select_file_for_open ~title ?filename () = file_chooser#destroy (); file -let select_file_for_save ~title ?filename () = +let select_file_for_save ~title ?parent ?filename () = let file = ref None in let file_chooser = - GWindow.file_chooser_dialog ~action:`SAVE ~modal:true ~title () + GWindow.file_chooser_dialog ~action:`SAVE ~modal:true ~title ?parent () in file_chooser#add_button_stock `CANCEL `CANCEL ; file_chooser#add_select_button_stock `SAVE `SAVE ; diff --git a/ide/ideutils.mli b/ide/ideutils.mli index 531c71cd4b..57f59d19fe 100644 --- a/ide/ideutils.mli +++ b/ide/ideutils.mli @@ -30,9 +30,10 @@ val find_tag_limits : GText.tag -> GText.iter -> GText.iter * GText.iter val find_tag_start : GText.tag -> GText.iter -> GText.iter val find_tag_stop : GText.tag -> GText.iter -> GText.iter -val select_file_for_open : title:string -> ?filename:string -> unit -> string option +val select_file_for_open : + title:string -> ?filter:bool -> ?parent:GWindow.window -> ?filename:string -> unit -> string option val select_file_for_save : - title:string -> ?filename:string -> unit -> string option + title:string -> ?parent:GWindow.window -> ?filename:string -> unit -> string option val try_convert : string -> string val try_export : string -> string -> bool val stock_to_widget : diff --git a/ide/nanoPG.ml b/ide/nanoPG.ml index f2913b1d1d..d85d87142c 100644 --- a/ide/nanoPG.ml +++ b/ide/nanoPG.ml @@ -52,7 +52,7 @@ let pr_key t = type action = | Action of string * string | Callback of (gui -> unit) - | Edit of (status -> GSourceView2.source_buffer -> GText.iter -> + | Edit of (status -> GSourceView3.source_buffer -> GText.iter -> (string -> string -> unit) -> status) | Motion of (status -> GText.iter -> GText.iter * status) diff --git a/ide/preferences.ml b/ide/preferences.ml index fb0eea1405..69dbc0b235 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) @@ -73,11 +73,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 *) @@ -413,8 +413,11 @@ let attach_fg (pref : string preference) (tag : GText.tag) = let processing_color = new preference ~name:["processing_color"] ~init:"light blue" ~repr:Repr.(string) +let incompletely_processed_color = + new preference ~name:["incompletely_processed_color"] ~init:"light sky blue" ~repr:Repr.(string) + let _ = attach_bg processing_color Tags.Script.to_process -let _ = attach_bg processing_color Tags.Script.incomplete +let _ = attach_bg incompletely_processed_color Tags.Script.incomplete let tags = ref Util.String.Map.empty @@ -575,7 +578,7 @@ object (self) | None -> set#set_active true | Some c -> set#set_active false; - but#set_color (Tags.color_of_string c) + but#set_color (Gdk.Color.color_parse c) in track tag.tag_bg_color bg_color bg_unset; track tag.tag_fg_color fg_color fg_unset; @@ -587,7 +590,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; @@ -691,7 +694,7 @@ let configure ?(apply=(fun () -> ())) parent = let config_color = let box = GPack.vbox () in - let table = GPack.table + let grid = GPack.grid ~row_spacings:5 ~col_spacings:5 ~border_width:2 @@ -703,19 +706,19 @@ let configure ?(apply=(fun () -> ())) parent = in let iter i (text, pref) = let label = GMisc.label - ~text ~packing:(table#attach ~expand:`X ~left:0 ~top:i) () + ~text ~packing:(grid#attach (*~expand:`X*) ~left:0 ~top:i) () in let () = label#set_xalign 0. in let button = GButton.color_button - ~color:(Tags.color_of_string pref#get) - ~packing:(table#attach ~left:1 ~top:i) () + ~color:(Gdk.Color.color_parse pref#get) + ~packing:(grid#attach ~left:1 ~top:i) () in let _ = button#connect#color_set ~callback:begin fun () -> - pref#set (Tags.string_of_color button#color) + pref#set (Gdk.Color.color_to_string button#color) end in let reset _ = pref#reset (); - button#set_color Tags.(color_of_string pref#get) + button#set_color (Gdk.Color.color_parse pref#get) in let _ = reset_button#connect#clicked ~callback:reset in () @@ -724,6 +727,7 @@ let configure ?(apply=(fun () -> ())) parent = ("Background color", background_color); ("Background color of processed text", processed_color); ("Background color of text being processed", processing_color); + ("Background color of incompletely processed Qed", incompletely_processed_color); ("Background color of errors", error_color); ("Foreground color of errors", error_fg_color); ] in @@ -740,7 +744,7 @@ let configure ?(apply=(fun () -> ())) parent = ~packing:(box#pack ~expand:true) () in - let table = GPack.table + let grid = GPack.grid ~row_spacings:5 ~col_spacings:5 ~border_width:2 @@ -750,13 +754,13 @@ let configure ?(apply=(fun () -> ())) parent = let cb = ref [] in let iter text tag = let label = GMisc.label - ~text ~packing:(table#attach ~expand:`X ~left:0 ~top:!i) () + ~text ~packing:(grid#attach (*~expand:`X*) ~left:0 ~top:!i) () in let () = label#set_xalign 0. in let button = tag_button () in let callback () = tag#set button#tag in button#set_tag tag#get; - table#attach ~left:1 ~top:!i button#coerce; + grid#attach ~left:1 ~top:!i button#coerce; incr i; cb := callback :: !cb; in @@ -921,6 +925,7 @@ let configure ?(apply=(fun () -> ())) parent = else cmd_browse#get]) cmd_browse#get in +(* let automatic_tactics = strings ~f:automatic_tactics#set @@ -929,12 +934,14 @@ let configure ?(apply=(fun () -> ())) parent = automatic_tactics#get in +*) let contextual_menus_on_goal = pbool "Contextual menus on goal" contextual_menus_on_goal in let misc = [contextual_menus_on_goal;stop_before;reset_on_tab_switch; vertical_tabs;opposite_tabs] in +(* let add_user_query () = let input_string l v = match GToolbox.input_string ~title:l v with @@ -964,6 +971,7 @@ let configure ?(apply=(fun () -> ())) parent = user_queries#get in +*) (* ATTENTION !!!!! L'onglet Fonts doit etre en premier pour eviter un bug !!!! (shame on Benjamin) *) @@ -987,12 +995,14 @@ let configure ?(apply=(fun () -> ())) parent = Section("Externals", None, [cmd_coqtop;cmd_coqc;cmd_make;cmd_coqmakefile; cmd_coqdoc; cmd_print;cmd_editor;cmd_browse]); +(* Section("Tactics Wizard", None, [automatic_tactics]); +*) Section("Shortcuts", Some `PREFERENCES, [modifiers_valid; modifier_for_tactics; modifier_for_templates; modifier_for_display; modifier_for_navigation; - modifier_for_queries; user_queries]); + modifier_for_queries (*; user_queries *)]); Section("Misc", Some `ADD, misc)] in diff --git a/ide/preferences.mli b/ide/preferences.mli index cf2265781c..8745c2ae91 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 @@ -108,6 +108,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 5e26c50797..e95176bf4d 100644 --- a/ide/wg_ScriptView.ml +++ b/ide/wg_ScriptView.ml @@ -284,12 +284,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 @@ -461,7 +461,7 @@ object (self) in let _ = GtkSignal.connect ~sgn:move_line_signal ~callback obj in (* Plug on preferences *) - let cb clr = self#misc#modify_base [`NORMAL, `NAME clr] in + let cb clr = self#misc#modify_bg [`NORMAL, `NAME clr] in let _ = background_color#connect#changed ~callback:cb in let _ = self#misc#connect#realize ~callback:(fun () -> cb background_color#get) in @@ -484,24 +484,24 @@ object (self) stick tab_length self self#set_tab_width; stick auto_complete self self#set_auto_complete; - let cb ft = self#misc#modify_font (Pango.Font.from_string ft) in + let cb ft = self#misc#modify_font (GPango.font_description_from_string ft) in stick text_font self cb; () end -let script_view ct ?(source_buffer:GSourceView2.source_buffer option) ?draw_spaces = - GtkSourceView2.SourceView.make_params [] ~cont:( +let script_view ct ?(source_buffer:GSourceView3.source_buffer option) ?draw_spaces = + GtkSourceView3.SourceView.make_params [] ~cont:( GtkText.View.make_params ~cont:( GContainer.pack_container ~create: (fun pl -> let w = match source_buffer with - | None -> GtkSourceView2.SourceView.new_ () - | Some buf -> GtkSourceView2.SourceView.new_with_buffer + | None -> GtkSourceView3.SourceView.new_ () + | Some buf -> GtkSourceView3.SourceView.new_with_buffer (Gobject.try_cast buf#as_buffer "GtkSourceBuffer") in let w = Gobject.unsafe_cast w in Gobject.set_params (Gobject.try_cast w "GtkSourceView") pl; - Gaux.may ~f:(GtkSourceView2.SourceView.set_draw_spaces w) draw_spaces; + Gaux.may ~f:(GtkSourceView3.SourceView.set_draw_spaces w) draw_spaces; ((new script_view w ct) : script_view)))) diff --git a/ide/wg_ScriptView.mli b/ide/wg_ScriptView.mli index be6510dbe2..ef7e92ff38 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 @@ -31,8 +31,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 -> @@ -42,7 +42,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/reduction.ml b/kernel/reduction.ml index 8c364602e9..2f11f3dd6b 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -193,8 +193,6 @@ type 'a extended_conversion_function = 'a -> 'a -> unit exception NotConvertible -exception NotConvertibleVect of int - (* Convertibility of sorts *) diff --git a/kernel/reduction.mli b/kernel/reduction.mli index 0408dbf057..7dcafb7d7b 100644 --- a/kernel/reduction.mli +++ b/kernel/reduction.mli @@ -27,7 +27,6 @@ val nf_betaiota : env -> constr -> constr s conversion functions *) exception NotConvertible -exception NotConvertibleVect of int type 'a kernel_conversion_function = env -> 'a -> 'a -> unit type 'a extended_conversion_function = 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/kernel/typeops.ml b/kernel/typeops.ml index be878dd99b..12ffbf4357 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -26,6 +26,8 @@ open Type_errors module RelDecl = Context.Rel.Declaration module NamedDecl = Context.Named.Declaration +exception NotConvertibleVect of int + let conv_leq l2r env x y = default_conv CUMUL ~l2r env x y let conv_leq_vecti env v1 v2 = 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/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 047bdd2b61..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 @@ -308,7 +325,7 @@ let explain_unification_error env sigma p1 p2 = function | UnifUnivInconsistency p -> if !Constrextern.print_universes then [str "universe inconsistency: " ++ - Univ.explain_universe_inconsistency UnivNames.pr_with_global_universes p] + Univ.explain_universe_inconsistency (Termops.pr_evd_level sigma) p] else [str "universe inconsistency"] | CannotSolveConstraint ((pb,env,t,u),e) -> @@ -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; } |
