diff options
257 files changed, 1621 insertions, 1802 deletions
diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 1c5c8efc19..ea7eccb47f 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -82,7 +82,7 @@ after_script: - echo 'end:coq:build' - echo 'start:coq.install' - - make install + - make install install-byte $EXTRA_INSTALL - make install-byte - cp bin/fake_ide _install_ci/bin/ - echo 'end:coq.install' @@ -196,6 +196,7 @@ build:base: COQ_EXTRA_CONF: "-native-compiler yes -coqide opt" # coqdoc for stdlib, until we know how to build it from installed Coq EXTRA_TARGET: "stdlib" + EXTRA_INSTALL: "install-doc-stdlib-html install-doc-printable" # no coqide for 32bit: libgtk installation problems build:base+32bit: @@ -362,7 +363,7 @@ validate:edge+flambda: OPAM_SWITCH: edge OPAM_VARIANT: "+flambda" -ci-aac-tactics: +ci-aac_tactics: <<: *ci-template ci-bedrock2: @@ -378,7 +379,7 @@ ci-color: ci-compcert: <<: *ci-template-flambda -ci-coq-dpdgraph: +ci-coq_dpdgraph: <<: *ci-template ci-coquelicot: @@ -438,7 +439,7 @@ ci-paramcoq: ci-pidetop: <<: *ci-template -ci-plugin-tutorial: +ci-plugin_tutorial: <<: *ci-template ci-quickchick: diff --git a/CHANGES.md b/CHANGES.md index e280cc2fb5..9a38b18a25 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -59,6 +59,10 @@ Tactics (e.g. `?[n]` or `?n` in terms - not in patterns) are now interpreted the same way as other variable names occurring in Ltac functions. +- Hint declaration and removal should now specify a database (e.g. `Hint Resolve + foo : database`). When the database name is omitted, the hint is added to the + core database (as previously), but a deprecation warning is emitted. + Vernacular commands - `Combined Scheme` can now work when inductive schemes are generated in sort @@ -67,6 +71,11 @@ Vernacular commands - Binders for an `Instance` now act more like binders for a `Theorem`. Names may not be repeated, and may not overlap with section variable names. +- Removed the deprecated `Implicit Tactic` family of commands. + +- The `Automatic Introduction` option has been removed and is now the + default. + Tools - The `-native-compiler` flag of `coqc` and `coqtop` now takes an argument which can have three values: @@ -93,6 +102,15 @@ Standard Library - Added `ByteVector` type that can convert to and from [string]. +- The prelude used to be automatically Exported and is now only + Imported. This should be relevant only when importing files which + don't use -noinit into files which do. + +Universes + +- Added `Print Universes Subgraph` variant of `Print Universes`. + Try for instance `Print Universes Subgraph(sigT2.u1 sigT_of_sigT2.u1 projT3_eq.u1 eq_sigT2_rect.u1).` + Changes from 8.8.2 to 8.9+beta1 =============================== diff --git a/Makefile.ci b/Makefile.ci index e8fea11bdb..88ea64974a 100644 --- a/Makefile.ci +++ b/Makefile.ci @@ -9,12 +9,12 @@ ########################################################################## CI_TARGETS= \ - ci-aac-tactics \ + ci-aac_tactics \ ci-bedrock2 \ ci-bignums \ ci-color \ ci-compcert \ - ci-coq-dpdgraph \ + ci-coq_dpdgraph \ ci-coquelicot \ ci-corn \ ci-cpdt \ @@ -38,7 +38,7 @@ CI_TARGETS= \ ci-mtac2 \ ci-paramcoq \ ci-pidetop \ - ci-plugin-tutorial \ + ci-plugin_tutorial \ ci-quickchick \ ci-sf \ ci-simple-io \ diff --git a/checker/dune b/checker/dune index 35a35a1f82..3ab4f50d13 100644 --- a/checker/dune +++ b/checker/dune @@ -14,7 +14,7 @@ %{project_root}/kernel/{cbytegen,clambda,nativeinstr,nativevalues,nativeconv,nativecode,nativelib,nativelibrary,nativelambda}.ml{,i}) (copy_files# - %{project_root}/kernel/{subtyping,term_typing,safe_typing,entries,cooking}.ml{,i}) + %{project_root}/kernel/{subtyping,term_typing,safe_typing,entries,cooking,transparentState}.ml{,i}) ; VM stuff diff --git a/clib/dyn.ml b/clib/dyn.ml index 6c45767246..22c49706be 100644 --- a/clib/dyn.ml +++ b/clib/dyn.ml @@ -38,6 +38,7 @@ sig type t = Dyn : 'a tag * 'a -> t val create : string -> 'a tag + val anonymous : int -> 'a tag val eq : 'a tag -> 'b tag -> ('a, 'b) CSig.eq option val repr : 'a tag -> string @@ -81,15 +82,22 @@ module Self : PreS = struct let create (s : string) = let hash = Hashtbl.hash s in - let () = - if Int.Map.mem hash !dyntab then - let old = Int.Map.find hash !dyntab in - let () = Printf.eprintf "Dynamic tag collision: %s vs. %s\n%!" s old in - assert false - in - let () = dyntab := Int.Map.add hash s !dyntab in + if Int.Map.mem hash !dyntab then begin + let old = Int.Map.find hash !dyntab in + Printf.eprintf "Dynamic tag collision: %s vs. %s\n%!" s old; + assert false + end; + dyntab := Int.Map.add hash s !dyntab; hash + let anonymous n = + if Int.Map.mem n !dyntab then begin + Printf.eprintf "Dynamic tag collision: %d\n%!" n; + assert false + end; + dyntab := Int.Map.add n "<anonymous>" !dyntab; + n + let eq : 'a 'b. 'a tag -> 'b tag -> ('a, 'b) CSig.eq option = fun h1 h2 -> if Int.equal h1 h2 then Some (Obj.magic CSig.Refl) else None diff --git a/clib/dyn.mli b/clib/dyn.mli index ff9762bd6b..1bd78b2db8 100644 --- a/clib/dyn.mli +++ b/clib/dyn.mli @@ -48,6 +48,12 @@ sig Type names are hashed, so [create] may raise even if no type with the exact same name was registered due to a collision. *) + val anonymous : int -> 'a tag + (** [anonymous i] returns a tag describing an [i]-th anonymous type. + If [anonymous] is not used together with [create], [max_int] anonymous types + are available. + [anonymous] raises an exception if [i] is already registered. *) + val eq : 'a tag -> 'b tag -> ('a, 'b) CSig.eq option (** [eq t1 t2] returns [Some witness] if [t1] is the same as [t2], [None] otherwise. *) diff --git a/clib/store.ml b/clib/store.ml index 1469358c9d..79e26908d7 100644 --- a/clib/store.ml +++ b/clib/store.ml @@ -20,70 +20,37 @@ module type S = sig type t type 'a field + val field : unit -> 'a field val empty : t val set : t -> 'a field -> 'a -> t val get : t -> 'a field -> 'a option val remove : t -> 'a field -> t val merge : t -> t -> t - val field : unit -> 'a field end -module Make () : S = +module Make() : S = struct - - let next = - let count = ref 0 in fun () -> - let n = !count in - incr count; - n - - type t = Obj.t option array - (** Store are represented as arrays. For small values, which is typicial, - is slightly quicker than other implementations. *) - -type 'a field = int - -let allocate len : t = Array.make len None - -let empty : t = [||] - -let set (s : t) (i : 'a field) (v : 'a) : t = - let len = Array.length s in - let nlen = if i < len then len else succ i in - let () = assert (0 <= i) in - let ans = allocate nlen in - Array.blit s 0 ans 0 len; - Array.unsafe_set ans i (Some (Obj.repr v)); - ans - -let get (s : t) (i : 'a field) : 'a option = - let len = Array.length s in - if len <= i then None - else Obj.magic (Array.unsafe_get s i) - -let remove (s : t) (i : 'a field) = - let len = Array.length s in - let () = assert (0 <= i) in - let ans = allocate len in - Array.blit s 0 ans 0 len; - if i < len then Array.unsafe_set ans i None; - ans - -let merge (s1 : t) (s2 : t) : t = - let len1 = Array.length s1 in - let len2 = Array.length s2 in - let nlen = if len1 < len2 then len2 else len1 in - let ans = allocate nlen in - (** Important: No more allocation from here. *) - Array.blit s2 0 ans 0 len2; - for i = 0 to pred len1 do - let v = Array.unsafe_get s1 i in - match v with - | None -> () - | Some _ -> Array.unsafe_set ans i v - done; - ans - -let field () = next () - + module Dyn = Dyn.Make() + module Map = Dyn.Map(struct type 'a t = 'a end) + + type t = Map.t + type 'a field = 'a Dyn.tag + + let next = ref 0 + let field () = + let f = Dyn.anonymous !next in + incr next; + f + + let empty = + Map.empty + let set s f v = + Map.add f v s + let get s f = + try Some (Map.find f s) + with Not_found -> None + let remove s f = + Map.remove f s + let merge s1 s2 = + Map.fold (fun (Map.Any (f, v)) s -> Map.add f v s) s1 s2 end diff --git a/clib/store.mli b/clib/store.mli index 0c2b2e0856..7cdd1d3bed 100644 --- a/clib/store.mli +++ b/clib/store.mli @@ -19,6 +19,9 @@ sig type 'a field (** Type of field of such stores *) + val field : unit -> 'a field + (** Create a new field *) + val empty : t (** Empty store *) @@ -33,11 +36,7 @@ sig val merge : t -> t -> t (** [merge s1 s2] adds all the fields of [s1] into [s2]. *) - - val field : unit -> 'a field - (** Create a new field *) - end -module Make () : S +module Make() : S (** Create a new store type. *) diff --git a/coqpp/coqpp_main.ml b/coqpp/coqpp_main.ml index ba3b9bcbbf..8da4c6db13 100644 --- a/coqpp/coqpp_main.ml +++ b/coqpp/coqpp_main.ml @@ -374,9 +374,9 @@ let print_rules fmt rules = let print_classifier fmt = function | ClassifDefault -> fprintf fmt "" | ClassifName "QUERY" -> - fprintf fmt "~classifier:(fun _ -> Vernac_classifier.classify_as_query)" + fprintf fmt "~classifier:(fun _ -> Vernacextend.classify_as_query)" | ClassifName "SIDEFF" -> - fprintf fmt "~classifier:(fun _ -> Vernac_classifier.classify_as_sideeff)" + fprintf fmt "~classifier:(fun _ -> Vernacextend.classify_as_sideeff)" | ClassifName s -> fatal (Printf.sprintf "Unknown classifier %s" s) | ClassifCode c -> fprintf fmt "~classifier:(%s)" c.code diff --git a/dev/build/windows/makecoq_mingw.sh b/dev/build/windows/makecoq_mingw.sh index 71207bb040..0dcabc0b97 100755 --- a/dev/build/windows/makecoq_mingw.sh +++ b/dev/build/windows/makecoq_mingw.sh @@ -1645,7 +1645,7 @@ function make_addon_bignums { function make_addon_equations { installer_addon_dependency equations - if build_prep_overlay Equations; then + if build_prep_overlay equations; then installer_addon_section equations "Equations" "Coq plugin for defining functions by equations" "" # Note: PATH is automatically saved/restored by build_prep / build_post PATH=$COQBIN:$PATH diff --git a/dev/ci/README.md b/dev/ci/README.md index 4709247549..7ed90f524c 100644 --- a/dev/ci/README.md +++ b/dev/ci/README.md @@ -179,7 +179,7 @@ Currently available artifacts are: + Coq's Reference Manual [master branch] https://gitlab.com/coq/coq/-/jobs/artifacts/master/file/_install_ci/share/doc/coq/sphinx/html/index.html?job=doc:refman + Coq's Standard Library Documentation [master branch] - https://gitlab.com/coq/coq/-/jobs/artifacts/master/file/_install_ci/share/doc/coq/html/stdlib/index.html?job=doc:refman + https://gitlab.com/coq/coq/-/jobs/artifacts/master/file/_install_ci/share/doc/coq/html/stdlib/index.html?job=build:base + Coq's ML API Documentation [master branch] https://gitlab.com/coq/coq/-/jobs/artifacts/master/file/_build/default/_doc/_html/index.html?job=doc:ml-api:odoc diff --git a/dev/ci/ci-aac-tactics.sh b/dev/ci/ci-aac-tactics.sh deleted file mode 100755 index 896a0ddf66..0000000000 --- a/dev/ci/ci-aac-tactics.sh +++ /dev/null @@ -1,8 +0,0 @@ -#!/usr/bin/env bash - -ci_dir="$(dirname "$0")" -. "${ci_dir}/ci-common.sh" - -git_download aactactics - -( cd "${CI_BUILD_DIR}/aactactics" && make && make install ) diff --git a/dev/ci/ci-aac_tactics.sh b/dev/ci/ci-aac_tactics.sh new file mode 100755 index 0000000000..19f1f43746 --- /dev/null +++ b/dev/ci/ci-aac_tactics.sh @@ -0,0 +1,8 @@ +#!/usr/bin/env bash + +ci_dir="$(dirname "$0")" +. "${ci_dir}/ci-common.sh" + +git_download aac_tactics + +( cd "${CI_BUILD_DIR}/aac_tactics" && make && make install ) diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index 3137576207..4d5834eeb6 100755 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -113,16 +113,16 @@ ######################################################################## # CompCert ######################################################################## -: "${CompCert_CI_REF:=master}" -: "${CompCert_CI_GITURL:=https://github.com/AbsInt/CompCert}" -: "${CompCert_CI_ARCHIVEURL:=${CompCert_CI_GITURL}/archive}" +: "${compcert_CI_REF:=master}" +: "${compcert_CI_GITURL:=https://github.com/AbsInt/CompCert}" +: "${compcert_CI_ARCHIVEURL:=${compcert_CI_GITURL}/archive}" ######################################################################## # VST ######################################################################## -: "${VST_CI_REF:=master}" -: "${VST_CI_GITURL:=https://github.com/PrincetonUniversity/VST}" -: "${VST_CI_ARCHIVEURL:=${VST_CI_GITURL}/archive}" +: "${vst_CI_REF:=master}" +: "${vst_CI_GITURL:=https://github.com/PrincetonUniversity/VST}" +: "${vst_CI_ARCHIVEURL:=${vst_CI_GITURL}/archive}" ######################################################################## # cross-crypto @@ -153,7 +153,7 @@ : "${formal_topology_CI_ARCHIVEURL:=${formal_topology_CI_GITURL}/archive}" ######################################################################## -# coq-dpdgraph +# coq_dpdgraph ######################################################################## : "${coq_dpdgraph_CI_REF:=coq-master}" : "${coq_dpdgraph_CI_GITURL:=https://github.com/Karmaki/coq-dpdgraph}" @@ -162,9 +162,9 @@ ######################################################################## # CoLoR ######################################################################## -: "${CoLoR_CI_REF:=master}" -: "${CoLoR_CI_GITURL:=https://github.com/fblanqui/color}" -: "${CoLoR_CI_ARCHIVEURL:=${CoLoR_CI_GITURL}/archive}" +: "${color_CI_REF:=master}" +: "${color_CI_GITURL:=https://github.com/fblanqui/color}" +: "${color_CI_ARCHIVEURL:=${color_CI_GITURL}/archive}" ######################################################################## # SF @@ -196,16 +196,16 @@ ######################################################################## # Equations ######################################################################## -: "${Equations_CI_REF:=master}" -: "${Equations_CI_GITURL:=https://github.com/mattam82/Coq-Equations}" -: "${Equations_CI_ARCHIVEURL:=${Equations_CI_GITURL}/archive}" +: "${equations_CI_REF:=master}" +: "${equations_CI_GITURL:=https://github.com/mattam82/Coq-Equations}" +: "${equations_CI_ARCHIVEURL:=${equations_CI_GITURL}/archive}" ######################################################################## # Elpi ######################################################################## -: "${Elpi_CI_REF:=coq-master}" -: "${Elpi_CI_GITURL:=https://github.com/LPCIC/coq-elpi}" -: "${Elpi_CI_ARCHIVEURL:=${Elpi_CI_GITURL}/archive}" +: "${elpi_CI_REF:=coq-master}" +: "${elpi_CI_GITURL:=https://github.com/LPCIC/coq-elpi}" +: "${elpi_CI_ARCHIVEURL:=${elpi_CI_GITURL}/archive}" ######################################################################## # fcsl-pcm @@ -257,11 +257,11 @@ : "${menhirlib_CI_ARCHIVEURL:=${menhirlib_CI_GITURL}/-/archive}" ######################################################################## -# aac-tactics +# aac_tactics ######################################################################## -: "${aactactics_CI_REF:=master}" -: "${aactactics_CI_GITURL:=https://github.com/coq-community/aac-tactics}" -: "${aactactics_CI_ARCHIVEURL:=${aactactics_CI_GITURL}/archive}" +: "${aac_tactics_CI_REF:=master}" +: "${aac_tactics_CI_GITURL:=https://github.com/coq-community/aac-tactics}" +: "${aac_tactics_CI_ARCHIVEURL:=${aac_tactics_CI_GITURL}/archive}" ######################################################################## # paramcoq diff --git a/dev/ci/ci-color.sh b/dev/ci/ci-color.sh index dc696f69d9..a0094b1006 100755 --- a/dev/ci/ci-color.sh +++ b/dev/ci/ci-color.sh @@ -3,6 +3,6 @@ ci_dir="$(dirname "$0")" . "${ci_dir}/ci-common.sh" -git_download CoLoR +git_download color -( cd "${CI_BUILD_DIR}/CoLoR" && make ) +( cd "${CI_BUILD_DIR}/color" && make ) diff --git a/dev/ci/ci-common.sh b/dev/ci/ci-common.sh index 7a450d0d48..a5aa54144c 100644 --- a/dev/ci/ci-common.sh +++ b/dev/ci/ci-common.sh @@ -46,8 +46,11 @@ for overlay in "${ci_dir}"/user-overlays/*.sh; do # shellcheck source=/dev/null . "${overlay}" done + +set +x # shellcheck source=ci-basic-overlay.sh . "${ci_dir}/ci-basic-overlay.sh" +set -x # [git_download project] will download [project] and unpack it # in [$CI_BUILD_DIR/project] if the folder does not exist already; diff --git a/dev/ci/ci-compcert.sh b/dev/ci/ci-compcert.sh index 01c35ceb4a..59a85e4726 100755 --- a/dev/ci/ci-compcert.sh +++ b/dev/ci/ci-compcert.sh @@ -3,7 +3,7 @@ ci_dir="$(dirname "$0")" . "${ci_dir}/ci-common.sh" -git_download CompCert +git_download compcert -( cd "${CI_BUILD_DIR}/CompCert" && \ +( cd "${CI_BUILD_DIR}/compcert" && \ ./configure -ignore-coq-version x86_32-linux && make && make check-proof ) diff --git a/dev/ci/ci-coq-dpdgraph.sh b/dev/ci/ci-coq_dpdgraph.sh index 2373ea6c62..2373ea6c62 100755 --- a/dev/ci/ci-coq-dpdgraph.sh +++ b/dev/ci/ci-coq_dpdgraph.sh diff --git a/dev/ci/ci-elpi.sh b/dev/ci/ci-elpi.sh index 9b4a06fd5b..d60bf34ba2 100755 --- a/dev/ci/ci-elpi.sh +++ b/dev/ci/ci-elpi.sh @@ -3,6 +3,6 @@ ci_dir="$(dirname "$0")" . "${ci_dir}/ci-common.sh" -git_download Elpi +git_download elpi -( cd "${CI_BUILD_DIR}/Elpi" && make && make install ) +( cd "${CI_BUILD_DIR}/elpi" && make && make install ) diff --git a/dev/ci/ci-equations.sh b/dev/ci/ci-equations.sh index 998d50faa7..b58a794da2 100755 --- a/dev/ci/ci-equations.sh +++ b/dev/ci/ci-equations.sh @@ -3,7 +3,7 @@ ci_dir="$(dirname "$0")" . "${ci_dir}/ci-common.sh" -git_download Equations +git_download equations -( cd "${CI_BUILD_DIR}/Equations" && coq_makefile -f _CoqProject -o Makefile && \ +( cd "${CI_BUILD_DIR}/equations" && coq_makefile -f _CoqProject -o Makefile && \ make && make test-suite && make examples && make install) diff --git a/dev/ci/ci-plugin-tutorial.sh b/dev/ci/ci-plugin_tutorial.sh index 6c26a71a21..6c26a71a21 100755 --- a/dev/ci/ci-plugin-tutorial.sh +++ b/dev/ci/ci-plugin_tutorial.sh diff --git a/dev/ci/ci-vst.sh b/dev/ci/ci-vst.sh index 0fec19205a..169d1a41db 100755 --- a/dev/ci/ci-vst.sh +++ b/dev/ci/ci-vst.sh @@ -3,6 +3,6 @@ ci_dir="$(dirname "$0")" . "${ci_dir}/ci-common.sh" -git_download VST +git_download vst -( cd "${CI_BUILD_DIR}/VST" && make IGNORECOQVERSION=true ) +( cd "${CI_BUILD_DIR}/vst" && make IGNORECOQVERSION=true ) diff --git a/dev/ci/user-overlays/00669-maximedenes-ssr-merge.sh b/dev/ci/user-overlays/00669-maximedenes-ssr-merge.sh deleted file mode 100644 index d812df3ec0..0000000000 --- a/dev/ci/user-overlays/00669-maximedenes-ssr-merge.sh +++ /dev/null @@ -1,6 +0,0 @@ -#!/bin/sh - -if [ "$CI_PULL_REQUEST" = "669" ] || [ "$CI_BRANCH" = "ssr-merge" ]; then - mathcomp_CI_REF=ssr-merge - mathcomp_CI_GITURL=https://github.com/maximedenes/math-comp -fi diff --git a/dev/ci/user-overlays/07085-ppedrot-pure-sharing-flag.sh b/dev/ci/user-overlays/07085-ppedrot-pure-sharing-flag.sh deleted file mode 100644 index 575df07425..0000000000 --- a/dev/ci/user-overlays/07085-ppedrot-pure-sharing-flag.sh +++ /dev/null @@ -1,8 +0,0 @@ -_OVERLAY_BRANCH=pure-sharing-flag - -if [ "$CI_PULL_REQUEST" = "7085" ] || [ "$CI_BRANCH" = "$_OVERLAY_BRANCH" ]; then - - mtac2_CI_BRANCH="$_OVERLAY_BRANCH" - mtac2_CI_GITURL=https://github.com/ppedrot/Mtac2 - -fi diff --git a/dev/ci/user-overlays/07257-herbelin-master+fix-yet-another-unif-dep-in-alphabet.sh b/dev/ci/user-overlays/07257-herbelin-master+fix-yet-another-unif-dep-in-alphabet.sh deleted file mode 100644 index 019cb8054d..0000000000 --- a/dev/ci/user-overlays/07257-herbelin-master+fix-yet-another-unif-dep-in-alphabet.sh +++ /dev/null @@ -1,4 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "7257" ] || [ "$CI_BRANCH" = "master+fix-yet-another-unif-dep-in-alphabet" ]; then - cross_crypto_CI_REF=master+fix-coq7257-ascii-sensitive-unification - cross_crypto_CI_GITURL=https://github.com/herbelin/cross-crypto -fi diff --git a/dev/ci/user-overlays/07288-herbelin-master+new-module-pretyping-id-management.sh b/dev/ci/user-overlays/07288-herbelin-master+new-module-pretyping-id-management.sh deleted file mode 100644 index 3a6480a5a1..0000000000 --- a/dev/ci/user-overlays/07288-herbelin-master+new-module-pretyping-id-management.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "7288" ] || [ "$CI_BRANCH" = "master+new-module-pretyping-id-management" ]; then - - ltac2_CI_BRANCH=master+globenv-coq-pr7288 - ltac2_CI_GITURL=https://github.com/herbelin/ltac2 - -fi diff --git a/dev/ci/user-overlays/07925-ppedrot-clean-transp-state.sh b/dev/ci/user-overlays/07925-ppedrot-clean-transp-state.sh new file mode 100644 index 0000000000..b05d02c5be --- /dev/null +++ b/dev/ci/user-overlays/07925-ppedrot-clean-transp-state.sh @@ -0,0 +1,14 @@ +_OVERLAY_BRANCH=clean-transp-state + +if [ "$CI_PULL_REQUEST" = "7925" ] || [ "$CI_BRANCH" = "$_OVERLAY_BRANCH" ]; then + + unicoq_CI_REF="$_OVERLAY_BRANCH" + unicoq_CI_GITURL=https://github.com/ppedrot/unicoq + + equations_CI_REF="$_OVERLAY_BRANCH" + equations_CI_GITURL=https://github.com/ppedrot/Coq-Equations + + mtac2_CI_REF="$_OVERLAY_BRANCH" + mtac2_CI_GITURL=https://github.com/ppedrot/Mtac2 + +fi diff --git a/dev/ci/user-overlays/08456-fix-6764.sh b/dev/ci/user-overlays/08456-fix-6764.sh deleted file mode 100644 index 3b951d9c07..0000000000 --- a/dev/ci/user-overlays/08456-fix-6764.sh +++ /dev/null @@ -1,5 +0,0 @@ -#!/bin/sh - -if [ "$CI_PULL_REQUEST" = "8456" ] || [ "$CI_BRANCH" = "fix-6764" ]; then - Elpi_CI_REF=overlay/8456 -fi diff --git a/dev/ci/user-overlays/08515-command-atts.sh b/dev/ci/user-overlays/08515-command-atts.sh deleted file mode 100755 index 4605255d5e..0000000000 --- a/dev/ci/user-overlays/08515-command-atts.sh +++ /dev/null @@ -1,12 +0,0 @@ -#!/bin/sh - -if [ "$CI_PULL_REQUEST" = "8515" ] || [ "$CI_BRANCH" = "command-atts" ]; then - ltac2_CI_REF=command-atts - ltac2_CI_GITURL=https://github.com/SkySkimmer/ltac2 - - Equations_CI_REF=command-atts - Equations_CI_GITURL=https://github.com/SkySkimmer/Coq-Equations - - plugin_tutorial_CI_REF=command-atts - plugin_tutorial_CI_GITURL=https://github.com/SkySkimmer/plugin_tutorials -fi diff --git a/dev/ci/user-overlays/08552-gares-elpi-11.sh b/dev/ci/user-overlays/08552-gares-elpi-11.sh deleted file mode 100644 index c08f44fc50..0000000000 --- a/dev/ci/user-overlays/08552-gares-elpi-11.sh +++ /dev/null @@ -1,5 +0,0 @@ -#!/bin/sh - -if [ "$CI_PULL_REQUEST" = "8552" ] || [ "$CI_BRANCH" = "elpi-1.1" ]; then - Elpi_CI_REF=coq-master-elpi-1.1 -fi diff --git a/dev/ci/user-overlays/08554-herbelin-master+fix8553-change-under-binders.sh b/dev/ci/user-overlays/08554-herbelin-master+fix8553-change-under-binders.sh deleted file mode 100644 index 484ad8f9e6..0000000000 --- a/dev/ci/user-overlays/08554-herbelin-master+fix8553-change-under-binders.sh +++ /dev/null @@ -1,11 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "8554" ] || [ "$CI_BRANCH" = "master+fix8553-change-under-binders" ]; then - - ltac2_CI_BRANCH=master+fix-pr8554-change-takes-env - ltac2_CI_REF=master+fix-pr8554-change-takes-env - ltac2_CI_GITURL=https://github.com/herbelin/ltac2 - - Equations_CI_BRANCH=master+fix-pr8554-change-takes-env - Equations_CI_REF=master+fix-pr8554-change-takes-env - Equations_CI_GITURL=https://github.com/herbelin/Coq-Equations - -fi diff --git a/dev/ci/user-overlays/08555-maximedenes-rm-section-path.sh b/dev/ci/user-overlays/08555-maximedenes-rm-section-path.sh deleted file mode 100644 index 41c2ad6fef..0000000000 --- a/dev/ci/user-overlays/08555-maximedenes-rm-section-path.sh +++ /dev/null @@ -1,9 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "8555" ] || [ "$CI_BRANCH" = "rm-section-path" ]; then - - ltac2_CI_REF=rm-section-path - ltac2_CI_GITURL=https://github.com/maximedenes/ltac2 - - Equations_CI_REF=rm-section-path - Equations_CI_GITURL=https://github.com/maximedenes/Coq-Equations - -fi diff --git a/dev/ci/user-overlays/08601-name-abstract-univ-context.sh b/dev/ci/user-overlays/08601-name-abstract-univ-context.sh deleted file mode 100644 index 9d723dc7f2..0000000000 --- a/dev/ci/user-overlays/08601-name-abstract-univ-context.sh +++ /dev/null @@ -1,11 +0,0 @@ -_OVERLAY_BRANCH=name-abstract-univ-context - -if [ "$CI_PULL_REQUEST" = "8601" ] || [ "$CI_BRANCH" = "$_OVERLAY_BRANCH" ]; then - - Elpi_CI_REF="$_OVERLAY_BRANCH" - Elpi_CI_GITURL=https://github.com/ppedrot/coq-elpi - - Equations_CI_REF="$_OVERLAY_BRANCH" - Equations_CI_GITURL=https://github.com/ppedrot/Coq-Equations - -fi diff --git a/dev/ci/user-overlays/08671-mattam-plugin-tutorials.sh b/dev/ci/user-overlays/08671-mattam-plugin-tutorials.sh deleted file mode 100644 index bd3e1bf7ff..0000000000 --- a/dev/ci/user-overlays/08671-mattam-plugin-tutorials.sh +++ /dev/null @@ -1,7 +0,0 @@ -#!/bin/sh - -if [ "$CI_PULL_REQUEST" = "8741" ] || [ "$CI_BRANCH" = "typeclasses-functional-evar_map" ]; then - plugin_tutorial_CI_REF=pr8671-fix - plugin_tutorial_CI_GITURL=https://github.com/mattam82/plugin_tutorials - -fi diff --git a/dev/ci/user-overlays/08684-maximedenes-cleanup-kernel-entries.sh b/dev/ci/user-overlays/08684-maximedenes-cleanup-kernel-entries.sh deleted file mode 100644 index 98530c825a..0000000000 --- a/dev/ci/user-overlays/08684-maximedenes-cleanup-kernel-entries.sh +++ /dev/null @@ -1,9 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "8684" ] || [ "$CI_BRANCH" = "kernel-entries-cleanup" ]; then - - Elpi_CI_REF=kernel-entries-cleanup - Elpi_CI_GITURL=https://github.com/maximedenes/coq-elpi - - Equations_CI_REF=kernel-entries-cleanup - Equations_CI_GITURL=https://github.com/maximedenes/Coq-Equations - -fi diff --git a/dev/ci/user-overlays/08688-herbelin-master+generalizing-evar-map-printer-over-env.sh b/dev/ci/user-overlays/08688-herbelin-master+generalizing-evar-map-printer-over-env.sh deleted file mode 100644 index 81ed91f52b..0000000000 --- a/dev/ci/user-overlays/08688-herbelin-master+generalizing-evar-map-printer-over-env.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "8688" ] || [ "$CI_BRANCH" = "master+generalizing-evar-map-printer-over-env" ]; then - - Elpi_CI_REF=master+generalized-evar-printers-pr8688 - Elpi_CI_GITURL=https://github.com/herbelin/coq-elpi - -fi diff --git a/dev/ci/user-overlays/08704-ejgallego-vernac+monify_hook.sh b/dev/ci/user-overlays/08704-ejgallego-vernac+monify_hook.sh deleted file mode 100644 index b3a9f67e00..0000000000 --- a/dev/ci/user-overlays/08704-ejgallego-vernac+monify_hook.sh +++ /dev/null @@ -1,15 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "8704" ] || [ "$CI_BRANCH" = "vernac+monify_hook" ]; then - - # ltac2_CI_REF=rm-section-path - # ltac2_CI_GITURL=https://github.com/maximedenes/ltac2 - - plugin_tutorial_CI_REF=vernac+monify_hook - plugin_tutorial_CI_GITURL=https://github.com/ejgallego/plugin_tutorials - - Elpi_CI_REF=vernac+monify_hook - Elpi_CI_GITURL=https://github.com/ejgallego/coq-elpi - - Equations_CI_REF=vernac+monify_hook - Equations_CI_GITURL=https://github.com/ejgallego/Coq-Equations - -fi diff --git a/dev/ci/user-overlays/08844-split-tactics.sh b/dev/ci/user-overlays/08844-split-tactics.sh deleted file mode 100644 index 8ad8cba243..0000000000 --- a/dev/ci/user-overlays/08844-split-tactics.sh +++ /dev/null @@ -1,12 +0,0 @@ -#!/bin/sh - -if [ "$CI_PULL_REQUEST" = "8844" ] || [ "$CI_BRANCH" = "split-tactics" ]; then - Equations_CI_REF=split-tactics - Equations_CI_GITURL=https://github.com/SkySkimmer/Coq-Equations - - ltac2_CI_REF=split-tactics - ltac2_CI_GITURL=https://github.com/SkySkimmer/ltac2 - - fiat_parsers_CI_REF=split-tactics - fiat_parsers_CI_GITURL=https://github.com/SkySkimmer/fiat -fi diff --git a/dev/ci/user-overlays/08902-ejgallego-ltac+use_atts_in_ast.sh b/dev/ci/user-overlays/08902-ejgallego-ltac+use_atts_in_ast.sh new file mode 100644 index 0000000000..08112d3054 --- /dev/null +++ b/dev/ci/user-overlays/08902-ejgallego-ltac+use_atts_in_ast.sh @@ -0,0 +1,15 @@ +if [ "$CI_PULL_REQUEST" = "8902" ] || [ "$CI_BRANCH" = "ltac+use_atts_in_ast" ]; then + + aactactics_CI_REF=ltac+use_atts_in_ast + aactactics_CI_GITURL=https://github.com/ejgallego/aac-tactics + + coqhammer_CI_REF=ltac+use_atts_in_ast + coqhammer_CI_GITURL=https://github.com/ejgallego/coqhammer + + Equations_CI_REF=ltac+use_atts_in_ast + Equations_CI_GITURL=https://github.com/ejgallego/Coq-Equations + + mtac2_CI_REF=ltac+use_atts_in_ast + mtac2_CI_GITURL=https://github.com/ejgallego/Coq-Equations + +fi diff --git a/dev/ci/user-overlays/08914-ejgallego-lib+better_boot_coqproject.sh b/dev/ci/user-overlays/08914-ejgallego-lib+better_boot_coqproject.sh new file mode 100644 index 0000000000..1c5157ba12 --- /dev/null +++ b/dev/ci/user-overlays/08914-ejgallego-lib+better_boot_coqproject.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "8914" ] || [ "$CI_BRANCH" = "lib+better_boot_coqproject" ]; then + + quickchick_CI_REF=lib+better_boot_coqproject + quickchick_CI_GITURL=https://github.com/ejgallego/QuickChick + +fi diff --git a/dev/ci/user-overlays/09003-ejgallego-vernac+move_extend_ast.sh b/dev/ci/user-overlays/09003-ejgallego-vernac+move_extend_ast.sh new file mode 100644 index 0000000000..61ffa4a197 --- /dev/null +++ b/dev/ci/user-overlays/09003-ejgallego-vernac+move_extend_ast.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "9003" ] || [ "$CI_BRANCH" = "vernac+move_extend_ast" ]; then + + ltac2_CI_REF=vernac+move_extend_ast + ltac2_CI_GITURL=https://github.com/ejgallego/ltac2 + +fi diff --git a/dev/ci/user-overlays/jasongross-numeral-notation-4.sh b/dev/ci/user-overlays/jasongross-numeral-notation-4.sh deleted file mode 100644 index 76aa37d380..0000000000 --- a/dev/ci/user-overlays/jasongross-numeral-notation-4.sh +++ /dev/null @@ -1,5 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "8064" ] || [ "$CI_BRANCH" = "numeral-notation-4" ]; then - HoTT_CI_REF=fix-for-numeral-notations - HoTT_CI_GITURL=https://github.com/JasonGross/HoTT - HoTT_CI_ARCHIVEURL=${HoTT_CI_GITURL}/archive -fi diff --git a/dev/doc/changes.md b/dev/doc/changes.md index b1fdfafd3a..30a2967259 100644 --- a/dev/doc/changes.md +++ b/dev/doc/changes.md @@ -19,6 +19,10 @@ Names Constant.make3 has been removed, use Constant.make2 Constant.repr3 has been removed, use Constant.repr2 +- `Names.transparent_state` has been moved to its own module `TransparentState`. + This module gathers utility functions that used to be defined in several + places. + Coqlib: - Most functions from the `Coqlib` module have been deprecated in favor of diff --git a/dev/tools/create_overlays.sh b/dev/tools/create_overlays.sh new file mode 100755 index 0000000000..314ac07e68 --- /dev/null +++ b/dev/tools/create_overlays.sh @@ -0,0 +1,78 @@ +#!/usr/bin/env bash + +# TODO: +# +# - Check if the branch already exists in the remote => checkout +# - Better error handling +# - Just checkout, don't build +# - Rebase functionality +# + +set -x +set -e +set -o pipefail + +# setup_contrib_git("_build_ci/fiat", "https://github.com/ejgallego/fiat-core.git") +setup_contrib_git() { + + local _DIR=$1 + local _GITURL=$2 + + ( cd $_DIR + git checkout -b $OVERLAY_BRANCH || true # allow the branch to exist already + git remote add $DEVELOPER_NAME $_GITURL || true # allow the remote to exist already + ) + +} + +if [ $# -lt 3 ]; then + echo "usage: $0 github_username pr_number contrib1 ... contribN" + exit 1 +fi + +set +x +. dev/ci/ci-basic-overlay.sh +set -x + +DEVELOPER_NAME=$1 +shift +PR_NUMBER=$1 +shift +OVERLAY_BRANCH=$(git rev-parse --abbrev-ref HEAD) +OVERLAY_FILE=$(mktemp overlay-XXXX) + +# Create the overlay file +printf 'if [ "$CI_PULL_REQUEST" = "%s" ] || [ "$CI_BRANCH" = "%s" ]; then \n\n' "$PR_NUMBER" "$OVERLAY_BRANCH" > "$OVERLAY_FILE" + +# We first try to build the contribs +while test $# -gt 0 +do + _CONTRIB_NAME=$1 + _CONTRIB_GITURL=${_CONTRIB_NAME}_CI_GITURL + _CONTRIB_GITURL=${!_CONTRIB_GITURL} + echo "Processing Contrib $_CONTRIB_NAME" + + # check _CONTRIB_GIT exists and it is of the from github... + + _CONTRIB_DIR=_build_ci/$_CONTRIB_NAME + + # extract the relevant part of the repository + _CONTRIB_GITSUFFIX=${_CONTRIB_GITURL#https://github.com/*/} + _CONTRIB_GITURL="https://github.com/$DEVELOPER_NAME/$_CONTRIB_GITSUFFIX" + _CONTRIB_GITPUSHURL="git@github.com:$DEVELOPER_NAME/${_CONTRIB_GITSUFFIX}.git" + + # This should work better: for example we should be able not to + # build but just to checkout. + make ci-$_CONTRIB_NAME || true + setup_contrib_git $_CONTRIB_DIR $_CONTRIB_GITPUSHURL + + echo " ${_CONTRIB_NAME}_CI_REF=$OVERLAY_BRANCH" >> $OVERLAY_FILE + echo " ${_CONTRIB_NAME}_CI_GITURL=$_CONTRIB_GITURL" >> $OVERLAY_FILE + echo "" >> $OVERLAY_FILE + shift +done + +# End the file; copy to overlays folder. +echo "fi" >> $OVERLAY_FILE +PR_NUMBER=$(printf '%05d' "$PR_NUMBER") +mv $OVERLAY_FILE dev/ci/user-overlays/$PR_NUMBER-$DEVELOPER_NAME-$OVERLAY_BRANCH.sh diff --git a/dev/top_printers.ml b/dev/top_printers.ml index f94e9acb72..4287702b3a 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -514,18 +514,18 @@ let _ = let ty_constr = Extend.TUentry (get_arg_tag Stdarg.wit_constr) in let cmd_sig = TyTerminal("PrintConstr", TyNonTerminal(ty_constr, TyNil)) in let cmd_fn c ~atts ~st = in_current_context econstr_display c; st in - let cmd_class _ = Vernacexpr.(VtQuery,VtNow) in + let cmd_class _ = VtQuery,VtNow in let cmd : ty_ml = TyML (false, cmd_sig, cmd_fn, Some cmd_class) in - Vernacextend.vernac_extend ~command:"PrintConstr" [cmd] + vernac_extend ~command:"PrintConstr" [cmd] let _ = let open Vernacextend in let ty_constr = Extend.TUentry (get_arg_tag Stdarg.wit_constr) in let cmd_sig = TyTerminal("PrintPureConstr", TyNonTerminal(ty_constr, TyNil)) in let cmd_fn c ~atts ~st = in_current_context print_pure_econstr c; st in - let cmd_class _ = Vernacexpr.(VtQuery,VtNow) in + let cmd_class _ = VtQuery,VtNow in let cmd : ty_ml = TyML (false, cmd_sig, cmd_fn, Some cmd_class) in - Vernacextend.vernac_extend ~command:"PrintPureConstr" [cmd] + vernac_extend ~command:"PrintPureConstr" [cmd] (* Setting printer of unbound global reference *) open Names diff --git a/dev/top_printers.mli b/dev/top_printers.mli index 63d7d58053..eaa12ff702 100644 --- a/dev/top_printers.mli +++ b/dev/top_printers.mli @@ -101,7 +101,7 @@ val ppdelta : Mod_subst.delta_resolver -> unit val pp_idpred : Names.Id.Pred.t -> unit val pp_cpred : Names.Cpred.t -> unit -val pp_transparent_state : Names.transparent_state -> unit +val pp_transparent_state : TransparentState.t -> unit val pp_stack_t : Constr.t Reductionops.Stack.t -> unit val pp_cst_stack_t : Reductionops.Cst_stack.t -> unit diff --git a/doc/sphinx/language/gallina-extensions.rst b/doc/sphinx/language/gallina-extensions.rst index 9dae7fd102..391afcb1f7 100644 --- a/doc/sphinx/language/gallina-extensions.rst +++ b/doc/sphinx/language/gallina-extensions.rst @@ -2155,6 +2155,12 @@ If `string` ends in ``.dot`` or ``.gv``, the constraints are printed in the DOT language, and can be processed by Graphviz tools. The format is unspecified if `string` doesn’t end in ``.dot`` or ``.gv``. +.. cmdv:: Print Universes Subgraph(@names) + +Prints the graph restricted to the requested names (adjusting +constraints to preserve the implied transitive constraints between +kept universes). + .. _existential-variables: Existential variables @@ -2247,7 +2253,3 @@ expression as described in :ref:`ltac`. This construction is useful when one wants to define complicated terms using highly automated tactics without resorting to writing the proof-term by means of the interactive proof engine. - -This mechanism is comparable to the ``Declare Implicit Tactic`` command -defined at :ref:`tactics-implicit-automation`, except that the used -tactic is local to each hole instead of being declared globally. diff --git a/doc/sphinx/proof-engine/proof-handling.rst b/doc/sphinx/proof-engine/proof-handling.rst index 741f9fe5b0..0b059f92ee 100644 --- a/doc/sphinx/proof-engine/proof-handling.rst +++ b/doc/sphinx/proof-engine/proof-handling.rst @@ -758,18 +758,6 @@ Controlling the effect of proof editing commands available hypotheses. -.. flag:: Automatic Introduction - - This option controls the way binders are handled - in assertion commands such as :n:`Theorem @ident {? @binders} : @term`. When the - option is on, which is the default, binders are automatically put in - the local context of the goal to prove. - - When the option is off, binders are discharged on the statement to be - proved and a tactic such as :tacn:`intro` (see Section :ref:`managingthelocalcontext`) - has to be used to move the assumptions to the local context. - - .. flag:: Nested Proofs Allowed When turned on (it is off by default), this option enables support for nested diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index 457f9b2efa..041f1bc966 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -3745,32 +3745,6 @@ Setting implicit automation tactics Combines in a single line ``Proof with`` and ``Proof using``, see :ref:`proof-editing-mode` - .. cmd:: Declare Implicit Tactic @tactic - - This command declares a tactic to be used to solve implicit arguments - that Coq does not know how to solve by unification. It is used every - time the term argument of a tactic has one of its holes not fully - resolved. - - .. deprecated:: 8.9 - - This command is deprecated. Use :ref:`typeclasses <typeclasses>` or - :ref:`tactics-in-terms <tactics-in-terms>` instead. - - .. example:: - - .. coqtop:: all - - Parameter quo : nat -> forall n:nat, n<>0 -> nat. - Notation "x // y" := (quo x y _) (at level 40). - Declare Implicit Tactic assumption. - Goal forall n m, m<>0 -> { q:nat & { r | q * m + r = n } }. - intros. - exists (n // m). - - The tactic ``exists (n // m)`` did not fail. The hole was solved - by ``assumption`` so that it behaved as ``exists (quo n m H)``. - .. _decisionprocedures: Decision procedures diff --git a/doc/sphinx/user-extensions/proof-schemes.rst b/doc/sphinx/user-extensions/proof-schemes.rst index eacd7b4676..8f76085d88 100644 --- a/doc/sphinx/user-extensions/proof-schemes.rst +++ b/doc/sphinx/user-extensions/proof-schemes.rst @@ -167,7 +167,7 @@ Combined Scheme Combined Scheme tree_forest_mutind from tree_forest_ind,forest_tree_ind. - The type of tree_forest_mutrec will be: + The type of tree_forest_mutind will be: .. coqtop:: all diff --git a/engine/univNames.ml b/engine/univNames.ml index ad91d31f87..1019f8f0c2 100644 --- a/engine/univNames.ml +++ b/engine/univNames.ml @@ -36,10 +36,6 @@ type universe_binders = Univ.Level.t Names.Id.Map.t let empty_binders = Id.Map.empty -let universe_binders_of_global ref : Name.t array = - try AUContext.names (Environ.universes_of_global (Global.env ()) ref) - with Not_found -> [||] - let name_universe lvl = (** Best-effort naming from the string representation of the level. This is completely hackish and should be solved in upper layers instead. *) @@ -55,8 +51,8 @@ let compute_instance_binders inst ubinders = type univ_name_list = Names.lname list -let universe_binders_with_opt_names ref names = - let orig = universe_binders_of_global ref in +let universe_binders_with_opt_names orig names = + let orig = AUContext.names orig in let orig = Array.to_list orig in let udecl = match names with | None -> orig diff --git a/engine/univNames.mli b/engine/univNames.mli index dc669f45d6..6e68153ac2 100644 --- a/engine/univNames.mli +++ b/engine/univNames.mli @@ -29,5 +29,5 @@ type univ_name_list = Names.lname list of [ref] by [univs] (skipping Anonymous). May error if the lengths mismatch. Otherwise return the bound universe names registered for [ref]. *) -val universe_binders_with_opt_names : Names.GlobRef.t -> +val universe_binders_with_opt_names : AUContext.t -> univ_name_list option -> universe_binders diff --git a/gramlib/grammar.ml b/gramlib/grammar.ml index 760410894a..1ce0136c1d 100644 --- a/gramlib/grammar.ml +++ b/gramlib/grammar.ml @@ -862,7 +862,6 @@ module type S = val parse_token_stream : 'a e -> te Stream.t -> 'a val print : Format.formatter -> 'a e -> unit external obj : 'a e -> te Gramext.g_entry = "%identity" - val parse_token : 'a e -> te Stream.t -> 'a end type ('self, 'a) ty_symbol type ('self, 'f, 'r) ty_rule @@ -930,18 +929,6 @@ module GMake (L : GLexerType) = Obj.magic (parse_parsable e p : Obj.t) let parse_token_stream (e : 'a e) ts : 'a = Obj.magic (e.estart 0 ts : Obj.t) - let _warned_using_parse_token = ref false - let parse_token (entry : 'a e) ts : 'a = - (* commented: too often warned in Coq... - if not warned_using_parse_token.val then do { - eprintf "<W> use of Entry.parse_token "; - eprintf "deprecated since 2017-06-16\n%!"; - eprintf "use Entry.parse_token_stream instead\n%! "; - warned_using_parse_token.val := True - } - else (); - *) - parse_token_stream entry ts let name e = e.ename let of_parser n (p : te Stream.t -> 'a) : 'a e = {egram = gram; ename = n; elocal = false; diff --git a/gramlib/grammar.mli b/gramlib/grammar.mli index 244ab710dc..1c5fcb7bbf 100644 --- a/gramlib/grammar.mli +++ b/gramlib/grammar.mli @@ -36,7 +36,6 @@ module type S = val parse_token_stream : 'a e -> te Stream.t -> 'a val print : Format.formatter -> 'a e -> unit external obj : 'a e -> te Gramext.g_entry = "%identity" - val parse_token : 'a e -> te Stream.t -> 'a end type ('self, 'a) ty_symbol type ('self, 'f, 'r) ty_rule diff --git a/ide/.merlin.in b/ide/.merlin.in index 953b5dce4c..4dc6f45550 100644 --- a/ide/.merlin.in +++ b/ide/.merlin.in @@ -2,5 +2,7 @@ PKG unix laglgtk2 lablgtk2.sourceview2 S utils B utils +S protocol +B protocol REC diff --git a/ide/configwin.ml b/ide/configwin.ml index 69e8b647ae..24be721631 100644 --- a/ide/configwin.ml +++ b/ide/configwin.ml @@ -46,6 +46,6 @@ let modifiers = Configwin_ihm.modifiers let edit ?(apply=(fun () -> ())) - title ?width ?height + title ?parent ?width ?height conf_struct_list = - Configwin_ihm.edit ~with_apply: true ~apply title ?width ?height conf_struct_list + Configwin_ihm.edit ~with_apply: true ~apply title ?parent ?width ?height conf_struct_list diff --git a/ide/configwin.mli b/ide/configwin.mli index 7616e471db..0ee77d69b5 100644 --- a/ide/configwin.mli +++ b/ide/configwin.mli @@ -158,6 +158,7 @@ val custom : ?label: string -> GPack.box -> (unit -> unit) -> bool -> parameter_ val edit : ?apply: (unit -> unit) -> string -> + ?parent:GWindow.window -> ?width:int -> ?height:int -> configuration_structure list -> diff --git a/ide/configwin_ihm.ml b/ide/configwin_ihm.ml index d16efa603d..91695e944e 100644 --- a/ide/configwin_ihm.ml +++ b/ide/configwin_ihm.ml @@ -662,12 +662,13 @@ class configuration_box (tt : GData.tooltips) conf_struct = to configure the various parameters. *) let edit ?(with_apply=true) ?(apply=(fun () -> ())) - title ?width ?height + title ?parent ?width ?height conf_struct = let dialog = GWindow.dialog ~position:`CENTER ~modal: true ~title: title - ?height ?width + ~type_hint:`DIALOG + ?parent ?height ?width () in let tooltips = GData.tooltips () in @@ -807,3 +808,40 @@ let custom ?label box f expand = custom_expand = expand ; custom_framed = label ; } + +(* Copying lablgtk question_box + forbidding hiding *) + +let question_box ~title ~buttons ?(default=1) ?icon ?parent message = + let button_nb = ref 0 in + let window = GWindow.dialog ~position:`CENTER ~modal:true ?parent ~type_hint:`DIALOG ~title () in + let hbox = GPack.hbox ~border_width:10 ~packing:window#vbox#add () in + let bbox = window#action_area in + begin match icon with + None -> () + | Some i -> hbox#pack i#coerce ~padding:4 + end; + ignore (GMisc.label ~text: message ~packing: hbox#add ()); + (* the function called to create each button by iterating *) + let rec iter_buttons n = function + [] -> + () + | button_label :: q -> + let b = GButton.button ~label: button_label + ~packing:(bbox#pack ~expand:true ~padding:4) () + in + ignore (b#connect#clicked ~callback: + (fun () -> button_nb := n; window#destroy ())); + (* If it's the first button then give it the focus *) + if n = default then b#grab_default () else (); + + iter_buttons (n+1) q + in + iter_buttons 1 buttons; + ignore (window#connect#destroy ~callback: GMain.Main.quit); + window#set_position `CENTER; + window#show (); + GMain.Main.main (); + !button_nb + +let message_box ~title ?icon ?parent ?(ok="Ok") message = + ignore (question_box ?icon ?parent ~title message ~buttons:[ ok ]) diff --git a/ide/configwin_ihm.mli b/ide/configwin_ihm.mli index c867ad9127..772a0958ff 100644 --- a/ide/configwin_ihm.mli +++ b/ide/configwin_ihm.mli @@ -60,7 +60,17 @@ val edit : ?with_apply:bool -> ?apply:(unit -> unit) -> string -> + ?parent:GWindow.window -> ?width:int -> ?height:int -> configuration_structure list -> return_button + +val question_box : title:string -> + buttons:string list -> + ?default:int -> ?icon:#GObj.widget -> + ?parent:GWindow.window -> string -> int + +val message_box : + title:string -> ?icon:#GObj.widget -> + ?parent:GWindow.window -> ?ok:string -> string -> unit diff --git a/ide/coqide.ml b/ide/coqide.ml index a26f7d1b94..40b8d2f484 100644 --- a/ide/coqide.ml +++ b/ide/coqide.ml @@ -103,7 +103,8 @@ let make_coqtop_args fname = with | None -> "", base_args | Some proj -> - proj, coqtop_args_from_project (read_project_file proj) @ base_args + let warning_fn x = Feedback.msg_warning Pp.(str x) in + proj, coqtop_args_from_project (read_project_file ~warning_fn proj) @ base_args in let args = match fname with | None -> args @@ -112,7 +113,6 @@ let make_coqtop_args fname = else "-topfile"::fname::args in proj, args -;; (** Setting drag & drop on widgets *) @@ -190,8 +190,8 @@ let load_file ?(maycreate=false) f = let confirm_save ok = if ok then flash_info "Saved" else warning "Save Failed" -let select_and_save ~saveas ?filename sn = - let do_save = if saveas then sn.fileops#saveas else sn.fileops#save in +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 |None -> false @@ -201,9 +201,9 @@ let select_and_save ~saveas ?filename sn = if ok then sn.tab_label#set_text (Filename.basename f); ok -let check_save ~saveas sn = +let check_save ?parent ~saveas sn = try match sn.fileops#filename with - |None -> select_and_save ~saveas sn + |None -> select_and_save ?parent ~saveas sn |Some f -> let ok = sn.fileops#save f in confirm_save ok; @@ -212,16 +212,17 @@ let check_save ~saveas sn = exception DontQuit -let check_quit saveall = +let check_quit ?parent saveall = (try save_pref () with _ -> flash_info "Cannot save preferences"); let is_modified sn = sn.buffer#modified in if List.exists is_modified notebook#pages then begin - let answ = GToolbox.question_box ~title:"Quit" + let answ = Configwin_ihm.question_box ~title:"Quit" ~buttons:["Save Named Buffers and Quit"; "Quit without Saving"; "Don't Quit"] ~default:0 ~icon:(warn_image ())#coerce + ?parent "There are unsaved buffers" in match answ with @@ -278,15 +279,15 @@ let load _ = | None -> () | Some f -> FileAux.load_file f -let save _ = on_current_term (FileAux.check_save ~saveas:false) +let save ?parent _ = on_current_term (FileAux.check_save ?parent ~saveas:false) -let saveas sn = +let saveas ?parent sn = try let filename = sn.fileops#filename in - ignore (FileAux.select_and_save ~saveas:true ?filename sn) + ignore (FileAux.select_and_save ?parent ~saveas:true ?filename sn) with _ -> warning "Save Failed" -let saveas = cb_on_current_term saveas +let saveas ?parent = cb_on_current_term (saveas ?parent) let saveall _ = List.iter @@ -297,33 +298,34 @@ let saveall _ = let () = Coq.save_all := saveall -let revert_all _ = +let revert_all ?parent _ = List.iter - (fun sn -> if sn.fileops#changed_on_disk then sn.fileops#revert) + (fun sn -> if sn.fileops#changed_on_disk then sn.fileops#revert ?parent ()) notebook#pages -let quit _ = - try FileAux.check_quit saveall; exit 0 +let quit ?parent _ = + try FileAux.check_quit ?parent saveall; exit 0 with FileAux.DontQuit -> () -let close_buffer sn = +let close_buffer ?parent sn = let do_remove () = notebook#remove_page notebook#current_page in if not sn.buffer#modified then do_remove () else - let answ = GToolbox.question_box ~title:"Close" + let answ = Configwin_ihm.question_box ~title:"Close" ~buttons:["Save Buffer and Close"; "Close without Saving"; "Don't Close"] ~default:0 ~icon:(warn_image ())#coerce + ?parent "This buffer has unsaved modifications" in match answ with - | 1 when FileAux.check_save ~saveas:true sn -> do_remove () + | 1 when FileAux.check_save ?parent ~saveas:true sn -> do_remove () | 2 -> do_remove () | _ -> () -let close_buffer = cb_on_current_term close_buffer +let close_buffer ?parent = cb_on_current_term (close_buffer ?parent) let export kind sn = match sn.fileops#filename with @@ -434,16 +436,16 @@ let coq_makefile sn = let coq_makefile = cb_on_current_term coq_makefile -let editor sn = +let editor ?parent sn = match sn.fileops#filename with |None -> warning "Call to external editor available only on named files" |Some f -> File.save (); let f = Filename.quote f in let cmd = Util.subst_command_placeholder cmd_editor#get f in - run_command ignore (fun _ -> sn.fileops#revert) cmd + run_command ignore (fun _ -> sn.fileops#revert ?parent ()) cmd -let editor = cb_on_current_term editor +let editor ?parent = cb_on_current_term (editor ?parent) let compile sn = File.save (); @@ -945,7 +947,7 @@ let build_ui () = try w#set_icon (Some (GdkPixbuf.from_file (MiscMenu.coq_icon ()))) with _ -> () in - let _ = w#event#connect#delete ~callback:(fun _ -> File.quit (); true) in + let _ = w#event#connect#delete ~callback:(fun _ -> File.quit ~parent:w (); true) in let _ = set_drag w#drag in let vbox = GPack.vbox ~homogeneous:false ~packing:w#add () in @@ -971,18 +973,18 @@ let build_ui () = item "File" ~label:"_File"; item "New" ~callback:File.newfile ~stock:`NEW; item "Open" ~callback:File.load ~stock:`OPEN; - item "Save" ~callback:File.save ~stock:`SAVE ~tooltip:"Save current buffer"; - item "Save as" ~label:"S_ave as" ~stock:`SAVE_AS ~callback:File.saveas; + 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; item "Revert all buffers" ~label:"_Revert all buffers" - ~callback:File.revert_all ~stock:`REVERT_TO_SAVED; + ~callback:(File.revert_all ~parent:w) ~stock:`REVERT_TO_SAVED; item "Close buffer" ~label:"_Close buffer" ~stock:`CLOSE - ~callback:File.close_buffer ~tooltip:"Close current buffer"; + ~callback:(File.close_buffer ~parent:w) ~tooltip:"Close current buffer"; item "Print..." ~label:"_Print..." ~callback:File.print ~stock:`PRINT ~accel:"<Ctrl>p"; item "Rehighlight" ~label:"Reh_ighlight" ~accel:"<Ctrl>l" ~callback:File.highlight ~stock:`REFRESH; - item "Quit" ~stock:`QUIT ~callback:File.quit; + item "Quit" ~stock:`QUIT ~callback:(File.quit ~parent:w); ]; menu export_menu [ @@ -1013,14 +1015,12 @@ let build_ui () = item "Find Previous" ~label:"Find _Previous" ~stock:`GO_UP ~accel:"<Shift>F3" ~callback:(cb_on_current_term (fun t -> t.finder#find_backward ())); - item "Complete Word" ~label:"Complete Word" ~accel:"<Ctrl>slash" - ~callback:(fun _ -> ()); item "External editor" ~label:"External editor" ~stock:`EDIT - ~callback:External.editor; + ~callback:(External.editor ~parent:w); item "Preferences" ~accel:"<Ctrl>comma" ~stock:`PREFERENCES ~callback:(fun _ -> begin - try Preferences.configure ~apply:refresh_notebook_pos () + try Preferences.configure ~apply:refresh_notebook_pos w with _ -> flash_info "Cannot save preferences" end; reset_revert_timer ()); @@ -1309,8 +1309,8 @@ let build_ui () = (Gdk.Bitmap.create_from_data ~width:2 ~height:2 "\x01\x02")); (* Showtime ! *) - w#show () - + w#show (); + w (** {2 Coqide main function } *) @@ -1325,7 +1325,7 @@ let make_scratch_buffer () = () let main files = - build_ui (); + let w = build_ui () in reset_revert_timer (); reset_autosave_timer (); (match files with @@ -1334,8 +1334,8 @@ let main files = notebook#goto_page 0; MiscMenu.initial_about (); on_current_term (fun t -> t.script#misc#grab_focus ()); - Minilib.log "End of Coqide.main" - + Minilib.log "End of Coqide.main"; + w (** {2 Argument parsing } *) @@ -1355,7 +1355,8 @@ let read_coqide_args argv = if project_files <> None then (output_string stderr "Error: multiple -f options"; exit 1); let d = CUnix.canonical_path_name (Filename.dirname file) in - let p = CoqProject_file.read_project_file file in + let warning_fn x = Format.eprintf "%s@\n%!" x in + let p = CoqProject_file.read_project_file ~warning_fn file in filter_coqtop coqtop (Some (d,p)) out args |"-f" :: [] -> output_string stderr "Error: missing project file name"; exit 1 @@ -1391,9 +1392,9 @@ let signals_to_crash = [Sys.sigabrt; Sys.sigalrm; Sys.sigfpe; Sys.sighup; Sys.sigill; Sys.sigpipe; Sys.sigquit; Sys.sigusr1; Sys.sigusr2] -let set_signal_handlers () = +let set_signal_handlers ?parent () = try - Sys.set_signal Sys.sigint (Sys.Signal_handle File.quit); + Sys.set_signal Sys.sigint (Sys.Signal_handle (File.quit ?parent)); List.iter (fun i -> Sys.set_signal i (Sys.Signal_handle FileAux.crash_save)) signals_to_crash diff --git a/ide/coqide.mli b/ide/coqide.mli index 03e8545377..1d438ec381 100644 --- a/ide/coqide.mli +++ b/ide/coqide.mli @@ -22,7 +22,7 @@ val logfile : string option ref val read_coqide_args : string list -> string list (** Prepare the widgets, load the given files in tabs *) -val main : string list -> unit +val main : string list -> GWindow.window (** Function to save anything and kill all coqtops @return [false] if you're allowed to quit. *) @@ -37,7 +37,7 @@ val do_load : string -> unit (** Set coqide to perform a clean quit at Ctrl-C, while launching [crash_save] and exiting for others received signals *) -val set_signal_handlers : unit -> unit +val set_signal_handlers : ?parent:GWindow.window -> unit -> unit (** Emergency saving of opened files as "foo.v.crashcoqide", and exit (if the integer isn't 127). *) diff --git a/ide/coqide_main.ml b/ide/coqide_main.ml index 91e8be875a..21f513b8f4 100644 --- a/ide/coqide_main.ml +++ b/ide/coqide_main.ml @@ -8,7 +8,6 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -let _ = Coqide.set_signal_handlers () let _ = GtkMain.Main.init () (* We handle Gtk warning messages ourselves : @@ -62,7 +61,8 @@ let () = let args = List.filter (fun x -> not (List.mem x files)) argl in Coq.check_connection args; Coqide.sup_args := args; - Coqide.main files; + let w = Coqide.main files in + Coqide.set_signal_handlers ~parent:w (); Coqide_os_specific.init (); try GMain.main (); diff --git a/ide/coqide_ui.ml b/ide/coqide_ui.ml index 91c529932f..c994898a4f 100644 --- a/ide/coqide_ui.ml +++ b/ide/coqide_ui.ml @@ -60,7 +60,6 @@ let init () = \n <menuitem action='Find' />\ \n <menuitem action='Find Next' />\ \n <menuitem action='Find Previous' />\ -\n <menuitem action='Complete Word' />\ \n <separator />\ \n <menuitem action='External editor' />\ \n <separator />\ diff --git a/ide/fileOps.ml b/ide/fileOps.ml index 7acd2c37a9..e4c8942cf1 100644 --- a/ide/fileOps.ml +++ b/ide/fileOps.ml @@ -18,10 +18,10 @@ object method filename : string option method update_stats : unit method changed_on_disk : bool - method revert : unit + method revert : ?parent:GWindow.window -> unit -> unit method auto_save : unit method save : string -> bool - method saveas : string -> bool + method saveas : ?parent:GWindow.window -> string -> bool end class fileops (buffer:GText.buffer) _fn (reset_handler:unit->unit) = @@ -48,7 +48,7 @@ object(self) false |_ -> false - method revert = + method revert ?parent () = let do_revert f = push_info "Reverting buffer"; try @@ -72,13 +72,14 @@ object(self) | Some f -> if not buffer#modified then do_revert f else - let answ = GToolbox.question_box + let answ = Configwin_ihm.question_box ~title:"Modified buffer changed on disk" ~buttons:["Revert from File"; "Overwrite File"; "Disable Auto Revert"] ~default:0 ~icon:(stock_to_widget `DIALOG_WARNING) + ?parent "Some unsaved buffers changed on disk" in match answ with @@ -102,13 +103,14 @@ object(self) end else false - method saveas f = + method saveas ?parent f = if not (Sys.file_exists f) then self#save f else - let answ = GToolbox.question_box ~title:"File exists on disk" + let answ = Configwin_ihm.question_box ~title:"File exists on disk" ~buttons:["Overwrite"; "Cancel";] ~default:1 ~icon:(warn_image ())#coerce + ?parent ("File "^f^" already exists") in match answ with diff --git a/ide/fileOps.mli b/ide/fileOps.mli index 9a1f0cb738..44a19f9981 100644 --- a/ide/fileOps.mli +++ b/ide/fileOps.mli @@ -16,10 +16,10 @@ object method filename : string option method update_stats : unit method changed_on_disk : bool - method revert : unit + method revert : ?parent:GWindow.window -> unit -> unit method auto_save : unit method save : string -> bool - method saveas : string -> bool + method saveas : ?parent:GWindow.window -> string -> bool end class fileops : GText.buffer -> string option -> (unit -> unit) -> ops diff --git a/ide/nanoPG.ml b/ide/nanoPG.ml index 002722ace9..f2913b1d1d 100644 --- a/ide/nanoPG.ml +++ b/ide/nanoPG.ml @@ -153,13 +153,13 @@ let emacs = insert emacs "Emacs" [] [ i#forward_sentence_end, { s with move = None })); mkE ~mods:mM _a "a" "Move to beginning of sentence" (Motion(fun s i -> i#backward_sentence_start, { s with move = None })); - mkE _n "n" "Move to next line" ~alias:[[],_Down,"DOWN"] (Motion(fun s i -> + mkE _n "n" "Move to next line" (Motion(fun s i -> let orig_off = Option.default i#line_offset s.move in let i = i#forward_line in let new_off = min (i#chars_in_line - 1) orig_off in (if new_off > 0 then i#set_line_offset new_off else i), { s with move = Some orig_off })); - mkE _p "p" "Move to previous line" ~alias:[[],_Up,"UP"] (Motion(fun s i -> + mkE _p "p" "Move to previous line" (Motion(fun s i -> let orig_off = Option.default i#line_offset s.move in let i = i#backward_line in let new_off = min (i#chars_in_line - 1) orig_off in diff --git a/ide/preferences.ml b/ide/preferences.ml index 6dc922c225..045d650c1c 100644 --- a/ide/preferences.ml +++ b/ide/preferences.ml @@ -688,7 +688,7 @@ let pmodifiers ?(all = false) name p = modifiers name (str_to_mod_list p#get) -let configure ?(apply=(fun () -> ())) () = +let configure ?(apply=(fun () -> ())) parent = let cmd_coqtop = string ~f:(fun s -> cmd_coqtop#set (if s = "AUTO" then None else Some s)) @@ -1068,7 +1068,7 @@ let configure ?(apply=(fun () -> ())) () = (* Format.printf "before edit: current.text_font = %s@." (Pango.Font.to_string current.text_font); *) - let x = edit ~apply "Customizations" cmds in + let x = edit ~apply "Customizations" ~parent cmds in (* Format.printf "after edit: current.text_font = %s@." (Pango.Font.to_string current.text_font); *) diff --git a/ide/preferences.mli b/ide/preferences.mli index dd2976efc2..7ed6a40bdb 100644 --- a/ide/preferences.mli +++ b/ide/preferences.mli @@ -107,7 +107,7 @@ val diffs : string preference val save_pref : unit -> unit val load_pref : unit -> unit -val configure : ?apply:(unit -> unit) -> unit -> unit +val configure : ?apply:(unit -> unit) -> GWindow.window -> unit val stick : 'a preference -> (#GObj.widget as 'obj) -> ('a -> unit) -> unit diff --git a/kernel/cClosure.ml b/kernel/cClosure.ml index 95546a83e1..7e73609996 100644 --- a/kernel/cClosure.ml +++ b/kernel/cClosure.ml @@ -72,11 +72,8 @@ let with_stats c = end else Lazy.force c -let all_opaque = (Id.Pred.empty, Cpred.empty) -let all_transparent = (Id.Pred.full, Cpred.full) - -let is_transparent_variable (ids, _) id = Id.Pred.mem id ids -let is_transparent_constant (_, csts) cst = Cpred.mem cst csts +let all_opaque = TransparentState.empty +let all_transparent = TransparentState.full module type RedFlagsSig = sig type reds @@ -93,8 +90,8 @@ module type RedFlagsSig = sig val no_red : reds val red_add : reds -> red_kind -> reds val red_sub : reds -> red_kind -> reds - val red_add_transparent : reds -> transparent_state -> reds - val red_transparent : reds -> transparent_state + val red_add_transparent : reds -> TransparentState.t -> reds + val red_transparent : reds -> TransparentState.t val mkflags : red_kind list -> reds val red_set : reds -> red_kind -> bool val red_projection : reds -> Projection.t -> bool @@ -106,11 +103,13 @@ module RedFlags = (struct (* [r_const=(false,cl)] means only those in [cl] *) (* [r_delta=true] just mean [r_const=(true,[])] *) + open TransparentState + type reds = { r_beta : bool; r_delta : bool; r_eta : bool; - r_const : transparent_state; + r_const : TransparentState.t; r_zeta : bool; r_match : bool; r_fix : bool; @@ -143,30 +142,30 @@ module RedFlags = (struct | ETA -> { red with r_eta = true } | DELTA -> { red with r_delta = true; r_const = all_transparent } | CONST kn -> - let (l1,l2) = red.r_const in - { red with r_const = l1, Cpred.add kn l2 } + let r = red.r_const in + { red with r_const = { r with tr_cst = Cpred.add kn r.tr_cst } } | MATCH -> { red with r_match = true } | FIX -> { red with r_fix = true } | COFIX -> { red with r_cofix = true } | ZETA -> { red with r_zeta = true } | VAR id -> - let (l1,l2) = red.r_const in - { red with r_const = Id.Pred.add id l1, l2 } + let r = red.r_const in + { red with r_const = { r with tr_var = Id.Pred.add id r.tr_var } } let red_sub red = function | BETA -> { red with r_beta = false } | ETA -> { red with r_eta = false } | DELTA -> { red with r_delta = false } | CONST kn -> - let (l1,l2) = red.r_const in - { red with r_const = l1, Cpred.remove kn l2 } + let r = red.r_const in + { red with r_const = { r with tr_cst = Cpred.remove kn r.tr_cst } } | MATCH -> { red with r_match = false } | FIX -> { red with r_fix = false } | COFIX -> { red with r_cofix = false } | ZETA -> { red with r_zeta = false } | VAR id -> - let (l1,l2) = red.r_const in - { red with r_const = Id.Pred.remove id l1, l2 } + let r = red.r_const in + { red with r_const = { r with tr_var = Id.Pred.remove id r.tr_var } } let red_transparent red = red.r_const @@ -179,12 +178,10 @@ module RedFlags = (struct | BETA -> incr_cnt red.r_beta beta | ETA -> incr_cnt red.r_eta eta | CONST kn -> - let (_,l) = red.r_const in - let c = Cpred.mem kn l in + let c = is_transparent_constant red.r_const kn in incr_cnt c delta | VAR id -> (* En attendant d'avoir des kn pour les Var *) - let (l,_) = red.r_const in - let c = Id.Pred.mem id l in + let c = is_transparent_variable red.r_const id in incr_cnt c delta | ZETA -> incr_cnt red.r_zeta zeta | MATCH -> incr_cnt red.r_match nb_match diff --git a/kernel/cClosure.mli b/kernel/cClosure.mli index 1ee4bccc25..b6c87b3732 100644 --- a/kernel/cClosure.mli +++ b/kernel/cClosure.mli @@ -24,14 +24,6 @@ val with_stats: 'a Lazy.t -> 'a Rem: reduction of a Rel/Var bound to a term is Delta, but reduction of a LetIn expression is Letin reduction *) - - -val all_opaque : transparent_state -val all_transparent : transparent_state - -val is_transparent_variable : transparent_state -> variable -> bool -val is_transparent_constant : transparent_state -> Constant.t -> bool - (** Sets of reduction kinds. *) module type RedFlagsSig = sig type reds @@ -60,10 +52,10 @@ module type RedFlagsSig = sig val red_sub : reds -> red_kind -> reds (** Adds a reduction kind to a set *) - val red_add_transparent : reds -> transparent_state -> reds + val red_add_transparent : reds -> TransparentState.t -> reds (** Retrieve the transparent state of the reduction flags *) - val red_transparent : reds -> transparent_state + val red_transparent : reds -> TransparentState.t (** Build a reduction set from scratch = iter [red_add] on [no_red] *) val mkflags : red_kind list -> reds diff --git a/kernel/conv_oracle.ml b/kernel/conv_oracle.ml index ac78064235..fe82353b70 100644 --- a/kernel/conv_oracle.ml +++ b/kernel/conv_oracle.ml @@ -81,7 +81,8 @@ let fold_strategy f { var_opacity; cst_opacity; _ } accu = let accu = Id.Map.fold fvar var_opacity accu in Cmap.fold fcst cst_opacity accu -let get_transp_state { var_trstate; cst_trstate; _ } = (var_trstate, cst_trstate) +let get_transp_state { var_trstate; cst_trstate; _ } = + { TransparentState.tr_var = var_trstate; tr_cst = cst_trstate } let dep_order l2r k1 k2 = match k1, k2 with | RelKey _, RelKey _ -> l2r diff --git a/kernel/conv_oracle.mli b/kernel/conv_oracle.mli index 67add5dd35..bc06cc21b6 100644 --- a/kernel/conv_oracle.mli +++ b/kernel/conv_oracle.mli @@ -41,5 +41,5 @@ val set_strategy : oracle -> Constant.t tableKey -> level -> oracle (** Fold over the non-transparent levels of the oracle. Order unspecified. *) val fold_strategy : (Constant.t tableKey -> level -> 'a -> 'a) -> oracle -> 'a -> 'a -val get_transp_state : oracle -> transparent_state +val get_transp_state : oracle -> TransparentState.t diff --git a/kernel/environ.ml b/kernel/environ.ml index f61dd0c101..019c0a6819 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -384,8 +384,26 @@ let set_engagement c env = (* Unsafe *) { env with env_stratification = { env.env_stratification with env_engagement = c } } +(* It's convenient to use [{flags with foo = bar}] so we're smart wrt to it. *) +let same_flags { + check_guarded; + check_universes; + conv_oracle; + share_reduction; + enable_VM; + enable_native_compiler; + } alt = + check_guarded == alt.check_guarded && + check_universes == alt.check_universes && + conv_oracle == alt.conv_oracle && + share_reduction == alt.share_reduction && + enable_VM == alt.enable_VM && + enable_native_compiler == alt.enable_native_compiler +[@warning "+9"] + let set_typing_flags c env = (* Unsafe *) - { env with env_typing_flags = c } + if same_flags env.env_typing_flags c then env + else { env with env_typing_flags = c } (* Global constants *) diff --git a/kernel/kernel.mllib b/kernel/kernel.mllib index a18c5d1e20..54c239349d 100644 --- a/kernel/kernel.mllib +++ b/kernel/kernel.mllib @@ -1,4 +1,5 @@ Names +TransparentState Uint31 Univ UGraph diff --git a/kernel/modops.ml b/kernel/modops.ml index bab2eae3df..0dde1c7e75 100644 --- a/kernel/modops.ml +++ b/kernel/modops.ml @@ -47,10 +47,9 @@ type signature_mismatch_error = | RecordFieldExpected of bool | RecordProjectionsExpected of Name.t list | NotEqualInductiveAliases - | IncompatibleInstances | IncompatibleUniverses of Univ.univ_inconsistency | IncompatiblePolymorphism of env * types * types - | IncompatibleConstraints of Univ.AUContext.t + | IncompatibleConstraints of { got : Univ.AUContext.t; expect : Univ.AUContext.t } type module_typing_error = | SignatureMismatch of diff --git a/kernel/modops.mli b/kernel/modops.mli index 8e7e618fcd..0acd09fb12 100644 --- a/kernel/modops.mli +++ b/kernel/modops.mli @@ -106,10 +106,9 @@ type signature_mismatch_error = | RecordFieldExpected of bool | RecordProjectionsExpected of Name.t list | NotEqualInductiveAliases - | IncompatibleInstances | IncompatibleUniverses of Univ.univ_inconsistency | IncompatiblePolymorphism of env * types * types - | IncompatibleConstraints of Univ.AUContext.t + | IncompatibleConstraints of { got : Univ.AUContext.t; expect : Univ.AUContext.t } type module_typing_error = | SignatureMismatch of diff --git a/kernel/names.ml b/kernel/names.ml index 18560d5f8d..b2d6a489a6 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -715,13 +715,6 @@ let hcons_construct = Hashcons.simple_hcons Hconstruct.generate Hconstruct.hcons (*****************) -type transparent_state = Id.Pred.t * Cpred.t - -let empty_transparent_state = (Id.Pred.empty, Cpred.empty) -let full_transparent_state = (Id.Pred.full, Cpred.full) -let var_full_transparent_state = (Id.Pred.full, Cpred.empty) -let cst_full_transparent_state = (Id.Pred.empty, Cpred.full) - type 'a tableKey = | ConstKey of 'a | VarKey of Id.t diff --git a/kernel/names.mli b/kernel/names.mli index 98995752a2..350db871d5 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -510,14 +510,6 @@ type 'a tableKey = | VarKey of Id.t | RelKey of Int.t -(** Sets of names *) -type transparent_state = Id.Pred.t * Cpred.t - -val empty_transparent_state : transparent_state -val full_transparent_state : transparent_state -val var_full_transparent_state : transparent_state -val cst_full_transparent_state : transparent_state - type inv_rel_key = int (** index in the [rel_context] part of environment starting by the end, {e inverse} of de Bruijn indice *) diff --git a/kernel/reduction.ml b/kernel/reduction.ml index 5515ff9767..fbb481424f 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -177,7 +177,7 @@ type 'a kernel_conversion_function = env -> 'a -> 'a -> unit (* functions of this type can be called from outside the kernel *) type 'a extended_conversion_function = - ?l2r:bool -> ?reds:Names.transparent_state -> env -> + ?l2r:bool -> ?reds:TransparentState.t -> env -> ?evars:((existential->constr option) * UGraph.t) -> 'a -> 'a -> unit @@ -758,7 +758,7 @@ let gen_conv cv_pb l2r reds env evars univs t1 t2 = () (* Profiling *) -let gen_conv cv_pb ?(l2r=false) ?(reds=full_transparent_state) env ?(evars=(fun _->None), universes env) = +let gen_conv cv_pb ?(l2r=false) ?(reds=TransparentState.full) env ?(evars=(fun _->None), universes env) = let evars, univs = evars in if Flags.profile then let fconv_universes_key = CProfile.declare_profile "trans_fconv_universes" in @@ -792,11 +792,11 @@ let infer_conv_universes = CProfile.profile8 infer_conv_universes_key infer_conv_universes else infer_conv_universes -let infer_conv ?(l2r=false) ?(evars=fun _ -> None) ?(ts=full_transparent_state) +let infer_conv ?(l2r=false) ?(evars=fun _ -> None) ?(ts=TransparentState.full) env univs t1 t2 = infer_conv_universes CONV l2r evars ts env univs t1 t2 -let infer_conv_leq ?(l2r=false) ?(evars=fun _ -> None) ?(ts=full_transparent_state) +let infer_conv_leq ?(l2r=false) ?(evars=fun _ -> None) ?(ts=TransparentState.full) env univs t1 t2 = infer_conv_universes CUMUL l2r evars ts env univs t1 t2 diff --git a/kernel/reduction.mli b/kernel/reduction.mli index 581e8bd88a..0408dbf057 100644 --- a/kernel/reduction.mli +++ b/kernel/reduction.mli @@ -31,7 +31,7 @@ exception NotConvertibleVect of int type 'a kernel_conversion_function = env -> 'a -> 'a -> unit type 'a extended_conversion_function = - ?l2r:bool -> ?reds:Names.transparent_state -> env -> + ?l2r:bool -> ?reds:TransparentState.t -> env -> ?evars:((existential->constr option) * UGraph.t) -> 'a -> 'a -> unit @@ -77,15 +77,15 @@ val conv_leq : types extended_conversion_function (** These conversion functions are used by module subtyping, which needs to infer universe constraints inside the kernel *) val infer_conv : ?l2r:bool -> ?evars:(existential->constr option) -> - ?ts:Names.transparent_state -> constr infer_conversion_function + ?ts:TransparentState.t -> constr infer_conversion_function val infer_conv_leq : ?l2r:bool -> ?evars:(existential->constr option) -> - ?ts:Names.transparent_state -> types infer_conversion_function + ?ts:TransparentState.t -> types infer_conversion_function (** Depending on the universe state functions, this might raise [UniverseInconsistency] in addition to [NotConvertible] (for better error messages). *) val generic_conv : conv_pb -> l2r:bool -> (existential->constr option) -> - Names.transparent_state -> (constr,'a) generic_conversion_function + TransparentState.t -> (constr,'a) generic_conversion_function val default_conv : conv_pb -> ?l2r:bool -> types kernel_conversion_function val default_conv_leq : ?l2r:bool -> types kernel_conversion_function diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index df10398b2f..2464df799e 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -192,7 +192,9 @@ let set_engagement c senv = engagement = Some c } let set_typing_flags c senv = - { senv with env = Environ.set_typing_flags c senv.env } + let env = Environ.set_typing_flags c senv.env in + if env == senv.env then senv + else { senv with env } let set_share_reduction b senv = let flags = Environ.typing_flags senv.env in diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml index d64342dbb0..347c30dd64 100644 --- a/kernel/subtyping.ml +++ b/kernel/subtyping.ml @@ -93,10 +93,8 @@ let check_conv_error error why cst poly f env a1 a2 = | Univ.UniverseInconsistency e -> error (IncompatibleUniverses e) let check_polymorphic_instance error env auctx1 auctx2 = - if not (Univ.AUContext.size auctx1 == Univ.AUContext.size auctx2) then - error IncompatibleInstances - else if not (UGraph.check_subtype (Environ.universes env) auctx2 auctx1) then - error (IncompatibleConstraints auctx1) + if not (UGraph.check_subtype (Environ.universes env) auctx2 auctx1) then + error (IncompatibleConstraints { got = auctx1; expect = auctx2; } ) else Environ.push_context ~strict:false (Univ.AUContext.repr auctx2) env diff --git a/kernel/transparentState.ml b/kernel/transparentState.ml new file mode 100644 index 0000000000..9661dace6a --- /dev/null +++ b/kernel/transparentState.ml @@ -0,0 +1,45 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names + +type t = { + tr_var : Id.Pred.t; + tr_cst : Cpred.t; +} + +let empty = { + tr_var = Id.Pred.empty; + tr_cst = Cpred.empty; +} + +let full = { + tr_var = Id.Pred.full; + tr_cst = Cpred.full; +} + +let var_full = { + tr_var = Id.Pred.full; + tr_cst = Cpred.empty; +} + +let cst_full = { + tr_var = Id.Pred.empty; + tr_cst = Cpred.full; +} + +let is_empty ts = + Id.Pred.is_empty ts.tr_var && Cpred.is_empty ts.tr_cst + +let is_transparent_variable ts id = + Id.Pred.mem id ts.tr_var + +let is_transparent_constant ts cst = + Cpred.mem cst ts.tr_cst diff --git a/kernel/transparentState.mli b/kernel/transparentState.mli new file mode 100644 index 0000000000..f2999c6869 --- /dev/null +++ b/kernel/transparentState.mli @@ -0,0 +1,34 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names + +(** Sets of names *) +type t = { + tr_var : Id.Pred.t; + tr_cst : Cpred.t; +} + +val empty : t +(** Everything opaque *) + +val full : t +(** Everything transparent *) + +val var_full : t +(** All variables transparent *) + +val cst_full : t +(** All constant transparent *) + +val is_empty : t -> bool + +val is_transparent_variable : t -> Id.t -> bool +val is_transparent_constant : t -> Constant.t -> bool diff --git a/kernel/uGraph.ml b/kernel/uGraph.ml index 9ff51fca55..9083156745 100644 --- a/kernel/uGraph.ml +++ b/kernel/uGraph.ml @@ -942,34 +942,36 @@ let check_eq_instances g t1 t2 = (** Pretty-printing *) +let pr_umap sep pr map = + let cmp (u,_) (v,_) = Level.compare u v in + Pp.prlist_with_sep sep pr (List.sort cmp (UMap.bindings map)) + let pr_arc prl = function | _, Canonical {univ=u; ltle; _} -> if UMap.is_empty ltle then mt () else prl u ++ str " " ++ v 0 - (pr_sequence (fun (v, strict) -> + (pr_umap Pp.spc (fun (v, strict) -> (if strict then str "< " else str "<= ") ++ prl v) - (UMap.bindings ltle)) ++ + ltle) ++ fnl () | u, Equiv v -> prl u ++ str " = " ++ prl v ++ fnl () let pr_universes prl g = - let graph = UMap.fold (fun u a l -> (u,a)::l) g.entries [] in - prlist (pr_arc prl) graph + pr_umap mt (pr_arc prl) g.entries (* Dumping constraints to a file *) let dump_universes output g = let dump_arc u = function | Canonical {univ=u; ltle; _} -> - let u_str = Level.to_string u in UMap.iter (fun v strict -> let typ = if strict then Lt else Le in - output typ u_str (Level.to_string v)) ltle; + output typ u v) ltle; | Equiv v -> - output Eq (Level.to_string u) (Level.to_string v) + output Eq u v in UMap.iter dump_arc g.entries diff --git a/kernel/uGraph.mli b/kernel/uGraph.mli index 4336a22b8c..a2cc5b3116 100644 --- a/kernel/uGraph.mli +++ b/kernel/uGraph.mli @@ -86,7 +86,7 @@ val check_subtype : AUContext.t check_function (** {6 Dumping to a file } *) val dump_universes : - (constraint_type -> string -> string -> unit) -> t -> unit + (constraint_type -> Level.t -> Level.t -> unit) -> t -> unit (** {6 Debugging} *) val check_universes_invariants : t -> unit diff --git a/kernel/univ.ml b/kernel/univ.ml index 0edf750997..2b3b4f9486 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -570,9 +570,9 @@ struct include S let pr prl c = - fold (fun (u1,op,u2) pp_std -> - pp_std ++ prl u1 ++ pr_constraint_type op ++ - prl u2 ++ fnl () ) c (str "") + v 0 (prlist_with_sep spc (fun (u1,op,u2) -> + hov 0 (prl u1 ++ pr_constraint_type op ++ prl u2)) + (elements c)) end diff --git a/kernel/vconv.ml b/kernel/vconv.ml index c1130e62c9..246c90c09d 100644 --- a/kernel/vconv.ml +++ b/kernel/vconv.ml @@ -191,7 +191,7 @@ let warn_bytecode_compiler_failed = let vm_conv_gen cv_pb env univs t1 t2 = if not (typing_flags env).Declarations.enable_VM then Reduction.generic_conv cv_pb ~l2r:false (fun _ -> None) - full_transparent_state env univs t1 t2 + TransparentState.full env univs t1 t2 else try let v1 = val_of_constr env t1 in @@ -200,7 +200,7 @@ let vm_conv_gen cv_pb env univs t1 t2 = with Not_found | Invalid_argument _ -> warn_bytecode_compiler_failed (); Reduction.generic_conv cv_pb ~l2r:false (fun _ -> None) - full_transparent_state env univs t1 t2 + TransparentState.full env univs t1 t2 let vm_conv cv_pb env t1 t2 = let univs = Environ.universes env in diff --git a/lib/coqProject_file.ml b/lib/coqProject_file.ml index 7395654022..868042303d 100644 --- a/lib/coqProject_file.ml +++ b/lib/coqProject_file.ml @@ -12,10 +12,6 @@ ideally we would like to make this independent so it can be bootstrapped. *) -(* Note the problem with the error invokation below calling exit... *) -(* let error msg = Feedback.msg_error msg *) -let warning msg = Feedback.msg_warning Pp.(str msg) - type arg_source = CmdLine | ProjectFile type 'a sourced = { thing : 'a; source : arg_source } @@ -147,7 +143,7 @@ let exists_dir dir = try Sys.is_directory (strip_trailing_slash dir) with Sys_error _ -> false -let process_cmd_line orig_dir proj args = +let process_cmd_line ~warning_fn orig_dir proj args = let parsing_project_file = ref (proj.project_file <> None) in let sourced x = { thing = x; source = if !parsing_project_file then ProjectFile else CmdLine } in let orig_dir = (* avoids turning foo.v in ./foo.v *) @@ -170,7 +166,7 @@ let process_cmd_line orig_dir proj args = | ("-full"|"-opt") :: r -> aux { proj with use_ocamlopt = true } r | "-install" :: d :: r -> if proj.install_kind <> None then - (warning "-install set more than once.@\n%!"); + (warning_fn "-install set more than once."); let install = match d with | "user" -> UserInstall | "none" -> NoInstall @@ -197,7 +193,7 @@ let process_cmd_line orig_dir proj args = let file = CUnix.remove_path_dot (CUnix.correct_path file orig_dir) in let () = match proj.project_file with | None -> () - | Some _ -> warning "Multiple project files are deprecated.@\n%!" + | Some _ -> warning_fn "Multiple project files are deprecated." in parsing_project_file := true; let proj = aux { proj with project_file = Some file } (parse file) in @@ -236,11 +232,11 @@ let process_cmd_line orig_dir proj args = (******************************* API ************************************) -let cmdline_args_to_project ~curdir args = - process_cmd_line curdir (mk_project None None None true) args +let cmdline_args_to_project ~warning_fn ~curdir args = + process_cmd_line ~warning_fn curdir (mk_project None None None true) args -let read_project_file f = - process_cmd_line (Filename.dirname f) +let read_project_file ~warning_fn f = + process_cmd_line ~warning_fn (Filename.dirname f) (mk_project (Some f) None (Some NoInstall) true) (parse f) let rec find_project_file ~from ~projfile_name = diff --git a/lib/coqProject_file.mli b/lib/coqProject_file.mli index 2a6a09a9a0..20b276ce8c 100644 --- a/lib/coqProject_file.mli +++ b/lib/coqProject_file.mli @@ -51,8 +51,8 @@ and install = | TraditionalInstall | UserInstall -val cmdline_args_to_project : curdir:string -> string list -> project -val read_project_file : string -> project +val cmdline_args_to_project : warning_fn:(string -> unit) -> curdir:string -> string list -> project +val read_project_file : warning_fn:(string -> unit) -> string -> project val coqtop_args_from_project : project -> string list val find_project_file : from:string -> projfile_name:string -> string option diff --git a/lib/flags.ml b/lib/flags.ml index 582506f3a8..3aef5a7b2c 100644 --- a/lib/flags.ml +++ b/lib/flags.ml @@ -99,10 +99,6 @@ let verbosely f x = without_option quiet f x let if_silent f x = if !quiet then f x let if_verbose f x = if not !quiet then f x -let auto_intros = ref true -let make_auto_intros flag = auto_intros := flag -let is_auto_intros () = !auto_intros - let polymorphic_inductive_cumulativity = ref false let make_polymorphic_inductive_cumulativity b = polymorphic_inductive_cumulativity := b let is_polymorphic_inductive_cumulativity () = !polymorphic_inductive_cumulativity diff --git a/lib/flags.mli b/lib/flags.mli index b667235678..e282d4ca8c 100644 --- a/lib/flags.mli +++ b/lib/flags.mli @@ -78,9 +78,6 @@ val if_silent : ('a -> unit) -> 'a -> unit val if_verbose : ('a -> unit) -> 'a -> unit (* Miscellaneus flags for vernac *) -val make_auto_intros : bool -> unit -val is_auto_intros : unit -> bool - val program_mode : bool ref val is_program_mode : unit -> bool diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index eb3e633892..d4aa598fd8 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -59,7 +59,7 @@ module type S = type e 'a = 'y; value create : string -> e 'a; value parse : e 'a -> parsable -> 'a; - value parse_token : e 'a -> Stream.t te -> 'a; + value parse_token_stream : e 'a -> Stream.t te -> 'a; value name : e 'a -> string; value of_parser : string -> (Stream.t te -> 'a) -> e 'a; value print : Format.formatter -> e 'a -> unit; diff --git a/plugins/btauto/Algebra.v b/plugins/btauto/Algebra.v index f1095fc9f1..638a4cef21 100644 --- a/plugins/btauto/Algebra.v +++ b/plugins/btauto/Algebra.v @@ -10,7 +10,7 @@ end. Arguments decide P /H. -Hint Extern 5 => progress bool. +Hint Extern 5 => progress bool : core. Ltac define t x H := set (x := t) in *; assert (H : t = x) by reflexivity; clearbody x. @@ -147,7 +147,7 @@ Qed. (** * The core reflexive part. *) -Hint Constructors valid. +Hint Constructors valid : core. Fixpoint beq_poly pl pr := match pl with @@ -315,7 +315,7 @@ Section Validity. (* Decision procedure of validity *) -Hint Constructors valid linear. +Hint Constructors valid linear : core. Lemma valid_le_compat : forall k l p, valid k p -> (k <= l)%positive -> valid l p. Proof. @@ -425,10 +425,10 @@ match goal with | [ |- (?z < Pos.max ?x ?y)%positive ] => apply Pos.max_case_strong; intros; lia | _ => zify; omega -end. -Hint Resolve Pos.le_max_r Pos.le_max_l. +end : core. +Hint Resolve Pos.le_max_r Pos.le_max_l : core. -Hint Constructors valid linear. +Hint Constructors valid linear : core. (* Compatibility of validity w.r.t algebraic operations *) diff --git a/plugins/btauto/Reflect.v b/plugins/btauto/Reflect.v index 4cde08872f..98f5ab067a 100644 --- a/plugins/btauto/Reflect.v +++ b/plugins/btauto/Reflect.v @@ -77,10 +77,10 @@ intros var f; induction f; simpl poly_of_formula; simpl formula_eval; auto. end. Qed. -Hint Extern 5 => change 0 with (min 0 0). -Local Hint Resolve poly_add_valid_compat poly_mul_valid_compat. -Local Hint Constructors valid. -Hint Extern 5 => zify; omega. +Hint Extern 5 => change 0 with (min 0 0) : core. +Local Hint Resolve poly_add_valid_compat poly_mul_valid_compat : core. +Local Hint Constructors valid : core. +Hint Extern 5 => zify; omega : core. (* Compatibility with validity *) diff --git a/plugins/derive/g_derive.mlg b/plugins/derive/g_derive.mlg index 18316bf2cd..df4b647642 100644 --- a/plugins/derive/g_derive.mlg +++ b/plugins/derive/g_derive.mlg @@ -18,7 +18,7 @@ DECLARE PLUGIN "derive_plugin" { -let classify_derive_command _ = Vernacexpr.(VtStartProof ("Classic",Doesn'tGuaranteeOpacity,[]),VtLater) +let classify_derive_command _ = Vernacextend.(VtStartProof ("Classic",Doesn'tGuaranteeOpacity,[]),VtLater) } diff --git a/plugins/firstorder/g_ground.mlg b/plugins/firstorder/g_ground.mlg index 1128a78093..a212d13453 100644 --- a/plugins/firstorder/g_ground.mlg +++ b/plugins/firstorder/g_ground.mlg @@ -66,7 +66,7 @@ let default_intuition_tac = let name = { Tacexpr.mltac_plugin = "ground_plugin"; mltac_tactic = "auto_with"; } in let entry = { Tacexpr.mltac_name = name; mltac_index = 0 } in Tacenv.register_ml_tactic name [| tac |]; - Tacexpr.TacML (Loc.tag (entry, [])) + Tacexpr.TacML (CAst.make (entry, [])) let (set_default_solver, default_solver, print_default_solver) = Tactic_option.declare_tactic_option ~default:default_intuition_tac "Firstorder default solver" diff --git a/plugins/firstorder/ground.ml b/plugins/firstorder/ground.ml index 516b04ea21..6a80525200 100644 --- a/plugins/firstorder/ground.ml +++ b/plugins/firstorder/ground.ml @@ -18,16 +18,16 @@ open Tacticals.New open Globnames let update_flags ()= - let f acc coe = - match coe.Classops.coe_value with - | ConstRef c -> Names.Cpred.add c acc - | _ -> acc + let open TransparentState in + let f accu coe = match coe.Classops.coe_value with + | ConstRef kn -> { accu with tr_cst = Names.Cpred.remove kn accu.tr_cst } + | _ -> accu in - let pred = List.fold_left f Names.Cpred.empty (Classops.coercions ()) in + let flags = List.fold_left f TransparentState.full (Classops.coercions ()) in red_flags:= CClosure.RedFlags.red_add_transparent CClosure.betaiotazeta - (Names.Id.Pred.full,Names.Cpred.complement pred) + flags let ground_tac solver startseq = Proofview.Goal.enter begin fun gl -> diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 651895aa08..92fa94d6dc 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -1487,7 +1487,7 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = Eauto.eauto_with_bases (true,5) [(fun _ sigma -> (sigma, Lazy.force refl_equal))] - [Hints.Hint_db.empty empty_transparent_state false] + [Hints.Hint_db.empty TransparentState.empty false] ) ) ) diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index d1e7d8a5a8..1cf952576d 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -320,10 +320,16 @@ let build_functional_principle (evd:Evd.evar_map ref) interactive_proof old_prin (* let dur1 = System.time_difference tim1 tim2 in *) (* Pp.msgnl (str ("Time to compute proof: ") ++ str (string_of_float dur1)); *) (* end; *) - get_proof_clean true, CEphemeron.create hook - end - + let open Proof_global in + let { id; entries; persistence } = fst @@ close_proof ~keep_body_ucst_separate:false (fun x -> x) in + match entries with + | [entry] -> + discard_current (); + (id,(entry,persistence)), CEphemeron.create hook + | _ -> + CErrors.anomaly Pp.(str "[build_functional_principle] close_proof returned more than one proof term") + end let generate_functional_principle (evd: Evd.evar_map ref) interactive_proof diff --git a/plugins/funind/g_indfun.mlg b/plugins/funind/g_indfun.mlg index 155df1c1e0..7e707b423a 100644 --- a/plugins/funind/g_indfun.mlg +++ b/plugins/funind/g_indfun.mlg @@ -186,8 +186,8 @@ VERNAC COMMAND EXTEND Function Vernac_classifier.classify_vernac (Vernacexpr.(VernacExpr([], VernacFixpoint(Decl_kinds.NoDischarge, List.map snd recsl)))) with - | Vernacexpr.VtSideff ids, _ when hard -> - Vernacexpr.(VtStartProof ("Classic", GuaranteesOpacity, ids), VtLater) + | Vernacextend.VtSideff ids, _ when hard -> + Vernacextend.(VtStartProof ("Classic", GuaranteesOpacity, ids), VtLater) | x -> x } -> { do_generate_principle false (List.map snd recsl) } END @@ -225,7 +225,7 @@ let warning_error names e = VERNAC COMMAND EXTEND NewFunctionalScheme | ["Functional" "Scheme" ne_fun_scheme_arg_list_sep(fas,"with") ] - => { Vernacexpr.VtSideff(List.map pi1 fas), Vernacexpr.VtLater } + => { Vernacextend.(VtSideff(List.map pi1 fas), VtLater) } -> { begin @@ -261,7 +261,7 @@ END VERNAC COMMAND EXTEND NewFunctionalCase | ["Functional" "Case" fun_scheme_arg(fas) ] - => { Vernacexpr.VtSideff[pi1 fas], Vernacexpr.VtLater } + => { Vernacextend.(VtSideff[pi1 fas], VtLater) } -> { Functional_principles_types.build_case_scheme fas } END diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index cd2ea3ef88..b68b34ca35 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -147,17 +147,6 @@ let save with_clean id const (locality,_,kind) hook = CEphemeron.iter_opt hook (fun f -> Lemmas.call_hook fix_exn f l r); definition_message id - - -let cook_proof _ = - let (id,(entry,_,strength)) = Pfedit.cook_proof () in - (id,(entry,strength)) - -let get_proof_clean do_reduce = - let result = cook_proof do_reduce in - Proof_global.discard_current (); - result - let with_full_print f a = let old_implicit_args = Impargs.is_implicit_args () and old_strict_implicit_args = Impargs.is_strict_implicit_args () diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli index 0c8f40c5cf..c9d153d89f 100644 --- a/plugins/funind/indfun_common.mli +++ b/plugins/funind/indfun_common.mli @@ -45,15 +45,6 @@ val jmeq_refl : unit -> EConstr.constr val save : bool -> Id.t -> Safe_typing.private_constants Entries.definition_entry -> Decl_kinds.goal_kind -> Lemmas.declaration_hook CEphemeron.key -> unit -(* [get_proof_clean do_reduce] : returns the proof name, definition, kind and hook and - abort the proof -*) -val get_proof_clean : bool -> - Names.Id.t * - (Safe_typing.private_constants Entries.definition_entry * Decl_kinds.goal_kind) - - - (* [with_full_print f a] applies [f] to [a] in full printing environment. This function preserves the print settings diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 63a3e0582d..6e5e3f9353 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -1359,7 +1359,7 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp Eauto.eauto_with_bases (true,5) [(fun _ sigma -> (sigma, (Lazy.force refl_equal)))] - [Hints.Hint_db.empty empty_transparent_state false] + [Hints.Hint_db.empty TransparentState.empty false] ] ) ) diff --git a/plugins/ltac/coretactics.mlg b/plugins/ltac/coretactics.mlg index 6388906f5e..d9338f0421 100644 --- a/plugins/ltac/coretactics.mlg +++ b/plugins/ltac/coretactics.mlg @@ -333,7 +333,7 @@ open Tacexpr let initial_atomic () = let nocl = {onhyps=Some[];concl_occs=AllOccurrences} in let iter (s, t) = - let body = TacAtom (Loc.tag t) in + let body = TacAtom (CAst.make t) in Tacenv.register_ltac false false (Names.Id.of_string s) body in let () = List.iter iter @@ -348,7 +348,7 @@ let initial_atomic () = List.iter iter [ "idtac",TacId []; "fail", TacFail(TacLocal,ArgArg 0,[]); - "fresh", TacArg(Loc.tag @@ TacFreshId []) + "fresh", TacArg(CAst.make @@ TacFreshId []) ] let () = Mltop.declare_cache_obj initial_atomic "ltac_plugin" @@ -379,8 +379,8 @@ let initial_tacticals () = let varn n = Reference (ArgVar (CAst.make (idn n))) in let iter (s, t) = Tacenv.register_ltac false false (Id.of_string s) t in List.iter iter [ - "first", TacFun ([Name (idn 0)], TacML (None, (initial_entry "first", [varn 0]))); - "solve", TacFun ([Name (idn 0)], TacML (None, (initial_entry "solve", [varn 0]))); + "first", TacFun ([Name (idn 0)], TacML (CAst.make (initial_entry "first", [varn 0]))); + "solve", TacFun ([Name (idn 0)], TacML (CAst.make (initial_entry "solve", [varn 0]))); ] let () = Mltop.declare_cache_obj initial_tacticals "ltac_plugin" diff --git a/plugins/ltac/extratactics.mlg b/plugins/ltac/extratactics.mlg index 85fb0c73c9..603dd60cf2 100644 --- a/plugins/ltac/extratactics.mlg +++ b/plugins/ltac/extratactics.mlg @@ -31,6 +31,7 @@ open Tactypes open Tactics open Proofview.Notations open Attributes +open Vernacextend let wit_hyp = wit_var @@ -48,7 +49,6 @@ let with_delayed_uconstr ist c tac = let flags = { Pretyping.use_typeclasses = false; solve_unification_constraints = true; - use_hook = Pfedit.solve_by_implicit_tactic (); fail_evar = false; expand_evars = true } in @@ -316,7 +316,7 @@ let add_rewrite_hint ~poly bases ort t lcsr = let add_hints base = add_rew_rules base eqs in List.iter add_hints bases -let classify_hint _ = Vernacexpr.VtSideff [], Vernacexpr.VtLater +let classify_hint _ = VtSideff [], VtLater } @@ -343,7 +343,6 @@ open Vars let constr_flags () = { Pretyping.use_typeclasses = true; Pretyping.solve_unification_constraints = Pfedit.use_unification_heuristics (); - Pretyping.use_hook = Pfedit.solve_by_implicit_tactic (); Pretyping.fail_evar = false; Pretyping.expand_evars = true } @@ -400,7 +399,7 @@ END open Inv open Leminv -let seff id = Vernacexpr.VtSideff [id], Vernacexpr.VtLater +let seff id = VtSideff [id], VtLater } @@ -571,44 +570,6 @@ VERNAC COMMAND EXTEND AddStepr CLASSIFIED AS SIDEFF { add_transitivity_lemma false t } END -{ - -let cache_implicit_tactic (_,tac) = match tac with - | Some tac -> Pfedit.declare_implicit_tactic (Tacinterp.eval_tactic tac) - | None -> Pfedit.clear_implicit_tactic () - -let subst_implicit_tactic (subst,tac) = - Option.map (Tacsubst.subst_tactic subst) tac - -let inImplicitTactic : glob_tactic_expr option -> obj = - declare_object {(default_object "IMPLICIT-TACTIC") with - open_function = (fun i o -> if Int.equal i 1 then cache_implicit_tactic o); - cache_function = cache_implicit_tactic; - subst_function = subst_implicit_tactic; - classify_function = (fun o -> Dispose)} - -let warn_deprecated_implicit_tactic = - CWarnings.create ~name:"deprecated-implicit-tactic" ~category:"deprecated" - (fun () -> strbrk "Implicit tactics are deprecated") - -let declare_implicit_tactic tac = - let () = warn_deprecated_implicit_tactic () in - Lib.add_anonymous_leaf (inImplicitTactic (Some (Tacintern.glob_tactic tac))) - -let clear_implicit_tactic () = - let () = warn_deprecated_implicit_tactic () in - Lib.add_anonymous_leaf (inImplicitTactic None) - -} - -VERNAC COMMAND EXTEND ImplicitTactic CLASSIFIED AS SIDEFF -| [ "Declare" "Implicit" "Tactic" tactic(tac) ] -> { declare_implicit_tactic tac } -| [ "Clear" "Implicit" "Tactic" ] -> { clear_implicit_tactic () } -END - - - - (**********************************************************************) (* sozeau: abs/gen for induction on instantiated dependent inductives, using "Ford" induction as defined by Conor McBride *) @@ -807,7 +768,7 @@ let case_eq_intros_rewrite x = let rec find_a_destructable_match sigma t = let cl = induction_arg_of_quantified_hyp (NamedHyp (Id.of_string "x")) in let cl = [cl, (None, None), None], None in - let dest = TacAtom (Loc.tag @@ TacInductionDestruct(false, false, cl)) in + let dest = TacAtom (CAst.make @@ TacInductionDestruct(false, false, cl)) in match EConstr.kind sigma t with | Case (_,_,x,_) when closed0 sigma x -> if isVar sigma x then @@ -950,7 +911,7 @@ END mode. *) VERNAC COMMAND EXTEND GrabEvars | [ "Grab" "Existential" "Variables" ] - => { Vernac_classifier.classify_as_proofstep } + => { classify_as_proofstep } -> { Proof_global.simple_with_current_proof (fun _ p -> Proof.V82.grab_evars p) } END @@ -982,7 +943,7 @@ END (* Command to add every unshelved variables to the focus *) VERNAC COMMAND EXTEND Unshelve | [ "Unshelve" ] - => { Vernac_classifier.classify_as_proofstep } + => { classify_as_proofstep } -> { Proof_global.simple_with_current_proof (fun _ p -> Proof.unshelve p) } END @@ -1134,9 +1095,9 @@ END VERNAC COMMAND EXTEND OptimizeProof -| [ "Optimize" "Proof" ] => { Vernac_classifier.classify_as_proofstep } -> +| [ "Optimize" "Proof" ] => { classify_as_proofstep } -> { Proof_global.compact_the_proof () } -| [ "Optimize" "Heap" ] => { Vernac_classifier.classify_as_proofstep } -> +| [ "Optimize" "Heap" ] => { classify_as_proofstep } -> { Gc.compact () } END diff --git a/plugins/ltac/g_auto.mlg b/plugins/ltac/g_auto.mlg index 5af393a3e5..7be8f67616 100644 --- a/plugins/ltac/g_auto.mlg +++ b/plugins/ltac/g_auto.mlg @@ -55,7 +55,6 @@ let eval_uconstrs ist cs = let flags = { Pretyping.use_typeclasses = false; solve_unification_constraints = true; - use_hook = Pfedit.solve_by_implicit_tactic (); fail_evar = false; expand_evars = true } in diff --git a/plugins/ltac/g_ltac.mlg b/plugins/ltac/g_ltac.mlg index c58c8556c5..bd8a097154 100644 --- a/plugins/ltac/g_ltac.mlg +++ b/plugins/ltac/g_ltac.mlg @@ -33,7 +33,7 @@ open Pltac let fail_default_value = Locus.ArgArg 0 let arg_of_expr = function - TacArg (loc,a) -> a + TacArg { CAst.v } -> v | e -> Tacexp (e:raw_tactic_expr) let genarg_of_unit () = in_gen (rawwit Stdarg.wit_unit) () @@ -162,9 +162,9 @@ GRAMMAR EXTEND Gram | g=failkw; n = [ n = int_or_var -> { n } | -> { fail_default_value } ]; l = LIST0 message_token -> { TacFail (g,n,l) } | st = simple_tactic -> { st } - | a = tactic_arg -> { TacArg(Loc.tag ~loc a) } + | a = tactic_arg -> { TacArg(CAst.make ~loc a) } | r = reference; la = LIST0 tactic_arg_compat -> - { TacArg(Loc.tag ~loc @@ TacCall (Loc.tag ~loc (r,la))) } ] + { TacArg(CAst.make ~loc @@ TacCall (CAst.make ~loc (r,la))) } ] | "0" [ "("; a = tactic_expr; ")" -> { a } | "["; ">"; tg = tactic_then_gen; "]" -> { @@ -173,7 +173,7 @@ GRAMMAR EXTEND Gram | Some (t,tl) -> TacExtendTac(Array.of_list tf,t,tl) | None -> TacDispatch tf end } - | a = tactic_atom -> { TacArg (Loc.tag ~loc a) } ] ] + | a = tactic_atom -> { TacArg (CAst.make ~loc a) } ] ] ; failkw: [ [ IDENT "fail" -> { TacLocal } | IDENT "gfail" -> { TacGlobal } ] ] @@ -223,7 +223,7 @@ GRAMMAR EXTEND Gram ; tactic_atom: [ [ n = integer -> { TacGeneric (genarg_of_int n) } - | r = reference -> { TacCall (Loc.tag ~loc (r,[])) } + | r = reference -> { TacCall (CAst.make ~loc (r,[])) } | "()" -> { TacGeneric (genarg_of_unit ()) } ] ] ; match_key: @@ -367,8 +367,7 @@ GRAMMAR EXTEND Gram open Stdarg open Tacarg -open Vernacexpr -open Vernac_classifier +open Vernacextend open Goptions open Libnames diff --git a/plugins/ltac/g_obligations.mlg b/plugins/ltac/g_obligations.mlg index aa78fb5d1e..e29f78af5b 100644 --- a/plugins/ltac/g_obligations.mlg +++ b/plugins/ltac/g_obligations.mlg @@ -84,7 +84,7 @@ open Obligations let obligation obl tac = with_tac (fun t -> Obligations.obligation obl t) tac let next_obligation obl tac = with_tac (fun t -> Obligations.next_obligation obl t) tac -let classify_obbl _ = Vernacexpr.(VtStartProof ("Classic",Doesn'tGuaranteeOpacity,[]), VtLater) +let classify_obbl _ = Vernacextend.(VtStartProof ("Classic",Doesn'tGuaranteeOpacity,[]), VtLater) } diff --git a/plugins/ltac/g_rewrite.mlg b/plugins/ltac/g_rewrite.mlg index 1c7220ddc0..2596bc22f2 100644 --- a/plugins/ltac/g_rewrite.mlg +++ b/plugins/ltac/g_rewrite.mlg @@ -26,6 +26,7 @@ open Pcoq.Prim open Pcoq.Constr open Pvernac.Vernac_ open Pltac +open Vernacextend let wit_hyp = wit_var @@ -280,18 +281,18 @@ VERNAC COMMAND EXTEND AddSetoid1 CLASSIFIED AS SIDEFF } | #[ atts = rewrite_attributes; ] [ "Add" "Morphism" constr(m) ":" ident(n) ] (* This command may or may not open a goal *) - => { Vernacexpr.VtUnknown, Vernacexpr.VtNow } + => { VtUnknown, VtNow } -> { add_morphism_infer atts m n; } | #[ atts = rewrite_attributes; ] [ "Add" "Morphism" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] - => { Vernacexpr.(VtStartProof("Classic",GuaranteesOpacity,[n]), VtLater) } + => { VtStartProof("Classic",GuaranteesOpacity,[n]), VtLater } -> { add_morphism atts [] m s n; } | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Morphism" binders(binders) ":" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] - => { Vernacexpr.(VtStartProof("Classic",GuaranteesOpacity,[n]), VtLater) } + => { VtStartProof("Classic",GuaranteesOpacity,[n]), VtLater } -> { add_morphism atts binders m s n; } diff --git a/plugins/ltac/g_tactic.mlg b/plugins/ltac/g_tactic.mlg index 571595be70..0ce0fbd0cd 100644 --- a/plugins/ltac/g_tactic.mlg +++ b/plugins/ltac/g_tactic.mlg @@ -529,178 +529,178 @@ GRAMMAR EXTEND Gram [ [ (* Basic tactics *) IDENT "intros"; pl = ne_intropatterns -> - { TacAtom (Loc.tag ~loc @@ TacIntroPattern (false,pl)) } + { TacAtom (CAst.make ~loc @@ TacIntroPattern (false,pl)) } | IDENT "intros" -> - { TacAtom (Loc.tag ~loc @@ TacIntroPattern (false,[CAst.make ~loc @@IntroForthcoming false])) } + { TacAtom (CAst.make ~loc @@ TacIntroPattern (false,[CAst.make ~loc @@IntroForthcoming false])) } | IDENT "eintros"; pl = ne_intropatterns -> - { TacAtom (Loc.tag ~loc @@ TacIntroPattern (true,pl)) } + { TacAtom (CAst.make ~loc @@ TacIntroPattern (true,pl)) } | IDENT "apply"; cl = LIST1 constr_with_bindings_arg SEP ","; - inhyp = in_hyp_as -> { TacAtom (Loc.tag ~loc @@ TacApply (true,false,cl,inhyp)) } + inhyp = in_hyp_as -> { TacAtom (CAst.make ~loc @@ TacApply (true,false,cl,inhyp)) } | IDENT "eapply"; cl = LIST1 constr_with_bindings_arg SEP ","; - inhyp = in_hyp_as -> { TacAtom (Loc.tag ~loc @@ TacApply (true,true,cl,inhyp)) } + inhyp = in_hyp_as -> { TacAtom (CAst.make ~loc @@ TacApply (true,true,cl,inhyp)) } | IDENT "simple"; IDENT "apply"; cl = LIST1 constr_with_bindings_arg SEP ","; - inhyp = in_hyp_as -> { TacAtom (Loc.tag ~loc @@ TacApply (false,false,cl,inhyp)) } + inhyp = in_hyp_as -> { TacAtom (CAst.make ~loc @@ TacApply (false,false,cl,inhyp)) } | IDENT "simple"; IDENT "eapply"; cl = LIST1 constr_with_bindings_arg SEP","; - inhyp = in_hyp_as -> { TacAtom (Loc.tag ~loc @@ TacApply (false,true,cl,inhyp)) } + inhyp = in_hyp_as -> { TacAtom (CAst.make ~loc @@ TacApply (false,true,cl,inhyp)) } | IDENT "elim"; cl = constr_with_bindings_arg; el = OPT eliminator -> - { TacAtom (Loc.tag ~loc @@ TacElim (false,cl,el)) } + { TacAtom (CAst.make ~loc @@ TacElim (false,cl,el)) } | IDENT "eelim"; cl = constr_with_bindings_arg; el = OPT eliminator -> - { TacAtom (Loc.tag ~loc @@ TacElim (true,cl,el)) } - | IDENT "case"; icl = induction_clause_list -> { TacAtom (Loc.tag ~loc @@ mkTacCase false icl) } - | IDENT "ecase"; icl = induction_clause_list -> { TacAtom (Loc.tag ~loc @@ mkTacCase true icl) } + { TacAtom (CAst.make ~loc @@ TacElim (true,cl,el)) } + | IDENT "case"; icl = induction_clause_list -> { TacAtom (CAst.make ~loc @@ mkTacCase false icl) } + | IDENT "ecase"; icl = induction_clause_list -> { TacAtom (CAst.make ~loc @@ mkTacCase true icl) } | "fix"; id = ident; n = natural; "with"; fd = LIST1 fixdecl -> - { TacAtom (Loc.tag ~loc @@ TacMutualFix (id,n,List.map mk_fix_tac fd)) } + { TacAtom (CAst.make ~loc @@ TacMutualFix (id,n,List.map mk_fix_tac fd)) } | "cofix"; id = ident; "with"; fd = LIST1 cofixdecl -> - { TacAtom (Loc.tag ~loc @@ TacMutualCofix (id,List.map mk_cofix_tac fd)) } + { TacAtom (CAst.make ~loc @@ TacMutualCofix (id,List.map mk_cofix_tac fd)) } | IDENT "pose"; bl = bindings_with_parameters -> - { let (id,b) = bl in TacAtom (Loc.tag ~loc @@ TacLetTac (false,Names.Name.Name id,b,Locusops.nowhere,true,None)) } + { let (id,b) = bl in TacAtom (CAst.make ~loc @@ TacLetTac (false,Names.Name.Name id,b,Locusops.nowhere,true,None)) } | IDENT "pose"; b = constr; na = as_name -> - { TacAtom (Loc.tag ~loc @@ TacLetTac (false,na,b,Locusops.nowhere,true,None)) } + { TacAtom (CAst.make ~loc @@ TacLetTac (false,na,b,Locusops.nowhere,true,None)) } | IDENT "epose"; bl = bindings_with_parameters -> - { let (id,b) = bl in TacAtom (Loc.tag ~loc @@ TacLetTac (true,Names.Name id,b,Locusops.nowhere,true,None)) } + { let (id,b) = bl in TacAtom (CAst.make ~loc @@ TacLetTac (true,Names.Name id,b,Locusops.nowhere,true,None)) } | IDENT "epose"; b = constr; na = as_name -> - { TacAtom (Loc.tag ~loc @@ TacLetTac (true,na,b,Locusops.nowhere,true,None)) } + { TacAtom (CAst.make ~loc @@ TacLetTac (true,na,b,Locusops.nowhere,true,None)) } | IDENT "set"; bl = bindings_with_parameters; p = clause_dft_concl -> - { let (id,c) = bl in TacAtom (Loc.tag ~loc @@ TacLetTac (false,Names.Name.Name id,c,p,true,None)) } + { let (id,c) = bl in TacAtom (CAst.make ~loc @@ TacLetTac (false,Names.Name.Name id,c,p,true,None)) } | IDENT "set"; c = constr; na = as_name; p = clause_dft_concl -> - { TacAtom (Loc.tag ~loc @@ TacLetTac (false,na,c,p,true,None)) } + { TacAtom (CAst.make ~loc @@ TacLetTac (false,na,c,p,true,None)) } | IDENT "eset"; bl = bindings_with_parameters; p = clause_dft_concl -> - { let (id,c) = bl in TacAtom (Loc.tag ~loc @@ TacLetTac (true,Names.Name id,c,p,true,None)) } + { let (id,c) = bl in TacAtom (CAst.make ~loc @@ TacLetTac (true,Names.Name id,c,p,true,None)) } | IDENT "eset"; c = constr; na = as_name; p = clause_dft_concl -> - { TacAtom (Loc.tag ~loc @@ TacLetTac (true,na,c,p,true,None)) } + { TacAtom (CAst.make ~loc @@ TacLetTac (true,na,c,p,true,None)) } | IDENT "remember"; c = constr; na = as_name; e = eqn_ipat; p = clause_dft_all -> - { TacAtom (Loc.tag ~loc @@ TacLetTac (false,na,c,p,false,e)) } + { TacAtom (CAst.make ~loc @@ TacLetTac (false,na,c,p,false,e)) } | IDENT "eremember"; c = constr; na = as_name; e = eqn_ipat; p = clause_dft_all -> - { TacAtom (Loc.tag ~loc @@ TacLetTac (true,na,c,p,false,e)) } + { TacAtom (CAst.make ~loc @@ TacLetTac (true,na,c,p,false,e)) } (* Alternative syntax for "pose proof c as id" *) | IDENT "assert"; test_lpar_id_coloneq; "("; lid = identref; ":="; c = lconstr; ")" -> { let { CAst.loc = loc; v = id } = lid in - TacAtom (Loc.tag ?loc @@ TacAssert (false,true,None,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) } + TacAtom (CAst.make ?loc @@ TacAssert (false,true,None,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) } | IDENT "eassert"; test_lpar_id_coloneq; "("; lid = identref; ":="; c = lconstr; ")" -> { let { CAst.loc = loc; v = id } = lid in - TacAtom (Loc.tag ?loc @@ TacAssert (true,true,None,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) } + TacAtom (CAst.make ?loc @@ TacAssert (true,true,None,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) } (* Alternative syntax for "assert c as id by tac" *) | IDENT "assert"; test_lpar_id_colon; "("; lid = identref; ":"; c = lconstr; ")"; tac=by_tactic -> { let { CAst.loc = loc; v = id } = lid in - TacAtom (Loc.tag ?loc @@ TacAssert (false,true,Some tac,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) } + TacAtom (CAst.make ?loc @@ TacAssert (false,true,Some tac,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) } | IDENT "eassert"; test_lpar_id_colon; "("; lid = identref; ":"; c = lconstr; ")"; tac=by_tactic -> { let { CAst.loc = loc; v = id } = lid in - TacAtom (Loc.tag ?loc @@ TacAssert (true,true,Some tac,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) } + TacAtom (CAst.make ?loc @@ TacAssert (true,true,Some tac,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) } (* Alternative syntax for "enough c as id by tac" *) | IDENT "enough"; test_lpar_id_colon; "("; lid = identref; ":"; c = lconstr; ")"; tac=by_tactic -> { let { CAst.loc = loc; v = id } = lid in - TacAtom (Loc.tag ?loc @@ TacAssert (false,false,Some tac,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) } + TacAtom (CAst.make ?loc @@ TacAssert (false,false,Some tac,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) } | IDENT "eenough"; test_lpar_id_colon; "("; lid = identref; ":"; c = lconstr; ")"; tac=by_tactic -> { let { CAst.loc = loc; v = id } = lid in - TacAtom (Loc.tag ?loc @@ TacAssert (true,false,Some tac,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) } + TacAtom (CAst.make ?loc @@ TacAssert (true,false,Some tac,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) } | IDENT "assert"; c = constr; ipat = as_ipat; tac = by_tactic -> - { TacAtom (Loc.tag ~loc @@ TacAssert (false,true,Some tac,ipat,c)) } + { TacAtom (CAst.make ~loc @@ TacAssert (false,true,Some tac,ipat,c)) } | IDENT "eassert"; c = constr; ipat = as_ipat; tac = by_tactic -> - { TacAtom (Loc.tag ~loc @@ TacAssert (true,true,Some tac,ipat,c)) } + { TacAtom (CAst.make ~loc @@ TacAssert (true,true,Some tac,ipat,c)) } | IDENT "pose"; IDENT "proof"; c = lconstr; ipat = as_ipat -> - { TacAtom (Loc.tag ~loc @@ TacAssert (false,true,None,ipat,c)) } + { TacAtom (CAst.make ~loc @@ TacAssert (false,true,None,ipat,c)) } | IDENT "epose"; IDENT "proof"; c = lconstr; ipat = as_ipat -> - { TacAtom (Loc.tag ~loc @@ TacAssert (true,true,None,ipat,c)) } + { TacAtom (CAst.make ~loc @@ TacAssert (true,true,None,ipat,c)) } | IDENT "enough"; c = constr; ipat = as_ipat; tac = by_tactic -> - { TacAtom (Loc.tag ~loc @@ TacAssert (false,false,Some tac,ipat,c)) } + { TacAtom (CAst.make ~loc @@ TacAssert (false,false,Some tac,ipat,c)) } | IDENT "eenough"; c = constr; ipat = as_ipat; tac = by_tactic -> - { TacAtom (Loc.tag ~loc @@ TacAssert (true,false,Some tac,ipat,c)) } + { TacAtom (CAst.make ~loc @@ TacAssert (true,false,Some tac,ipat,c)) } | IDENT "generalize"; c = constr -> - { TacAtom (Loc.tag ~loc @@ TacGeneralize [((AllOccurrences,c),Names.Name.Anonymous)]) } + { TacAtom (CAst.make ~loc @@ TacGeneralize [((AllOccurrences,c),Names.Name.Anonymous)]) } | IDENT "generalize"; c = constr; l = LIST1 constr -> { let gen_everywhere c = ((AllOccurrences,c),Names.Name.Anonymous) in - TacAtom (Loc.tag ~loc @@ TacGeneralize (List.map gen_everywhere (c::l))) } + TacAtom (CAst.make ~loc @@ TacGeneralize (List.map gen_everywhere (c::l))) } | IDENT "generalize"; c = constr; lookup_at_as_comma; nl = occs; na = as_name; l = LIST0 [","; c = pattern_occ; na = as_name -> { (c,na) } ] -> - { TacAtom (Loc.tag ~loc @@ TacGeneralize (((nl,c),na)::l)) } + { TacAtom (CAst.make ~loc @@ TacGeneralize (((nl,c),na)::l)) } (* Derived basic tactics *) | IDENT "induction"; ic = induction_clause_list -> - { TacAtom (Loc.tag ~loc @@ TacInductionDestruct (true,false,ic)) } + { TacAtom (CAst.make ~loc @@ TacInductionDestruct (true,false,ic)) } | IDENT "einduction"; ic = induction_clause_list -> - { TacAtom (Loc.tag ~loc @@ TacInductionDestruct(true,true,ic)) } + { TacAtom (CAst.make ~loc @@ TacInductionDestruct(true,true,ic)) } | IDENT "destruct"; icl = induction_clause_list -> - { TacAtom (Loc.tag ~loc @@ TacInductionDestruct(false,false,icl)) } + { TacAtom (CAst.make ~loc @@ TacInductionDestruct(false,false,icl)) } | IDENT "edestruct"; icl = induction_clause_list -> - { TacAtom (Loc.tag ~loc @@ TacInductionDestruct(false,true,icl)) } + { TacAtom (CAst.make ~loc @@ TacInductionDestruct(false,true,icl)) } (* Equality and inversion *) | IDENT "rewrite"; l = LIST1 oriented_rewriter SEP ","; - cl = clause_dft_concl; t=by_tactic -> { TacAtom (Loc.tag ~loc @@ TacRewrite (false,l,cl,t)) } + cl = clause_dft_concl; t=by_tactic -> { TacAtom (CAst.make ~loc @@ TacRewrite (false,l,cl,t)) } | IDENT "erewrite"; l = LIST1 oriented_rewriter SEP ","; - cl = clause_dft_concl; t=by_tactic -> { TacAtom (Loc.tag ~loc @@ TacRewrite (true,l,cl,t)) } + cl = clause_dft_concl; t=by_tactic -> { TacAtom (CAst.make ~loc @@ TacRewrite (true,l,cl,t)) } | IDENT "dependent"; k = [ IDENT "simple"; IDENT "inversion" -> { SimpleInversion } | IDENT "inversion" -> { FullInversion } | IDENT "inversion_clear" -> { FullInversionClear } ]; hyp = quantified_hypothesis; ids = as_or_and_ipat; co = OPT ["with"; c = constr -> { c } ] -> - { TacAtom (Loc.tag ~loc @@ TacInversion (DepInversion (k,co,ids),hyp)) } + { TacAtom (CAst.make ~loc @@ TacInversion (DepInversion (k,co,ids),hyp)) } | IDENT "simple"; IDENT "inversion"; hyp = quantified_hypothesis; ids = as_or_and_ipat; cl = in_hyp_list -> - { TacAtom (Loc.tag ~loc @@ TacInversion (NonDepInversion (SimpleInversion, cl, ids), hyp)) } + { TacAtom (CAst.make ~loc @@ TacInversion (NonDepInversion (SimpleInversion, cl, ids), hyp)) } | IDENT "inversion"; hyp = quantified_hypothesis; ids = as_or_and_ipat; cl = in_hyp_list -> - { TacAtom (Loc.tag ~loc @@ TacInversion (NonDepInversion (FullInversion, cl, ids), hyp)) } + { TacAtom (CAst.make ~loc @@ TacInversion (NonDepInversion (FullInversion, cl, ids), hyp)) } | IDENT "inversion_clear"; hyp = quantified_hypothesis; ids = as_or_and_ipat; cl = in_hyp_list -> - { TacAtom (Loc.tag ~loc @@ TacInversion (NonDepInversion (FullInversionClear, cl, ids), hyp)) } + { TacAtom (CAst.make ~loc @@ TacInversion (NonDepInversion (FullInversionClear, cl, ids), hyp)) } | IDENT "inversion"; hyp = quantified_hypothesis; "using"; c = constr; cl = in_hyp_list -> - { TacAtom (Loc.tag ~loc @@ TacInversion (InversionUsing (c,cl), hyp)) } + { TacAtom (CAst.make ~loc @@ TacInversion (InversionUsing (c,cl), hyp)) } (* Conversion *) | IDENT "red"; cl = clause_dft_concl -> - { TacAtom (Loc.tag ~loc @@ TacReduce (Red false, cl)) } + { TacAtom (CAst.make ~loc @@ TacReduce (Red false, cl)) } | IDENT "hnf"; cl = clause_dft_concl -> - { TacAtom (Loc.tag ~loc @@ TacReduce (Hnf, cl)) } + { TacAtom (CAst.make ~loc @@ TacReduce (Hnf, cl)) } | IDENT "simpl"; d = delta_flag; po = OPT ref_or_pattern_occ; cl = clause_dft_concl -> - { TacAtom (Loc.tag ~loc @@ TacReduce (Simpl (all_with d, po), cl)) } + { TacAtom (CAst.make ~loc @@ TacReduce (Simpl (all_with d, po), cl)) } | IDENT "cbv"; s = strategy_flag; cl = clause_dft_concl -> - { TacAtom (Loc.tag ~loc @@ TacReduce (Cbv s, cl)) } + { TacAtom (CAst.make ~loc @@ TacReduce (Cbv s, cl)) } | IDENT "cbn"; s = strategy_flag; cl = clause_dft_concl -> - { TacAtom (Loc.tag ~loc @@ TacReduce (Cbn s, cl)) } + { TacAtom (CAst.make ~loc @@ TacReduce (Cbn s, cl)) } | IDENT "lazy"; s = strategy_flag; cl = clause_dft_concl -> - { TacAtom (Loc.tag ~loc @@ TacReduce (Lazy s, cl)) } + { TacAtom (CAst.make ~loc @@ TacReduce (Lazy s, cl)) } | IDENT "compute"; delta = delta_flag; cl = clause_dft_concl -> - { TacAtom (Loc.tag ~loc @@ TacReduce (Cbv (all_with delta), cl)) } + { TacAtom (CAst.make ~loc @@ TacReduce (Cbv (all_with delta), cl)) } | IDENT "vm_compute"; po = OPT ref_or_pattern_occ; cl = clause_dft_concl -> - { TacAtom (Loc.tag ~loc @@ TacReduce (CbvVm po, cl)) } + { TacAtom (CAst.make ~loc @@ TacReduce (CbvVm po, cl)) } | IDENT "native_compute"; po = OPT ref_or_pattern_occ; cl = clause_dft_concl -> - { TacAtom (Loc.tag ~loc @@ TacReduce (CbvNative po, cl)) } + { TacAtom (CAst.make ~loc @@ TacReduce (CbvNative po, cl)) } | IDENT "unfold"; ul = LIST1 unfold_occ SEP ","; cl = clause_dft_concl -> - { TacAtom (Loc.tag ~loc @@ TacReduce (Unfold ul, cl)) } + { TacAtom (CAst.make ~loc @@ TacReduce (Unfold ul, cl)) } | IDENT "fold"; l = LIST1 constr; cl = clause_dft_concl -> - { TacAtom (Loc.tag ~loc @@ TacReduce (Fold l, cl)) } + { TacAtom (CAst.make ~loc @@ TacReduce (Fold l, cl)) } | IDENT "pattern"; pl = LIST1 pattern_occ SEP","; cl = clause_dft_concl -> - { TacAtom (Loc.tag ~loc @@ TacReduce (Pattern pl, cl)) } + { TacAtom (CAst.make ~loc @@ TacReduce (Pattern pl, cl)) } (* Change ne doit pas s'appliquer dans un Definition t := Eval ... *) | IDENT "change"; c = conversion; cl = clause_dft_concl -> { let (oc, c) = c in let p,cl = merge_occurrences loc cl oc in - TacAtom (Loc.tag ~loc @@ TacChange (p,c,cl)) } + TacAtom (CAst.make ~loc @@ TacChange (p,c,cl)) } ] ] ; END diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index b219ee25ca..50cfb6d004 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -294,7 +294,7 @@ let string_of_genarg_arg (ArgumentType arg) = let pr _ = str "_" in KerName.print key ++ spc() ++ pr_sequence pr l ++ str" (* Generic printer *)" - let pr_farg prtac arg = prtac (1, Any) (TacArg (Loc.tag arg)) + let pr_farg prtac arg = prtac (1, Any) (TacArg (CAst.make arg)) let is_genarg tag wit = let ArgT.Any tag = tag in @@ -350,9 +350,9 @@ let string_of_genarg_arg (ArgumentType arg) = pr_extend_gen (pr_farg prtac) let pr_raw_alias prtac lev key args = - pr_alias_gen (pr_targ (fun l a -> prtac l (TacArg (Loc.tag a)))) lev key args + pr_alias_gen (pr_targ (fun l a -> prtac l (TacArg (CAst.make a)))) lev key args let pr_glob_alias prtac lev key args = - pr_alias_gen (pr_targ (fun l a -> prtac l (TacArg (Loc.tag a)))) lev key args + pr_alias_gen (pr_targ (fun l a -> prtac l (TacArg (CAst.make a)))) lev key args (**********************************************************************) (* The tactic printer *) @@ -579,7 +579,7 @@ let pr_goal_selector ~toplevel s = pr_gen arg else str name ++ str ":" ++ surround (pr_gen arg) - | _ -> pr_arg (TacArg (Loc.tag t)) in + | _ -> pr_arg (TacArg (CAst.make t)) in hov 0 (keyword k ++ spc () ++ pr_lname na ++ prlist pr_funvar bl ++ str " :=" ++ brk (1,1) ++ pr t) @@ -1045,30 +1045,30 @@ let pr_goal_selector ~toplevel s = | TacSelect (s, tac) -> pr_goal_selector ~toplevel:false s ++ spc () ++ pr_tac ltop tac, latom | TacId l -> keyword "idtac" ++ prlist (pr_arg (pr_message_token pr.pr_name)) l, latom - | TacAtom (loc,t) -> + | TacAtom { CAst.loc; v=t } -> pr_with_comments ?loc (hov 1 (pr_atom pr strip_prod_binders tag_atom t)), ltatom - | TacArg(_,Tacexp e) -> + | TacArg { CAst.v=Tacexp e } -> pr_tac inherited e, latom - | TacArg(_,ConstrMayEval (ConstrTerm c)) -> + | TacArg { CAst.v=ConstrMayEval (ConstrTerm c) } -> keyword "constr:" ++ pr.pr_constr c, latom - | TacArg(_,ConstrMayEval c) -> + | TacArg { CAst.v=ConstrMayEval c } -> pr_may_eval pr.pr_constr pr.pr_lconstr pr.pr_constant pr.pr_pattern c, leval - | TacArg(_,TacFreshId l) -> + | TacArg { CAst.v=TacFreshId l } -> primitive "fresh" ++ pr_fresh_ids l, latom - | TacArg(_,TacGeneric arg) -> + | TacArg { CAst.v=TacGeneric arg } -> pr.pr_generic arg, latom - | TacArg(_,TacCall(_,(f,[]))) -> + | TacArg { CAst.v=TacCall {CAst.v=(f,[])} } -> pr.pr_reference f, latom - | TacArg(_,TacCall(loc,(f,l))) -> + | TacArg { CAst.v=TacCall {CAst.loc; v=(f,l)} } -> pr_with_comments ?loc (hov 1 ( pr.pr_reference f ++ spc () ++ prlist_with_sep spc pr_tacarg l)), lcall - | TacArg (_,a) -> + | TacArg { CAst.v=a } -> pr_tacarg a, latom - | TacML (loc,(s,l)) -> + | TacML { CAst.loc; v=(s,l) } -> pr_with_comments ?loc (pr.pr_extend 1 s l), lcall - | TacAlias (loc,(kn,l)) -> + | TacAlias { CAst.loc; v=(kn,l) } -> pr_with_comments ?loc (pr.pr_alias (level_of inherited) kn l), latom ) in @@ -1087,7 +1087,7 @@ let pr_goal_selector ~toplevel s = | TacNumgoals -> keyword "numgoals" | (TacCall _|Tacexp _ | TacGeneric _) as a -> - hov 0 (keyword "ltac:" ++ surround (pr_tac ltop (TacArg (Loc.tag a)))) + hov 0 (keyword "ltac:" ++ surround (pr_tac ltop (TacArg (CAst.make a)))) in pr_tac diff --git a/plugins/ltac/profile_ltac.ml b/plugins/ltac/profile_ltac.ml index db7dcfa6ef..3eb049dbab 100644 --- a/plugins/ltac/profile_ltac.ml +++ b/plugins/ltac/profile_ltac.ml @@ -251,7 +251,7 @@ let string_of_call ck = | Tacexpr.LtacVarCall (id, t) -> Names.Id.print id | Tacexpr.LtacAtomCall te -> (Pptactic.pr_glob_tactic (Global.env ()) - (Tacexpr.TacAtom (Loc.tag te))) + (Tacexpr.TacAtom (CAst.make te))) | Tacexpr.LtacConstrInterp (c, _) -> pr_glob_constr_env (Global.env ()) c | Tacexpr.LtacMLCall te -> diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 7d917c58fe..fee469032c 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -528,7 +528,7 @@ let decompose_applied_relation env sigma (c,l) = let rewrite_db = "rewrite" -let conv_transparent_state = (Id.Pred.empty, Cpred.full) +let conv_transparent_state = TransparentState.cst_full let rewrite_transparent_state () = Hints.Hint_db.transparent_state (Hints.searchtable_map rewrite_db) @@ -537,8 +537,8 @@ let rewrite_core_unif_flags = { Unification.modulo_conv_on_closed_terms = None; Unification.use_metas_eagerly_in_conv_on_closed_terms = true; Unification.use_evars_eagerly_in_conv_on_closed_terms = true; - Unification.modulo_delta = empty_transparent_state; - Unification.modulo_delta_types = full_transparent_state; + Unification.modulo_delta = TransparentState.empty; + Unification.modulo_delta_types = TransparentState.full; Unification.check_applied_meta_types = true; Unification.use_pattern_unification = true; Unification.use_meta_bound_pattern_unification = true; @@ -585,12 +585,12 @@ let general_rewrite_unif_flags () = Unification.modulo_conv_on_closed_terms = Some ts; Unification.use_evars_eagerly_in_conv_on_closed_terms = true; Unification.modulo_delta = ts; - Unification.modulo_delta_types = full_transparent_state; + Unification.modulo_delta_types = TransparentState.full; Unification.modulo_betaiota = true } in { Unification.core_unify_flags = core_flags; Unification.merge_unify_flags = core_flags; - Unification.subterm_unify_flags = { core_flags with Unification.modulo_delta = empty_transparent_state }; + Unification.subterm_unify_flags = { core_flags with Unification.modulo_delta = TransparentState.empty }; Unification.allow_K_in_toplevel_higher_order_unification = true; Unification.resolve_evars = true } @@ -1958,7 +1958,7 @@ let add_setoid atts binders a aeq t n = let make_tactic name = let open Tacexpr in let tacqid = Libnames.qualid_of_string name in - TacArg (Loc.tag @@ (TacCall (Loc.tag (tacqid, [])))) + TacArg (CAst.make @@ (TacCall (CAst.make (tacqid, [])))) let warn_add_morphism_deprecated = CWarnings.create ~name:"add-morphism" ~category:"deprecated" (fun () -> diff --git a/plugins/ltac/tacentries.ml b/plugins/ltac/tacentries.ml index 1b212334ce..188d5de7de 100644 --- a/plugins/ltac/tacentries.ml +++ b/plugins/ltac/tacentries.ml @@ -177,7 +177,7 @@ let add_tactic_entry (kn, ml, tg) state = TacGeneric arg in let l = List.map map l in - (TacAlias (Loc.tag ~loc (kn,l)):raw_tactic_expr) + (TacAlias (CAst.make ~loc (kn,l)):raw_tactic_expr) in let () = if Int.equal tg.tacgram_level 0 && not (head_is_ident tg) then @@ -349,7 +349,7 @@ let extend_atomic_tactic name entries = | TacNonTerm (_, (symb, _)) -> let EntryName (typ, e) = prod_item_of_symbol 0 symb in let Genarg.Rawwit wit = typ in - let inj x = TacArg (Loc.tag @@ TacGeneric (Genarg.in_gen typ x)) in + let inj x = TacArg (CAst.make @@ TacGeneric (Genarg.in_gen typ x)) in let default = epsilon_value inj e in match default with | None -> raise NonEmptyArgument @@ -363,7 +363,7 @@ let extend_atomic_tactic name entries = | Some (id, args) -> let args = List.map (fun a -> Tacexp a) args in let entry = { mltac_name = name; mltac_index = i } in - let body = TacML (Loc.tag (entry, args)) in + let body = TacML (CAst.make (entry, args)) in Tacenv.register_ltac false false (Names.Id.of_string id) body in List.iteri add_atomic entries @@ -379,7 +379,7 @@ let add_ml_tactic_notation name ~level ?deprecation prods = let ids = List.map_filter get_id prods in let entry = { mltac_name = name; mltac_index = len - i - 1 } in let map id = Reference (Locus.ArgVar (CAst.make id)) in - let tac = TacML (Loc.tag (entry, List.map map ids)) in + let tac = TacML (CAst.make (entry, List.map map ids)) in add_glob_tactic_notation false ~level ?deprecation prods true ids tac in List.iteri iter (List.rev prods); @@ -664,7 +664,7 @@ let tactic_extend plugin_name tacname ~level ?deprecation sign = (** Arguments are not passed directly to the ML tactic in the TacML node, the ML tactic retrieves its arguments in the [ist] environment instead. This is the rôle of the [lift_constr_tac_to_ml_tac] function. *) - let body = Tacexpr.TacFun (vars, Tacexpr.TacML (Loc.tag (ml, [])))in + let body = Tacexpr.TacFun (vars, Tacexpr.TacML (CAst.make (ml, [])))in let id = Names.Id.of_string name in let obj () = Tacenv.register_ltac true false id body ?deprecation in let () = Tacenv.register_ml_tactic ml_tactic_name [|tac|] in diff --git a/plugins/ltac/tacexpr.ml b/plugins/ltac/tacexpr.ml index 8731cbf60d..9435d0b911 100644 --- a/plugins/ltac/tacexpr.ml +++ b/plugins/ltac/tacexpr.ml @@ -167,7 +167,7 @@ type 'a gen_tactic_arg = | TacGeneric of 'lev generic_argument | ConstrMayEval of ('trm,'cst,'pat) may_eval | Reference of 'ref - | TacCall of ('ref * 'a gen_tactic_arg list) Loc.located + | TacCall of ('ref * 'a gen_tactic_arg list) CAst.t | TacFreshId of string or_var list | Tacexp of 'tacexpr | TacPretype of 'trm @@ -189,7 +189,7 @@ constraint 'a = < 'r : ltac refs, 'n : idents, 'l : levels *) and 'a gen_tactic_expr = - | TacAtom of ('a gen_atomic_tactic_expr) Loc.located + | TacAtom of ('a gen_atomic_tactic_expr) CAst.t | TacThen of 'a gen_tactic_expr * 'a gen_tactic_expr @@ -245,12 +245,12 @@ and 'a gen_tactic_expr = | TacMatchGoal of lazy_flag * direction_flag * ('p,'a gen_tactic_expr) match_rule list | TacFun of 'a gen_tactic_fun_ast - | TacArg of 'a gen_tactic_arg located + | TacArg of 'a gen_tactic_arg CAst.t | TacSelect of Goal_select.t * 'a gen_tactic_expr (* For ML extensions *) - | TacML of (ml_tactic_entry * 'a gen_tactic_arg list) Loc.located + | TacML of (ml_tactic_entry * 'a gen_tactic_arg list) CAst.t (* For syntax extensions *) - | TacAlias of (KerName.t * 'a gen_tactic_arg list) Loc.located + | TacAlias of (KerName.t * 'a gen_tactic_arg list) CAst.t constraint 'a = < term:'t; diff --git a/plugins/ltac/tacexpr.mli b/plugins/ltac/tacexpr.mli index 9958d6dcda..1527724420 100644 --- a/plugins/ltac/tacexpr.mli +++ b/plugins/ltac/tacexpr.mli @@ -167,7 +167,7 @@ type 'a gen_tactic_arg = | TacGeneric of 'lev generic_argument | ConstrMayEval of ('trm,'cst,'pat) may_eval | Reference of 'ref - | TacCall of ('ref * 'a gen_tactic_arg list) Loc.located + | TacCall of ('ref * 'a gen_tactic_arg list) CAst.t | TacFreshId of string or_var list | Tacexp of 'tacexpr | TacPretype of 'trm @@ -189,7 +189,7 @@ constraint 'a = < 'r : ltac refs, 'n : idents, 'l : levels *) and 'a gen_tactic_expr = - | TacAtom of ('a gen_atomic_tactic_expr) Loc.located + | TacAtom of ('a gen_atomic_tactic_expr) CAst.t | TacThen of 'a gen_tactic_expr * 'a gen_tactic_expr @@ -245,12 +245,12 @@ and 'a gen_tactic_expr = | TacMatchGoal of lazy_flag * direction_flag * ('p,'a gen_tactic_expr) match_rule list | TacFun of 'a gen_tactic_fun_ast - | TacArg of 'a gen_tactic_arg located + | TacArg of 'a gen_tactic_arg CAst.t | TacSelect of Goal_select.t * 'a gen_tactic_expr (* For ML extensions *) - | TacML of (ml_tactic_entry * 'a gen_tactic_arg list) Loc.located + | TacML of (ml_tactic_entry * 'a gen_tactic_arg list) CAst.t (* For syntax extensions *) - | TacAlias of (KerName.t * 'a gen_tactic_arg list) Loc.located + | TacAlias of (KerName.t * 'a gen_tactic_arg list) CAst.t constraint 'a = < term:'t; diff --git a/plugins/ltac/tacintern.ml b/plugins/ltac/tacintern.ml index ebec3c887c..85c6348b52 100644 --- a/plugins/ltac/tacintern.ml +++ b/plugins/ltac/tacintern.ml @@ -137,7 +137,7 @@ let intern_isolated_global_tactic_reference qid = let kn = Tacenv.locate_tactic qid in Option.iter (fun depr -> warn_deprecated_tactic ?loc (qid,depr)) @@ Tacenv.tac_deprecation kn; - TacCall (Loc.tag ?loc (ArgArg (loc,kn),[])) + TacCall (CAst.make ?loc (ArgArg (loc,kn),[])) let intern_isolated_tactic_reference strict ist qid = (* An ltac reference *) @@ -587,10 +587,10 @@ let rec intern_atomic lf ist x = and intern_tactic onlytac ist tac = snd (intern_tactic_seq onlytac ist tac) and intern_tactic_seq onlytac ist = function - | TacAtom (loc,t) -> + | TacAtom { loc; v=t } -> let lf = ref ist.ltacvars in let t = intern_atomic lf ist t in - !lf, TacAtom (Loc.tag ?loc:(adjust_loc loc) t) + !lf, TacAtom (CAst.make ?loc:(adjust_loc loc) t) | TacFun tacfun -> ist.ltacvars, TacFun (intern_tactic_fun ist tacfun) | TacLetIn (isrec,l,u) -> let ltacvars = Id.Set.union (extract_let_names l) ist.ltacvars in @@ -659,27 +659,27 @@ and intern_tactic_seq onlytac ist = function | TacFirst l -> ist.ltacvars, TacFirst (List.map (intern_pure_tactic ist) l) | TacSolve l -> ist.ltacvars, TacSolve (List.map (intern_pure_tactic ist) l) | TacComplete tac -> ist.ltacvars, TacComplete (intern_pure_tactic ist tac) - | TacArg (loc,a) -> ist.ltacvars, intern_tactic_as_arg loc onlytac ist a + | TacArg { loc; v=a } -> ist.ltacvars, intern_tactic_as_arg loc onlytac ist a | TacSelect (sel, tac) -> ist.ltacvars, TacSelect (sel, intern_pure_tactic ist tac) (* For extensions *) - | TacAlias (loc,(s,l)) -> + | TacAlias { loc; v=(s,l) } -> let alias = Tacenv.interp_alias s in Option.iter (fun o -> warn_deprecated_alias ?loc (s,o)) @@ alias.Tacenv.alias_deprecation; let l = List.map (intern_tacarg !strict_check false ist) l in - ist.ltacvars, TacAlias (Loc.tag ?loc (s,l)) - | TacML (loc,(opn,l)) -> + ist.ltacvars, TacAlias (CAst.make ?loc (s,l)) + | TacML { loc; v=(opn,l) } -> let _ignore = Tacenv.interp_ml_tactic opn in - ist.ltacvars, TacML (loc, (opn,List.map (intern_tacarg !strict_check false ist) l)) + ist.ltacvars, TacML CAst.(make ?loc (opn,List.map (intern_tacarg !strict_check false ist) l)) and intern_tactic_as_arg loc onlytac ist a = match intern_tacarg !strict_check onlytac ist a with | TacCall _ | Reference _ - | TacGeneric _ as a -> TacArg (loc,a) + | TacGeneric _ as a -> TacArg CAst.(make ?loc a) | Tacexp a -> a | ConstrMayEval _ | TacFreshId _ | TacPretype _ | TacNumgoals as a -> - if onlytac then error_tactic_expected ?loc else TacArg (loc,a) + if onlytac then error_tactic_expected ?loc else TacArg CAst.(make ?loc a) and intern_tactic_or_tacarg ist = intern_tactic false ist @@ -692,9 +692,9 @@ and intern_tactic_fun ist (var,body) = and intern_tacarg strict onlytac ist = function | Reference r -> intern_non_tactic_reference strict ist r | ConstrMayEval c -> ConstrMayEval (intern_constr_may_eval ist c) - | TacCall (loc,(f,[])) -> intern_isolated_tactic_reference strict ist f - | TacCall (loc,(f,l)) -> - TacCall (Loc.tag ?loc ( + | TacCall { loc; v=(f,[]) } -> intern_isolated_tactic_reference strict ist f + | TacCall { loc; v=(f,l) } -> + TacCall (CAst.make ?loc ( intern_applied_tactic_reference ist f, List.map (intern_tacarg !strict_check false ist) l)) | TacFreshId x -> TacFreshId (List.map (intern_string_or_var ist) x) diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index 2a046a3e65..cb3a0aaed9 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -543,7 +543,6 @@ let interp_gen kind ist pattern_mode flags env sigma c = let constr_flags () = { use_typeclasses = true; solve_unification_constraints = true; - use_hook = Pfedit.solve_by_implicit_tactic (); fail_evar = true; expand_evars = true } @@ -558,21 +557,18 @@ let interp_type = interp_constr_gen IsType let open_constr_use_classes_flags () = { use_typeclasses = true; solve_unification_constraints = true; - use_hook = Pfedit.solve_by_implicit_tactic (); fail_evar = false; expand_evars = true } let open_constr_no_classes_flags () = { use_typeclasses = false; solve_unification_constraints = true; - use_hook = Pfedit.solve_by_implicit_tactic (); fail_evar = false; expand_evars = true } let pure_open_constr_flags = { use_typeclasses = false; solve_unification_constraints = true; - use_hook = None; fail_evar = false; expand_evars = false } @@ -987,7 +983,7 @@ let rec read_match_rule lfun ist env sigma = function | [] -> [] (* Fully evaluate an untyped constr *) -let type_uconstr ?(flags = {(constr_flags ()) with use_hook = None }) +let type_uconstr ?(flags = (constr_flags ())) ?(expected_type = WithoutTypeConstraint) ist c = begin fun env sigma -> let { closure; term } = c in @@ -1022,7 +1018,7 @@ let rec val_interp ist ?(appl=UnnamedAppl) (tac:glob_tactic_expr) : Val.t Ftacti | TacLetIn (false,l,u) -> interp_letin ist l u | TacMatchGoal (lz,lr,lmr) -> interp_match_goal ist lz lr lmr | TacMatch (lz,c,lmr) -> interp_match ist lz c lmr - | TacArg (loc,a) -> interp_tacarg ist a + | TacArg {loc;v} -> interp_tacarg ist v | t -> (** Delayed evaluation *) Ftactic.return (of_tacvalue (VFun (UnnamedAppl,extract_trace ist, ist.lfun, [], t))) @@ -1040,7 +1036,7 @@ let rec val_interp ist ?(appl=UnnamedAppl) (tac:glob_tactic_expr) : Val.t Ftacti and eval_tactic ist tac : unit Proofview.tactic = match tac with - | TacAtom (loc,t) -> + | TacAtom {loc;v=t} -> let call = LtacAtomCall t in push_trace(loc,call) ist >>= fun trace -> Profile_ltac.do_profile "eval_tactic:2" trace @@ -1120,7 +1116,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with eval_tactic ist tac | TacSelect (sel, tac) -> Tacticals.New.tclSELECT sel (interp_tactic ist tac) (* For extensions *) - | TacAlias (loc,(s,l)) -> + | TacAlias {loc; v=(s,l)} -> let alias = Tacenv.interp_alias s in let (>>=) = Ftactic.bind in let interp_vars = Ftactic.List.map (fun v -> interp_tacarg ist v) l in @@ -1151,7 +1147,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with in Ftactic.run tac (fun () -> Proofview.tclUNIT ()) - | TacML (loc,(opn,l)) -> + | TacML {loc; v=(opn,l)} -> push_trace (Loc.tag ?loc @@ LtacMLCall tac) ist >>= fun trace -> let ist = { ist with extra = TacStore.set ist.extra f_trace trace; } in let tac = Tacenv.interp_ml_tactic opn in @@ -1205,9 +1201,9 @@ and interp_tacarg ist arg : Val.t Ftactic.t = Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (Ftactic.return (Value.of_constr c_interp)) end - | TacCall (loc,(r,[])) -> + | TacCall { v=(r,[]) } -> interp_ltac_reference true ist r - | TacCall (loc,(f,l)) -> + | TacCall { loc; v=(f,l) } -> let (>>=) = Ftactic.bind in interp_ltac_reference true ist f >>= fun fv -> Ftactic.List.map (fun a -> interp_tacarg ist a) l >>= fun largs -> @@ -1341,7 +1337,7 @@ and interp_letrec ist llc u = Proofview.tclUNIT () >>= fun () -> (* delay for the effects of [lref], just in case. *) let lref = ref ist.lfun in let fold accu ({v=na}, b) = - let v = of_tacvalue (VRec (lref, TacArg (Loc.tag b))) in + let v = of_tacvalue (VRec (lref, TacArg (CAst.make b))) in Name.fold_right (fun id -> Id.Map.add id v) na accu in let lfun = List.fold_left fold ist.lfun llc in @@ -1879,7 +1875,7 @@ module Value = struct let (_, args, lfun) = List.fold_right fold args (0, [], Id.Map.empty) in let lfun = Id.Map.add (Id.of_string "F") f lfun in let ist = { (default_ist ()) with lfun = lfun; } in - let tac = TacArg(Loc.tag @@ TacCall (Loc.tag (ArgVar CAst.(make @@ Id.of_string "F"),args))) in + let tac = TacArg(CAst.make @@ TacCall (CAst.make (ArgVar CAst.(make @@ Id.of_string "F"),args))) in eval_tactic_ist ist tac end diff --git a/plugins/ltac/tacsubst.ml b/plugins/ltac/tacsubst.ml index 9173e23b89..caaa547a07 100644 --- a/plugins/ltac/tacsubst.ml +++ b/plugins/ltac/tacsubst.ml @@ -173,7 +173,7 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with TacInversion (InversionUsing (subst_glob_constr subst c,cl),hyp) and subst_tactic subst (t:glob_tactic_expr) = match t with - | TacAtom (_loc,t) -> TacAtom (Loc.tag @@ subst_atomic subst t) + | TacAtom { CAst.v=t } -> TacAtom (CAst.make @@ subst_atomic subst t) | TacFun tacfun -> TacFun (subst_tactic_fun subst tacfun) | TacLetIn (r,l,u) -> let l = List.map (fun (n,b) -> (n,subst_tacarg subst b)) l in @@ -220,22 +220,22 @@ and subst_tactic subst (t:glob_tactic_expr) = match t with | TacFirst l -> TacFirst (List.map (subst_tactic subst) l) | TacSolve l -> TacSolve (List.map (subst_tactic subst) l) | TacComplete tac -> TacComplete (subst_tactic subst tac) - | TacArg (_,a) -> TacArg (Loc.tag @@ subst_tacarg subst a) + | TacArg { CAst.v=a } -> TacArg (CAst.make @@ subst_tacarg subst a) | TacSelect (s, tac) -> TacSelect (s, subst_tactic subst tac) (* For extensions *) - | TacAlias (_,(s,l)) -> + | TacAlias { CAst.v=(s,l) } -> let s = subst_kn subst s in - TacAlias (Loc.tag (s,List.map (subst_tacarg subst) l)) - | TacML (loc,(opn,l)) -> TacML (loc, (opn,List.map (subst_tacarg subst) l)) + TacAlias (CAst.make (s,List.map (subst_tacarg subst) l)) + | TacML { CAst.loc; v=(opn,l)} -> TacML CAst.(make ?loc (opn,List.map (subst_tacarg subst) l)) and subst_tactic_fun subst (var,body) = (var,subst_tactic subst body) and subst_tacarg subst = function | Reference r -> Reference (subst_reference subst r) | ConstrMayEval c -> ConstrMayEval (subst_raw_may_eval subst c) - | TacCall (loc,(f,l)) -> - TacCall (Loc.tag ?loc (subst_reference subst f, List.map (subst_tacarg subst) l)) + | TacCall { CAst.loc; v=(f,l) } -> + TacCall CAst.(make ?loc (subst_reference subst f, List.map (subst_tacarg subst) l)) | TacFreshId _ as x -> x | TacPretype c -> TacPretype (subst_glob_constr subst c) | TacNumgoals -> TacNumgoals diff --git a/plugins/ltac/tactic_debug.ml b/plugins/ltac/tactic_debug.ml index 6bab8d0353..877d4ee758 100644 --- a/plugins/ltac/tactic_debug.ml +++ b/plugins/ltac/tactic_debug.ml @@ -365,7 +365,7 @@ let explain_ltac_call_trace last trace loc = Pptactic.pr_glob_tactic (Global.env()) t ++ str ")" | Tacexpr.LtacAtomCall te -> quote (Pptactic.pr_glob_tactic (Global.env()) - (Tacexpr.TacAtom (Loc.tag te))) + (Tacexpr.TacAtom (CAst.make te))) | Tacexpr.LtacConstrInterp (c, { Ltac_pretype.ltac_constrs = vars }) -> quote (Printer.pr_glob_constr_env (Global.env()) c) ++ (if not (Id.Map.is_empty vars) then diff --git a/plugins/ltac/tauto.ml b/plugins/ltac/tauto.ml index 299bc7ea4d..561bfc5d7c 100644 --- a/plugins/ltac/tauto.ml +++ b/plugins/ltac/tauto.ml @@ -191,7 +191,7 @@ let make_unfold name = let u_not = make_unfold "not" let reduction_not_iff _ ist = - let make_reduce c = TacAtom (Loc.tag @@ TacReduce (Genredexpr.Unfold c, Locusops.allHypsAndConcl)) in + let make_reduce c = TacAtom (CAst.make @@ TacReduce (Genredexpr.Unfold c, Locusops.allHypsAndConcl)) in let tac = match !negation_unfolding with | true -> make_reduce [u_not] | false -> TacId [] @@ -244,7 +244,7 @@ let with_flags flags _ ist = let x = CAst.make @@ Id.of_string "x" in let arg = Val.Dyn (tag_tauto_flags, flags) in let ist = { ist with lfun = Id.Map.add x.CAst.v arg ist.lfun } in - eval_tactic_ist ist (TacArg (Loc.tag @@ TacCall (Loc.tag (Locus.ArgVar f, [Reference (Locus.ArgVar x)])))) + eval_tactic_ist ist (TacArg (CAst.make @@ TacCall (CAst.make (Locus.ArgVar f, [Reference (Locus.ArgVar x)])))) let register_tauto_tactic tac name0 args = let ids = List.map (fun id -> Id.of_string id) args in @@ -252,7 +252,7 @@ let register_tauto_tactic tac name0 args = let name = { mltac_plugin = tauto_plugin; mltac_tactic = name0; } in let entry = { mltac_name = name; mltac_index = 0 } in let () = Tacenv.register_ml_tactic name [| tac |] in - let tac = TacFun (ids, TacML (Loc.tag (entry, []))) in + let tac = TacFun (ids, TacML (CAst.make (entry, []))) in let obj () = Tacenv.register_ltac true true (Id.of_string name0) tac in Mltop.declare_cache_obj obj tauto_plugin diff --git a/plugins/setoid_ring/g_newring.mlg b/plugins/setoid_ring/g_newring.mlg index 3ddea7eb30..f59ca4cef4 100644 --- a/plugins/setoid_ring/g_newring.mlg +++ b/plugins/setoid_ring/g_newring.mlg @@ -86,7 +86,7 @@ END VERNAC COMMAND EXTEND AddSetoidRing CLASSIFIED AS SIDEFF | [ "Add" "Ring" ident(id) ":" constr(t) ring_mods_opt(l) ] -> { let l = match l with None -> [] | Some l -> l in add_theory id t l } - | [ "Print" "Rings" ] => {Vernac_classifier.classify_as_query} -> { + | [ "Print" "Rings" ] => { Vernacextend.classify_as_query } -> { Feedback.msg_notice (strbrk "The following ring structures have been declared:"); Spmap.iter (fun fn fi -> let sigma, env = Pfedit.get_current_context () in @@ -130,7 +130,7 @@ END VERNAC COMMAND EXTEND AddSetoidField CLASSIFIED AS SIDEFF | [ "Add" "Field" ident(id) ":" constr(t) field_mods_opt(l) ] -> { let l = match l with None -> [] | Some l -> l in add_field_theory id t l } -| [ "Print" "Fields" ] => {Vernac_classifier.classify_as_query} -> { +| [ "Print" "Fields" ] => {Vernacextend.classify_as_query} -> { Feedback.msg_notice (strbrk "The following field structures have been declared:"); Spmap.iter (fun fn fi -> let sigma, env = Pfedit.get_current_context () in diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index a2dce621d9..4109e9cf38 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -129,7 +129,7 @@ let closed_term_ast = fun l -> let l = List.map (fun gr -> ArgArg(Loc.tag gr)) l in TacFun([Name(Id.of_string"t")], - TacML(Loc.tag (tacname, + TacML(CAst.make (tacname, [TacGeneric (Genarg.in_gen (Genarg.glbwit Stdarg.wit_constr) (DAst.make @@ GVar(Id.of_string"t"),None)); TacGeneric (Genarg.in_gen (Genarg.glbwit (Genarg.wit_list Stdarg.wit_ref)) l)]))) (* @@ -160,7 +160,7 @@ let decl_constant na univs c = (* Calling a global tactic *) let ltac_call tac (args:glob_tactic_arg list) = - TacArg(Loc.tag @@ TacCall (Loc.tag (ArgArg(Loc.tag @@ Lazy.force tac),args))) + TacArg(CAst.make @@ TacCall (CAst.make (ArgArg(Loc.tag @@ Lazy.force tac),args))) let dummy_goal env sigma = let (gl,_,sigma) = @@ -197,7 +197,7 @@ let exec_tactic env evd n f args = (** Build the getter *) let lid = List.init n (fun i -> Id.of_string("x"^string_of_int i)) in let n = Genarg.in_gen (Genarg.glbwit Stdarg.wit_int) n in - let get_res = TacML (Loc.tag (get_res, [TacGeneric n])) in + let get_res = TacML (CAst.make (get_res, [TacGeneric n])) in let getter = Tacexp (TacFun (List.map (fun n -> Name n) lid, get_res)) in (** Evaluate the whole result *) let gl = dummy_goal env evd in @@ -557,7 +557,7 @@ let interp_cst_tac env sigma rk kind (zero,one,add,mul,opp) cst_tac = closed_term_ast (List.map Smartlocate.global_with_alias lc) | None -> let t = ArgArg(Loc.tag @@ Lazy.force ltac_inv_morph_nothing) in - TacArg(Loc.tag (TacCall(Loc.tag (t,[])))) + TacArg(CAst.make (TacCall(CAst.make (t,[])))) let make_hyp env evd c = let t = Retyping.get_type_of env !evd c in @@ -582,7 +582,7 @@ let interp_power env evdref pow = match pow with | None -> let t = ArgArg(Loc.tag (Lazy.force ltac_inv_morph_nothing)) in - (TacArg(Loc.tag (TacCall(Loc.tag (t,[])))), plapp evdref coq_None [|carrier|]) + (TacArg(CAst.make (TacCall(CAst.make (t,[])))), plapp evdref coq_None [|carrier|]) | Some (tac, spec) -> let tac = match tac with diff --git a/plugins/ssr/ssrbool.v b/plugins/ssr/ssrbool.v index a618fc781f..3a7cf41d43 100644 --- a/plugins/ssr/ssrbool.v +++ b/plugins/ssr/ssrbool.v @@ -371,7 +371,7 @@ Ltac prop_congr := apply: prop_congr. Lemma is_true_true : true. Proof. by []. Qed. Lemma not_false_is_true : ~ false. Proof. by []. Qed. Lemma is_true_locked_true : locked true. Proof. by unlock. Qed. -Hint Resolve is_true_true not_false_is_true is_true_locked_true. +Hint Resolve is_true_true not_false_is_true is_true_locked_true : core. (** Shorter names. **) Definition isT := is_true_true. diff --git a/plugins/ssr/ssrbwd.ml b/plugins/ssr/ssrbwd.ml index 1c4508abf4..3e0fbc9a8c 100644 --- a/plugins/ssr/ssrbwd.ml +++ b/plugins/ssr/ssrbwd.ml @@ -104,8 +104,6 @@ let mkRAppView ist gl rv gv = let nb_view_imps = interp_view_nbimps ist gl rv in mkRApp rv (mkRHoles (abs nb_view_imps)) -let prof_apply_interp_with = mk_profiler "ssrapplytac.interp_with";; - let refine_interp_apply_view dbl ist gl gv = let pair i = List.map (fun x -> i, x) in let rv = pf_intern_term ist gl gv in @@ -113,7 +111,6 @@ let refine_interp_apply_view dbl ist gl gv = let interp_with (dbl, hint) = let i = if dbl = Ssrview.AdaptorDb.Equivalence then 2 else 1 in interp_refine ist gl (mkRApp hint (v :: mkRHoles i)) in - let interp_with x = prof_apply_interp_with.profile interp_with x in let rec loop = function | [] -> (try apply_rconstr ~ist rv gl with _ -> view_error "apply" gv) | h :: hs -> (try refine_with (snd (interp_with h)) gl with _ -> loop hs) in diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index be8f3603e4..fa58a1c39a 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -242,7 +242,6 @@ let interp_refine ist gl rc = let flags = { Pretyping.use_typeclasses = true; solve_unification_constraints = true; - use_hook = None; fail_evar = false; expand_evars = true } in @@ -860,7 +859,7 @@ let ssr_n_tac seed n gl = with Not_found -> if n = -1 then fail "The ssreflect library was not loaded" else fail ("The tactic "^name^" was not found") in - let tacexpr = Loc.tag @@ Tacexpr.Reference (ArgArg (Loc.tag @@ tacname)) in + let tacexpr = CAst.make @@ Tacexpr.Reference (ArgArg (Loc.tag @@ tacname)) in Proofview.V82.of_tactic (Tacinterp.eval_tactic (Tacexpr.TacArg tacexpr)) gl let donetac n gl = ssr_n_tac "done" n gl @@ -1018,81 +1017,6 @@ let refine_with ?(first_goes_last=false) ?beta ?(with_evars=true) oc gl = try applyn ~with_evars ~with_shelve:true ?beta n (EConstr.of_constr oc) gl with e when CErrors.noncritical e -> raise dependent_apply_error -(** Profiling *)(* {{{ *************************************************************) -type profiler = { - profile : 'a 'b. ('a -> 'b) -> 'a -> 'b; - reset : unit -> unit; - print : unit -> unit } -let profile_now = ref false -let something_profiled = ref false -let profilers = ref [] -let add_profiler f = profilers := f :: !profilers;; -let _ = - Goptions.declare_bool_option - { Goptions.optname = "ssreflect profiling"; - Goptions.optkey = ["SsrProfiling"]; - Goptions.optread = (fun _ -> !profile_now); - Goptions.optdepr = false; - Goptions.optwrite = (fun b -> - Ssrmatching.profile b; - profile_now := b; - if b then List.iter (fun f -> f.reset ()) !profilers; - if not b then List.iter (fun f -> f.print ()) !profilers) } -let () = - let prof_total = - let init = ref 0.0 in { - profile = (fun f x -> assert false); - reset = (fun () -> init := Unix.gettimeofday ()); - print = (fun () -> if !something_profiled then - prerr_endline - (Printf.sprintf "!! %-39s %10d %9.4f %9.4f %9.4f" - "total" 0 (Unix.gettimeofday() -. !init) 0.0 0.0)) } in - let prof_legenda = { - profile = (fun f x -> assert false); - reset = (fun () -> ()); - print = (fun () -> if !something_profiled then begin - prerr_endline - (Printf.sprintf "!! %39s ---------- --------- --------- ---------" - (String.make 39 '-')); - prerr_endline - (Printf.sprintf "!! %-39s %10s %9s %9s %9s" - "function" "#calls" "total" "max" "average") end) } in - add_profiler prof_legenda; - add_profiler prof_total -;; - -let mk_profiler s = - let total, calls, max = ref 0.0, ref 0, ref 0.0 in - let reset () = total := 0.0; calls := 0; max := 0.0 in - let profile f x = - if not !profile_now then f x else - let before = Unix.gettimeofday () in - try - incr calls; - let res = f x in - let after = Unix.gettimeofday () in - let delta = after -. before in - total := !total +. delta; - if delta > !max then max := delta; - res - with exc -> - let after = Unix.gettimeofday () in - let delta = after -. before in - total := !total +. delta; - if delta > !max then max := delta; - raise exc in - let print () = - if !calls <> 0 then begin - something_profiled := true; - prerr_endline - (Printf.sprintf "!! %-39s %10d %9.4f %9.4f %9.4f" - s !calls !total !max (!total /. (float_of_int !calls))) end in - let prof = { profile = profile; reset = reset; print = print } in - add_profiler prof; - prof -;; -(* }}} *) - (* We wipe out all the keywords generated by the grammar rules we defined. *) (* The user is supposed to Require Import ssreflect or Require ssreflect *) (* and Import ssreflect.SsrSyntax to obtain these keywords and as a *) diff --git a/plugins/ssr/ssrcommon.mli b/plugins/ssr/ssrcommon.mli index cf4e4b354e..e92489e568 100644 --- a/plugins/ssr/ssrcommon.mli +++ b/plugins/ssr/ssrcommon.mli @@ -378,13 +378,6 @@ val pf_interp_gen_aux : val is_name_in_ipats : Id.t -> ssripats -> bool -type profiler = { - profile : 'a 'b. ('a -> 'b) -> 'a -> 'b; - reset : unit -> unit; - print : unit -> unit } - -val mk_profiler : string -> profiler - (** Basic tactics *) val introid : ?orig:Name.t ref -> Id.t -> v82tac diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml index 2a69e3f23a..22475fef34 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -425,11 +425,6 @@ let rwcltac cl rdx dir sr gl = in tclTHEN cvtac' rwtac gl -let prof_rwcltac = mk_profiler "rwrxtac.rwcltac";; -let rwcltac cl rdx dir sr gl = - prof_rwcltac.profile (rwcltac cl rdx dir sr) gl -;; - [@@@ocaml.warning "-3"] let lz_coq_prod = @@ -455,8 +450,6 @@ let ssr_is_setoid env = Rewrite.is_applied_rewrite_relation env sigma [] (EConstr.mkApp (r, args)) <> None -let prof_rwxrtac_find_rule = mk_profiler "rwrxtac.find_rule";; - let closed0_check cl p gl = if closed0 cl then errorstrm Pp.(str"No occurrence of redex "++ pr_constr_env (pf_env gl) (project gl) p) @@ -556,7 +549,6 @@ let rwrxtac occ rdx_pat dir rule gl = d, (ise, Evd.evar_universe_context ise, Reductionops.nf_evar ise r) with _ -> rwtac rs in rwtac rules in - let find_rule rdx = prof_rwxrtac_find_rule.profile find_rule rdx in let sigma0, env0, concl0 = project gl, pf_env gl, pf_concl gl in let find_R, conclude = match rdx_pat with | Some (_, (In_T _ | In_X_In_T _)) | None -> @@ -582,11 +574,6 @@ let rwrxtac occ rdx_pat dir rule gl = rwcltac (EConstr.of_constr concl) (EConstr.of_constr rdx) d r gl ;; -let prof_rwxrtac = mk_profiler "rwrxtac";; -let rwrxtac occ rdx_pat dir rule gl = - prof_rwxrtac.profile (rwrxtac occ rdx_pat dir rule) gl -;; - let ssrinstancesofrule ist dir arg gl = let sigma0, env0, concl0 = project gl, pf_env gl, pf_concl gl in let rule = interp_term ist gl arg in diff --git a/plugins/ssr/ssrfun.v b/plugins/ssr/ssrfun.v index e2c0ed7c8b..6535cad8b7 100644 --- a/plugins/ssr/ssrfun.v +++ b/plugins/ssr/ssrfun.v @@ -398,7 +398,7 @@ End ExtensionalEquality. Typeclasses Opaque eqfun. Typeclasses Opaque eqrel. -Hint Resolve frefl rrefl. +Hint Resolve frefl rrefl : core. Notation "f1 =1 f2" := (eqfun f1 f2) (at level 70, no associativity) : fun_scope. diff --git a/plugins/ssr/ssrparser.mlg b/plugins/ssr/ssrparser.mlg index 52240f5896..7c91860228 100644 --- a/plugins/ssr/ssrparser.mlg +++ b/plugins/ssr/ssrparser.mlg @@ -1545,9 +1545,9 @@ let test_ssrseqvar = Gram.Entry.of_parser "test_ssrseqvar" accept_ssrseqvar let swaptacarg (loc, b) = (b, []), Some (TacId []) let check_seqtacarg dir arg = match snd arg, dir with - | ((true, []), Some (TacAtom (loc, _))), L2R -> + | ((true, []), Some (TacAtom { CAst.loc })), L2R -> CErrors.user_err ?loc (str "expected \"last\"") - | ((false, []), Some (TacAtom (loc, _))), R2L -> + | ((false, []), Some (TacAtom { CAst.loc })), R2L -> CErrors.user_err ?loc (str "expected \"first\"") | _, _ -> arg @@ -1677,7 +1677,7 @@ let set_pr_ssrtac name prec afmt = (* FIXME *) () (* | ArgCoq at -> Egramml.GramTerminal "COQ_ARG") afmt in let tacname = ssrtac_name name in () *) -let ssrtac_atom ?loc name args = TacML (Loc.tag ?loc (ssrtac_entry name 0, args)) +let ssrtac_atom ?loc name args = TacML (CAst.make ?loc (ssrtac_entry name 0, args)) let ssrtac_expr ?loc name args = ssrtac_atom ?loc name args let tclintros_expr ?loc tac ipats = @@ -1704,7 +1704,7 @@ END GRAMMAR EXTEND Gram GLOBAL: tactic_expr; - ssrparentacarg: [[ "("; tac = tactic_expr; ")" -> { Loc.tag ~loc (Tacexp tac) } ]]; + ssrparentacarg: [[ "("; tac = tactic_expr; ")" -> { CAst.make ~loc (Tacexp tac) } ]]; tactic_expr: LEVEL "0" [[ arg = ssrparentacarg -> { TacArg arg } ]]; END @@ -1724,7 +1724,7 @@ let ssrautoprop gl = let tacname = try Tacenv.locate_tactic (qualid_of_ident (Id.of_string "ssrautoprop")) with Not_found -> Tacenv.locate_tactic (ssrqid "ssrautoprop") in - let tacexpr = Loc.tag @@ Tacexpr.Reference (ArgArg (Loc.tag @@ tacname)) in + let tacexpr = CAst.make @@ Tacexpr.Reference (ArgArg (Loc.tag @@ tacname)) in V82.of_tactic (eval_tactic (Tacexpr.TacArg tacexpr)) gl with Not_found -> V82.of_tactic (Auto.full_trivial []) gl diff --git a/plugins/ssrmatching/ssrmatching.ml b/plugins/ssrmatching/ssrmatching.ml index 5dcbf9b3ef..8cb0a8b463 100644 --- a/plugins/ssrmatching/ssrmatching.ml +++ b/plugins/ssrmatching/ssrmatching.ml @@ -174,82 +174,6 @@ let nf_evar sigma c = (* }}} *) -(** Profiling *)(* {{{ *************************************************************) -type profiler = { - profile : 'a 'b. ('a -> 'b) -> 'a -> 'b; - reset : unit -> unit; - print : unit -> unit } -let profile_now = ref false -let something_profiled = ref false -let profilers = ref [] -let add_profiler f = profilers := f :: !profilers;; -let profile b = - profile_now := b; - if b then List.iter (fun f -> f.reset ()) !profilers; - if not b then List.iter (fun f -> f.print ()) !profilers -;; -let _ = - Goptions.declare_bool_option - { Goptions.optname = "ssrmatching profiling"; - Goptions.optkey = ["SsrMatchingProfiling"]; - Goptions.optread = (fun _ -> !profile_now); - Goptions.optdepr = false; - Goptions.optwrite = profile } -let () = - let prof_total = - let init = ref 0.0 in { - profile = (fun f x -> assert false); - reset = (fun () -> init := Unix.gettimeofday ()); - print = (fun () -> if !something_profiled then - prerr_endline - (Printf.sprintf "!! %-39s %10d %9.4f %9.4f %9.4f" - "total" 0 (Unix.gettimeofday() -. !init) 0.0 0.0)) } in - let prof_legenda = { - profile = (fun f x -> assert false); - reset = (fun () -> ()); - print = (fun () -> if !something_profiled then begin - prerr_endline - (Printf.sprintf "!! %39s ---------- --------- --------- ---------" - (String.make 39 '-')); - prerr_endline - (Printf.sprintf "!! %-39s %10s %9s %9s %9s" - "function" "#calls" "total" "max" "average") end) } in - add_profiler prof_legenda; - add_profiler prof_total -;; - -let mk_profiler s = - let total, calls, max = ref 0.0, ref 0, ref 0.0 in - let reset () = total := 0.0; calls := 0; max := 0.0 in - let profile f x = - if not !profile_now then f x else - let before = Unix.gettimeofday () in - try - incr calls; - let res = f x in - let after = Unix.gettimeofday () in - let delta = after -. before in - total := !total +. delta; - if delta > !max then max := delta; - res - with exc -> - let after = Unix.gettimeofday () in - let delta = after -. before in - total := !total +. delta; - if delta > !max then max := delta; - raise exc in - let print () = - if !calls <> 0 then begin - something_profiled := true; - prerr_endline - (Printf.sprintf "!! %-39s %10d %9.4f %9.4f %9.4f" - s !calls !total !max (!total /. (float_of_int !calls))) end in - let prof = { profile = profile; reset = reset; print = print } in - add_profiler prof; - prof -;; -(* }}} *) - exception NoProgress (** Unification procedures. *) @@ -286,11 +210,6 @@ let unif_EQ_args env sigma pa a = let rec loop i = (i = n) || unif_EQ env sigma pa.(i) a.(i) && loop (i + 1) in loop 0 -let prof_unif_eq_args = mk_profiler "unif_EQ_args";; -let unif_EQ_args env sigma pa a = - prof_unif_eq_args.profile (unif_EQ_args env sigma pa) a -;; - let unif_HO env ise p c = try Evarconv.the_conv_x env p c ise with Evarconv.UnableToUnify(ise, err) -> @@ -650,11 +569,6 @@ let match_upats_FO upats env sigma0 ise orig_c = iter_constr_LR loop f; Array.iter loop a in try loop orig_c with Invalid_argument _ -> CErrors.anomaly (str"IN FO.") -let prof_FO = mk_profiler "match_upats_FO";; -let match_upats_FO upats env sigma0 ise c = - prof_FO.profile (match_upats_FO upats env sigma0) ise c -;; - let match_upats_HO ~on_instance upats env sigma0 ise c = let dont_impact_evars = dont_impact_evars_in c in @@ -706,11 +620,6 @@ let match_upats_HO ~on_instance upats env sigma0 ise c = if !it_did_match then raise NoProgress; !failed_because_of_TC -let prof_HO = mk_profiler "match_upats_HO";; -let match_upats_HO ~on_instance upats env sigma0 ise c = - prof_HO.profile (match_upats_HO ~on_instance upats env sigma0) ise c -;; - let fixed_upat evd = function | {up_k = KpatFlex | KpatEvar _ | KpatProj _} -> false @@ -1388,7 +1297,7 @@ let () = let () = Tacenv.register_ml_tactic name [|mltac|] in let tac = TacFun ([Name (Id.of_string "pattern")], - TacML (Loc.tag ({ mltac_name = name; mltac_index = 0 }, []))) in + TacML (CAst.make ({ mltac_name = name; mltac_index = 0 }, []))) in let obj () = Tacenv.register_ltac true false (Id.of_string "ssrpattern") tac in Mltop.declare_cache_obj obj "ssrmatching_plugin" diff --git a/plugins/ssrmatching/ssrmatching.mli b/plugins/ssrmatching/ssrmatching.mli index b3ddb52e85..63b7e1783e 100644 --- a/plugins/ssrmatching/ssrmatching.mli +++ b/plugins/ssrmatching/ssrmatching.mli @@ -221,10 +221,6 @@ val pf_unsafe_merge_uc : UState.t -> goal Evd.sigma -> goal Evd.sigma (* One can also "Set SsrMatchingDebug" from a .v *) val debug : bool -> unit -(* One should delimit a snippet with "Set SsrMatchingProfiling" and - * "Unset SsrMatchingProfiling" to get timings *) -val profile : bool -> unit - val ssrinstancesof : cpattern -> Tacmach.tactic (** Functions used for grammar extensions. Do not use. *) diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 164f5ab96d..e02fb33276 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -1698,7 +1698,7 @@ let abstract_tycon ?loc env sigma subst tycon extenv t = try list_assoc_in_triple i subst0 with Not_found -> mkRel i) 1 (rel_context !!env) in let sigma, ev' = Evarutil.new_evar ~src ~typeclass_candidate:false !!env sigma ty in - begin match solve_simple_eqn (evar_conv_x full_transparent_state) !!env sigma (None,ev,substl inst ev') with + begin match solve_simple_eqn (evar_conv_x TransparentState.full) !!env sigma (None,ev,substl inst ev') with | Success evd -> evdref := evd | UnifFailure _ -> assert false end; diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 6a75be352b..f370ad7ae2 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -16,7 +16,6 @@ open Termops open Environ open EConstr open Vars -open CClosure open Reduction open Reductionops open Recordops @@ -30,7 +29,7 @@ open Context.Named.Declaration module RelDecl = Context.Rel.Declaration module NamedDecl = Context.Named.Declaration -type unify_fun = transparent_state -> +type unify_fun = TransparentState.t -> env -> evar_map -> conv_pb -> EConstr.constr -> EConstr.constr -> Evarsolve.unification_result let debug_unification = ref (false) @@ -74,14 +73,14 @@ let coq_unit_judge = let unfold_projection env evd ts p c = let cst = Projection.constant p in - if is_transparent_constant ts cst then + if TransparentState.is_transparent_constant ts cst then Some (mkProj (Projection.unfold p, c)) else None let eval_flexible_term ts env evd c = match EConstr.kind evd c with | Const (c, u) -> - if is_transparent_constant ts c + if TransparentState.is_transparent_constant ts c then Option.map EConstr.of_constr (constant_opt_value_in env (c, EInstance.kind evd u)) else None | Rel n -> @@ -91,7 +90,7 @@ let eval_flexible_term ts env evd c = with Not_found -> None) | Var id -> (try - if is_transparent_variable ts id then + if TransparentState.is_transparent_variable ts id then env |> lookup_named id |> NamedDecl.get_value else None with Not_found -> None) @@ -1211,7 +1210,7 @@ let second_order_matching ts env_rhs evd (evk,args) argoccs rhs = | [] -> let evd = try Evarsolve.check_evar_instance evd evk rhs - (evar_conv_x full_transparent_state) + (evar_conv_x TransparentState.full) with IllTypedInstance _ -> raise (TypingFailed evd) in Evd.define evk rhs evd @@ -1354,7 +1353,7 @@ let solve_unconstrained_impossible_cases env evd = let j, ctx = coq_unit_judge env in let evd' = Evd.merge_context_set Evd.univ_flexible_alg ?loc evd' ctx in let ty = j_type j in - let conv_algo = evar_conv_x full_transparent_state in + let conv_algo = evar_conv_x TransparentState.full in let evd' = check_evar_instance evd' evk ty conv_algo in Evd.define evk ty evd' | _ -> evd') evd evd @@ -1393,7 +1392,7 @@ let solve_unif_constraints_with_heuristics env exception UnableToUnify of evar_map * unification_error -let default_transparent_state env = full_transparent_state +let default_transparent_state env = TransparentState.full (* Conv_oracle.get_transp_state (Environ.oracle env) *) let the_conv_x env ?(ts=default_transparent_state env) t1 t2 evd = diff --git a/pretyping/evarconv.mli b/pretyping/evarconv.mli index 350dece28a..4585fac252 100644 --- a/pretyping/evarconv.mli +++ b/pretyping/evarconv.mli @@ -8,7 +8,6 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Names open EConstr open Environ open Reductionops @@ -22,20 +21,20 @@ exception UnableToUnify of evar_map * Pretype_errors.unification_error (** {6 Main unification algorithm for type inference. } *) (** returns exception NotUnifiable with best known evar_map if not unifiable *) -val the_conv_x : env -> ?ts:transparent_state -> constr -> constr -> evar_map -> evar_map -val the_conv_x_leq : env -> ?ts:transparent_state -> constr -> constr -> evar_map -> evar_map +val the_conv_x : env -> ?ts:TransparentState.t -> constr -> constr -> evar_map -> evar_map +val the_conv_x_leq : env -> ?ts:TransparentState.t -> constr -> constr -> evar_map -> evar_map (** The same function resolving evars by side-effect and catching the exception *) -val conv : env -> ?ts:transparent_state -> evar_map -> constr -> constr -> evar_map option -val cumul : env -> ?ts:transparent_state -> evar_map -> constr -> constr -> evar_map option +val conv : env -> ?ts:TransparentState.t -> evar_map -> constr -> constr -> evar_map option +val cumul : env -> ?ts:TransparentState.t -> evar_map -> constr -> constr -> evar_map option (** {6 Unification heuristics. } *) (** Try heuristics to solve pending unification problems and to solve evars with candidates *) -val solve_unif_constraints_with_heuristics : env -> ?ts:transparent_state -> evar_map -> evar_map +val solve_unif_constraints_with_heuristics : env -> ?ts:TransparentState.t -> evar_map -> evar_map (** Check all pending unification problems are solved and raise an error otherwise *) @@ -55,14 +54,14 @@ val check_conv_record : env -> evar_map -> (** Try to solve problems of the form ?x[args] = c by second-order matching, using typing to select occurrences *) -val second_order_matching : transparent_state -> env -> evar_map -> +val second_order_matching : TransparentState.t -> env -> evar_map -> EConstr.existential -> occurrences option list -> constr -> evar_map * bool (** Declare function to enforce evars resolution by using typing constraints *) val set_solve_evars : (env -> evar_map -> constr -> evar_map * constr) -> unit -type unify_fun = transparent_state -> +type unify_fun = TransparentState.t -> env -> evar_map -> conv_pb -> constr -> constr -> Evarsolve.unification_result (** Override default [evar_conv_x] algorithm. *) @@ -73,7 +72,7 @@ val evar_conv_x : unify_fun (**/**) (* For debugging *) -val evar_eqappr_x : ?rhs_is_already_stuck:bool -> transparent_state * bool -> +val evar_eqappr_x : ?rhs_is_already_stuck:bool -> TransparentState.t * bool -> env -> evar_map -> conv_pb -> state * Cst_stack.t -> state * Cst_stack.t -> Evarsolve.unification_result diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index cba1533da5..8c57fc2375 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -193,7 +193,6 @@ type inference_hook = env -> evar_map -> Evar.t -> evar_map * constr type inference_flags = { use_typeclasses : bool; solve_unification_constraints : bool; - use_hook : inference_hook option; fail_evar : bool; expand_evars : bool } @@ -247,14 +246,14 @@ let apply_typeclasses env sigma frozen fail_evar = else sigma in sigma -let apply_inference_hook hook sigma frozen = match frozen with +let apply_inference_hook hook env sigma frozen = match frozen with | FrozenId _ -> sigma | FrozenProgress (lazy (_, pending)) -> Evar.Set.fold (fun evk sigma -> if Evd.is_undefined sigma evk (* in particular not defined by side-effect *) then try - let sigma, c = hook sigma evk in + let sigma, c = hook env sigma evk in Evd.define evk c sigma with Exit -> sigma @@ -307,16 +306,16 @@ let check_evars_are_solved env sigma frozen = (* Try typeclasses, hooks, unification heuristics ... *) -let solve_remaining_evars flags env sigma init_sigma = +let solve_remaining_evars ?hook flags env sigma init_sigma = let frozen = frozen_and_pending_holes (init_sigma, sigma) in let sigma = if flags.use_typeclasses then apply_typeclasses env sigma frozen false else sigma in - let sigma = if Option.has_some flags.use_hook - then apply_inference_hook (Option.get flags.use_hook env) sigma frozen - else sigma + let sigma = match hook with + | None -> sigma + | Some hook -> apply_inference_hook hook env sigma frozen in let sigma = if flags.solve_unification_constraints then apply_heuristics env sigma false @@ -1075,14 +1074,12 @@ let ise_pretype_gen flags env sigma lvar kind c = let default_inference_flags fail = { use_typeclasses = true; solve_unification_constraints = true; - use_hook = None; fail_evar = fail; expand_evars = true } let no_classes_no_fail_inference_flags = { use_typeclasses = false; solve_unification_constraints = true; - use_hook = None; fail_evar = false; expand_evars = true } diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index 0f95d27528..2eaa77b822 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -35,7 +35,6 @@ type inference_hook = env -> evar_map -> Evar.t -> evar_map * constr type inference_flags = { use_typeclasses : bool; solve_unification_constraints : bool; - use_hook : inference_hook option; fail_evar : bool; expand_evars : bool } @@ -95,7 +94,7 @@ val understand : ?flags:inference_flags -> ?expected_type:typing_constraint -> with candidate and no other conversion problems that the one in [pending], however, it can contain more evars than the pending ones. *) -val solve_remaining_evars : inference_flags -> +val solve_remaining_evars : ?hook:inference_hook -> inference_flags -> env -> (* current map *) evar_map -> (* initial map *) evar_map -> evar_map (** Checking evars and pending conversion problems are all solved, diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 17003cd1dd..e632976ae5 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -675,10 +675,6 @@ let apply_subst recfun env sigma refold cst_l t stack = let stacklam recfun env sigma t stack = apply_subst (fun _ _ s -> recfun s) env sigma false Cst_stack.empty t stack -let beta_app sigma (c,l) = - let zip s = Stack.zip sigma s in - stacklam zip [] sigma c (Stack.append_app l Stack.empty) - let beta_applist sigma (c,l) = let zip s = Stack.zip sigma s in stacklam zip [] sigma c (Stack.append_app_list l Stack.empty) @@ -1305,13 +1301,13 @@ let test_trans_conversion (f: constr Reduction.extended_conversion_function) red with Reduction.NotConvertible -> false | e when is_anomaly e -> report_anomaly e -let is_conv ?(reds=full_transparent_state) env sigma = test_trans_conversion f_conv reds env sigma -let is_conv_leq ?(reds=full_transparent_state) env sigma = test_trans_conversion f_conv_leq reds env sigma -let is_fconv ?(reds=full_transparent_state) = function +let is_conv ?(reds=TransparentState.full) env sigma = test_trans_conversion f_conv reds env sigma +let is_conv_leq ?(reds=TransparentState.full) env sigma = test_trans_conversion f_conv_leq reds env sigma +let is_fconv ?(reds=TransparentState.full) = function | Reduction.CONV -> is_conv ~reds | Reduction.CUMUL -> is_conv_leq ~reds -let check_conv ?(pb=Reduction.CUMUL) ?(ts=full_transparent_state) env sigma x y = +let check_conv ?(pb=Reduction.CUMUL) ?(ts=TransparentState.full) env sigma x y = let f = match pb with | Reduction.CONV -> f_conv | Reduction.CUMUL -> f_conv_leq @@ -1345,7 +1341,7 @@ let sigma_univ_state = compare_cumul_instances = sigma_check_inductive_instances; } let infer_conv_gen conv_fun ?(catch_incon=true) ?(pb=Reduction.CUMUL) - ?(ts=full_transparent_state) env sigma x y = + ?(ts=TransparentState.full) env sigma x y = (** FIXME *) try let ans = match pb with @@ -1378,7 +1374,7 @@ let infer_conv = infer_conv_gen (fun pb ~l2r sigma -> Reduction.generic_conv pb ~l2r (safe_evar_value sigma)) (* This reference avoids always having to link C code with the kernel *) -let vm_infer_conv = ref (infer_conv ~catch_incon:true ~ts:full_transparent_state) +let vm_infer_conv = ref (infer_conv ~catch_incon:true ~ts:TransparentState.full) let set_vm_infer_conv f = vm_infer_conv := f let vm_infer_conv ?(pb=Reduction.CUMUL) env t1 t2 = !vm_infer_conv ~pb env t1 t2 @@ -1681,25 +1677,6 @@ let meta_reducible_instance evd b = if Metaset.is_empty fm then (* nf_betaiota? *) b.rebus else irec b.rebus - -let head_unfold_under_prod ts env sigma c = - let unfold (cst,u) = - let cstu = (cst, EInstance.kind sigma u) in - if Cpred.mem cst (snd ts) then - match constant_opt_value_in env cstu with - | Some c -> EConstr.of_constr c - | None -> mkConstU (cst, u) - else mkConstU (cst, u) in - let rec aux c = - match EConstr.kind sigma c with - | Prod (n,t,c) -> mkProd (n,aux t, aux c) - | _ -> - let (h,l) = decompose_app_vect sigma c in - match EConstr.kind sigma h with - | Const cst -> beta_app sigma (unfold cst, l) - | _ -> c in - aux c - let betazetaevar_applist sigma n c l = let rec stacklam n env t stack = if Int.equal n 0 then applist (substl env t, stack) else diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index 41de779414..088e898a99 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -266,21 +266,21 @@ type conversion_test = Constraint.t -> Constraint.t val pb_is_equal : conv_pb -> bool val pb_equal : conv_pb -> conv_pb -val is_conv : ?reds:transparent_state -> env -> evar_map -> constr -> constr -> bool -val is_conv_leq : ?reds:transparent_state -> env -> evar_map -> constr -> constr -> bool -val is_fconv : ?reds:transparent_state -> conv_pb -> env -> evar_map -> constr -> constr -> bool +val is_conv : ?reds:TransparentState.t -> env -> evar_map -> constr -> constr -> bool +val is_conv_leq : ?reds:TransparentState.t -> env -> evar_map -> constr -> constr -> bool +val is_fconv : ?reds:TransparentState.t -> conv_pb -> env -> evar_map -> constr -> constr -> bool (** [check_conv] Checks universe constraints only. pb defaults to CUMUL and ts to a full transparent state. *) -val check_conv : ?pb:conv_pb -> ?ts:transparent_state -> env -> evar_map -> constr -> constr -> bool +val check_conv : ?pb:conv_pb -> ?ts:TransparentState.t -> env -> evar_map -> constr -> constr -> bool (** [infer_conv] Adds necessary universe constraints to the evar map. pb defaults to CUMUL and ts to a full transparent state. @raise UniverseInconsistency iff catch_incon is set to false, otherwise returns false in that case. *) -val infer_conv : ?catch_incon:bool -> ?pb:conv_pb -> ?ts:transparent_state -> +val infer_conv : ?catch_incon:bool -> ?pb:conv_pb -> ?ts:TransparentState.t -> env -> evar_map -> constr -> constr -> evar_map option (** Conversion with inference of universe constraints *) @@ -292,9 +292,9 @@ val vm_infer_conv : ?pb:conv_pb -> env -> evar_map -> constr -> constr -> (** [infer_conv_gen] behaves like [infer_conv] but is parametrized by a conversion function. Used to pretype vm and native casts. *) -val infer_conv_gen : (conv_pb -> l2r:bool -> evar_map -> transparent_state -> +val infer_conv_gen : (conv_pb -> l2r:bool -> evar_map -> TransparentState.t -> (Constr.constr, evar_map) Reduction.generic_conversion_function) -> - ?catch_incon:bool -> ?pb:conv_pb -> ?ts:transparent_state -> env -> + ?catch_incon:bool -> ?pb:conv_pb -> ?ts:TransparentState.t -> env -> evar_map -> constr -> constr -> evar_map option (** {6 Special-Purpose Reduction Functions } *) @@ -302,13 +302,12 @@ val infer_conv_gen : (conv_pb -> l2r:bool -> evar_map -> transparent_state -> val whd_meta : local_reduction_function val plain_instance : evar_map -> constr Metamap.t -> constr -> constr val instance : evar_map -> constr Metamap.t -> constr -> constr -val head_unfold_under_prod : transparent_state -> reduction_function val betazetaevar_applist : evar_map -> int -> constr -> constr list -> constr (** {6 Heuristic for Conversion with Evar } *) val whd_betaiota_deltazeta_for_iota_state : - transparent_state -> Environ.env -> Evd.evar_map -> Cst_stack.t -> state -> + TransparentState.t -> Environ.env -> Evd.evar_map -> Cst_stack.t -> state -> state * Cst_stack.t (** {6 Meta-related reduction functions } *) diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 4ec8569dd8..d9df8c8cf8 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -638,7 +638,7 @@ let whd_nothing_for_iota env sigma s = | Meta ev -> (try whrec (Evd.meta_value sigma ev, stack) with Not_found -> s) - | Const (const, u) when is_transparent_constant full_transparent_state const -> + | Const (const, u) -> let u = EInstance.kind sigma u in (match constant_opt_value_in env (const, u) with | Some body -> whrec (EConstr.of_constr body, stack) diff --git a/pretyping/typeclasses.mli b/pretyping/typeclasses.mli index ee9c83dad3..8bdac0a575 100644 --- a/pretyping/typeclasses.mli +++ b/pretyping/typeclasses.mli @@ -119,8 +119,8 @@ val resolve_one_typeclass : ?unique:bool -> env -> evar_map -> EConstr.types -> val set_typeclass_transparency_hook : (evaluable_global_reference -> bool (*local?*) -> bool -> unit) Hook.t val set_typeclass_transparency : evaluable_global_reference -> bool -> bool -> unit -val classes_transparent_state_hook : (unit -> transparent_state) Hook.t -val classes_transparent_state : unit -> transparent_state +val classes_transparent_state_hook : (unit -> TransparentState.t) Hook.t +val classes_transparent_state : unit -> TransparentState.t val add_instance_hint_hook : (global_reference_or_constr -> GlobRef.t list -> diff --git a/pretyping/unification.ml b/pretyping/unification.ml index e3b942b610..490d58fa52 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -149,7 +149,7 @@ let abstract_list_all_with_dependencies env evd typ c l = let n = List.length l in let argoccs = set_occurrences_of_last_arg (Array.sub (snd ev') 0 n) in let evd,b = - Evarconv.second_order_matching empty_transparent_state + Evarconv.second_order_matching TransparentState.empty env evd ev' argoccs c in if b then let p = nf_evar evd ev in @@ -247,7 +247,7 @@ let sort_eqns = unify_r2l *) type core_unify_flags = { - modulo_conv_on_closed_terms : Names.transparent_state option; + modulo_conv_on_closed_terms : TransparentState.t option; (* What this flag controls was activated with all constants transparent, *) (* even for auto, since Coq V5.10 *) @@ -257,11 +257,11 @@ type core_unify_flags = { use_evars_eagerly_in_conv_on_closed_terms : bool; - modulo_delta : Names.transparent_state; + modulo_delta : TransparentState.t; (* This controls which constants are unfoldable; this is on for apply *) (* (but not simple apply) since Feb 2008 for 8.2 *) - modulo_delta_types : Names.transparent_state; + modulo_delta_types : TransparentState.t; check_applied_meta_types : bool; (* This controls whether meta's applied to arguments have their *) @@ -322,7 +322,7 @@ type unify_flags = { (* Default flag for unifying a type against a type (e.g. apply) *) (* We set all conversion flags (no flag should be modified anymore) *) let default_core_unify_flags () = - let ts = Names.full_transparent_state in { + let ts = TransparentState.full in { modulo_conv_on_closed_terms = Some ts; use_metas_eagerly_in_conv_on_closed_terms = true; use_evars_eagerly_in_conv_on_closed_terms = false; @@ -344,14 +344,14 @@ let default_unify_flags () = let flags = default_core_unify_flags () in { core_unify_flags = flags; merge_unify_flags = flags; - subterm_unify_flags = { flags with modulo_delta = var_full_transparent_state }; + subterm_unify_flags = { flags with modulo_delta = TransparentState.var_full }; allow_K_in_toplevel_higher_order_unification = false; (* Why not? *) resolve_evars = false } let set_no_delta_core_flags flags = { flags with modulo_conv_on_closed_terms = None; - modulo_delta = empty_transparent_state; + modulo_delta = TransparentState.empty; check_applied_meta_types = false; use_pattern_unification = false; use_meta_bound_pattern_unification = true; @@ -370,7 +370,7 @@ let set_no_delta_flags flags = { (* For the first phase of keyed unification, restrict to conversion (including beta-iota) only on closed terms *) let set_no_delta_open_core_flags flags = { flags with - modulo_delta = empty_transparent_state; + modulo_delta = TransparentState.empty; modulo_betaiota = false; } @@ -388,7 +388,7 @@ let set_no_delta_open_flags flags = { (* We set only the flags available at the time the new "apply" extended *) (* out of "simple apply" *) let default_no_delta_core_unify_flags () = { (default_core_unify_flags ()) with - modulo_delta = empty_transparent_state; + modulo_delta = TransparentState.empty; check_applied_meta_types = false; use_pattern_unification = false; use_meta_bound_pattern_unification = true; @@ -425,7 +425,7 @@ let elim_flags_evars sigma = let flags = elim_core_flags sigma in { core_unify_flags = flags; merge_unify_flags = flags; - subterm_unify_flags = { flags with modulo_delta = empty_transparent_state }; + subterm_unify_flags = { flags with modulo_delta = TransparentState.empty }; allow_K_in_toplevel_higher_order_unification = true; resolve_evars = false } @@ -433,7 +433,7 @@ let elim_flags_evars sigma = let elim_flags () = elim_flags_evars Evd.empty let elim_no_delta_core_flags () = { (elim_core_flags Evd.empty) with - modulo_delta = empty_transparent_state; + modulo_delta = TransparentState.empty; check_applied_meta_types = false; use_pattern_unification = false; modulo_betaiota = false; @@ -504,16 +504,16 @@ let key_of env sigma b flags f = if subterm_restriction b flags then None else match EConstr.kind sigma f with | Const (cst, u) when is_transparent env (ConstKey cst) && - (Cpred.mem cst (snd flags.modulo_delta) + (TransparentState.is_transparent_constant flags.modulo_delta cst || Recordops.is_primitive_projection cst) -> let u = EInstance.kind sigma u in Some (IsKey (ConstKey (cst, u))) | Var id when is_transparent env (VarKey id) && - Id.Pred.mem id (fst flags.modulo_delta) -> + TransparentState.is_transparent_variable flags.modulo_delta id -> Some (IsKey (VarKey id)) | Proj (p, c) when Projection.unfolded p || (is_transparent env (ConstKey (Projection.constant p)) && - (Cpred.mem (Projection.constant p) (snd flags.modulo_delta))) -> + (TransparentState.is_transparent_constant flags.modulo_delta (Projection.constant p))) -> Some (IsProj (p, c)) | _ -> None @@ -550,7 +550,7 @@ let oracle_order env cf1 cf2 = let is_rigid_head sigma flags t = match EConstr.kind sigma t with - | Const (cst,u) -> not (Cpred.mem cst (snd flags.modulo_delta)) + | Const (cst,u) -> not (TransparentState.is_transparent_constant flags.modulo_delta cst) | Ind (i,u) -> true | Construct _ -> true | Fix _ | CoFix _ -> true @@ -633,11 +633,11 @@ let rec is_neutral env sigma ts t = | Const (c, u) -> not (Environ.evaluable_constant c env) || not (is_transparent env (ConstKey c)) || - not (Cpred.mem c (snd ts)) + not (TransparentState.is_transparent_constant ts c) | Var id -> not (Environ.evaluable_named id env) || not (is_transparent env (VarKey id)) || - not (Id.Pred.mem id (fst ts)) + not (TransparentState.is_transparent_variable ts id) | Rel n -> true | Evar _ | Meta _ -> true | Case (_, p, c, cl) -> is_neutral env sigma ts c @@ -935,8 +935,8 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e let ty1 = get_type_of curenv ~lax:true sigma c1 in let ty2 = get_type_of curenv ~lax:true sigma c2 in unify_0_with_initial_metas substn true curenv cv_pb - { flags with modulo_conv_on_closed_terms = Some full_transparent_state; - modulo_delta = full_transparent_state; + { flags with modulo_conv_on_closed_terms = Some TransparentState.full; + modulo_delta = TransparentState.full; modulo_eta = true; modulo_betaiota = true } ty1 ty2 @@ -1120,10 +1120,10 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e | Some sigma -> ans | None -> if (match flags.modulo_conv_on_closed_terms, flags.modulo_delta with - | Some (cv_id, cv_k), (dl_id, dl_k) -> - Id.Pred.subset dl_id cv_id && Cpred.subset dl_k cv_k - | None,(dl_id, dl_k) -> - Id.Pred.is_empty dl_id && Cpred.is_empty dl_k) + | Some cv, dl -> + let open TransparentState in + Id.Pred.subset dl.tr_var cv.tr_var && Cpred.subset dl.tr_cst cv.tr_cst + | None, dl -> TransparentState.is_empty dl) then error_cannot_unify env sigma (m, n) else None in let a = match res with @@ -1263,8 +1263,8 @@ let applyHead env evd n c = let is_mimick_head sigma ts f = match EConstr.kind sigma f with - | Const (c,u) -> not (CClosure.is_transparent_constant ts c) - | Var id -> not (CClosure.is_transparent_variable ts id) + | Const (c,u) -> not (TransparentState.is_transparent_constant ts c) + | Var id -> not (TransparentState.is_transparent_variable ts id) | (Rel _|Construct _|Ind _) -> true | _ -> false @@ -1534,11 +1534,11 @@ let finish_evar_resolution ?(flags=Pretyping.all_and_fail_flags) env current_sig (sigma, nf_evar sigma c) let default_matching_core_flags sigma = - let ts = Names.full_transparent_state in { - modulo_conv_on_closed_terms = Some empty_transparent_state; + let ts = TransparentState.full in { + modulo_conv_on_closed_terms = Some TransparentState.empty; use_metas_eagerly_in_conv_on_closed_terms = false; use_evars_eagerly_in_conv_on_closed_terms = false; - modulo_delta = empty_transparent_state; + modulo_delta = TransparentState.empty; modulo_delta_types = ts; check_applied_meta_types = true; use_pattern_unification = false; @@ -1550,7 +1550,7 @@ let default_matching_core_flags sigma = } let default_matching_merge_flags sigma = - let ts = Names.full_transparent_state in + let ts = TransparentState.full in let flags = default_matching_core_flags sigma in { flags with modulo_conv_on_closed_terms = Some ts; @@ -1580,7 +1580,7 @@ let make_pattern_test from_prefix_of_ind is_correct_type env sigma (pending,c) = if from_prefix_of_ind then let flags = default_matching_flags pending in { flags with core_unify_flags = { flags.core_unify_flags with - modulo_conv_on_closed_terms = Some Names.full_transparent_state; + modulo_conv_on_closed_terms = Some TransparentState.full; restrict_conv_on_strict_subterms = true } } else default_matching_flags pending in let n = Array.length (snd (decompose_app_vect sigma c)) in diff --git a/pretyping/unification.mli b/pretyping/unification.mli index e2e261ae7a..a45b8f1dd8 100644 --- a/pretyping/unification.mli +++ b/pretyping/unification.mli @@ -8,18 +8,17 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Names open Constr open EConstr open Environ open Evd type core_unify_flags = { - modulo_conv_on_closed_terms : Names.transparent_state option; + modulo_conv_on_closed_terms : TransparentState.t option; use_metas_eagerly_in_conv_on_closed_terms : bool; use_evars_eagerly_in_conv_on_closed_terms : bool; - modulo_delta : Names.transparent_state; - modulo_delta_types : Names.transparent_state; + modulo_delta : TransparentState.t; + modulo_delta_types : TransparentState.t; check_applied_meta_types : bool; use_pattern_unification : bool; use_meta_bound_pattern_unification : bool; @@ -41,7 +40,7 @@ val default_core_unify_flags : unit -> core_unify_flags val default_no_delta_core_unify_flags : unit -> core_unify_flags val default_unify_flags : unit -> unify_flags -val default_no_delta_unify_flags : transparent_state -> unify_flags +val default_no_delta_unify_flags : TransparentState.t -> unify_flags val elim_flags : unit -> unify_flags val elim_no_delta_flags : unit -> unify_flags diff --git a/printing/prettyp.ml b/printing/prettyp.ml index e698ba9f8f..712eb21ee6 100644 --- a/printing/prettyp.ml +++ b/printing/prettyp.ml @@ -71,27 +71,26 @@ let int_or_no n = if Int.equal n 0 then str "no" else int n let print_basename sp = pr_global (ConstRef sp) let print_ref reduce ref udecl = - let typ, univs = Typeops.type_of_global_in_context (Global.env ()) ref in + let env = Global.env () in + let typ, univs = Typeops.type_of_global_in_context env ref in let inst = Univ.make_abstract_instance univs in - let bl = UnivNames.universe_binders_with_opt_names ref udecl in + let bl = UnivNames.universe_binders_with_opt_names (Environ.universes_of_global env ref) udecl in let sigma = Evd.from_ctx (UState.of_binders bl) in let typ = EConstr.of_constr typ in let typ = if reduce then - let env = Global.env () in let ctx,ccl = Reductionops.splay_prod_assum env sigma typ in EConstr.it_mkProd_or_LetIn ccl ctx else typ in let variance = match ref with | VarRef _ | ConstRef _ -> None | IndRef (ind,_) | ConstructRef ((ind,_),_) -> - let mind = Environ.lookup_mind ind (Global.env ()) in + let mind = Environ.lookup_mind ind env in begin match mind.Declarations.mind_universes with | Declarations.Monomorphic_ind _ | Declarations.Polymorphic_ind _ -> None | Declarations.Cumulative_ind cumi -> Some (Univ.ACumulativityInfo.variance cumi) end in - let env = Global.env () in let inst = if Global.is_polymorphic ref then Printer.pr_universe_instance sigma inst @@ -571,7 +570,7 @@ let print_constant with_values sep sp udecl = in let ctx = UState.of_binders - (UnivNames.universe_binders_with_opt_names (ConstRef sp) udecl) + (UnivNames.universe_binders_with_opt_names (Declareops.constant_polymorphic_context cb) udecl) in let env = Global.env () and sigma = Evd.from_ctx ctx in let pr_ltype = pr_ltype_env env sigma in diff --git a/printing/printer.ml b/printing/printer.ml index da364c8b9e..831008a957 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -244,8 +244,19 @@ let pr_abstract_cumulativity_info sigma cumi = let pr_global_env = Nametab.pr_global_env let pr_global = pr_global_env Id.Set.empty +let pr_universe_instance_constraints evd inst csts = + let open Univ in + let prlev = Termops.pr_evd_level evd in + let pcsts = if Constraint.is_empty csts then mt() + else str " |= " ++ + prlist_with_sep (fun () -> str "," ++ spc()) + (fun (u,d,v) -> hov 0 (prlev u ++ pr_constraint_type d ++ prlev v)) + (Constraint.elements csts) + in + str"@{" ++ Instance.pr prlev inst ++ pcsts ++ str"}" + let pr_universe_instance evd inst = - str"@{" ++ Univ.Instance.pr (Termops.pr_evd_level evd) inst ++ str"}" + pr_universe_instance_constraints evd inst Univ.Constraint.empty let pr_puniverses f env sigma (c,u) = if !Constrextern.print_universes @@ -445,9 +456,9 @@ let pr_predicate pr_elt (b, elts) = let pr_cpred p = pr_predicate (pr_constant (Global.env())) (Cpred.elements p) let pr_idpred p = pr_predicate Id.print (Id.Pred.elements p) -let pr_transparent_state (ids, csts) = - hv 0 (str"VARIABLES: " ++ pr_idpred ids ++ fnl () ++ - str"CONSTANTS: " ++ pr_cpred csts ++ fnl ()) +let pr_transparent_state ts = + hv 0 (str"VARIABLES: " ++ pr_idpred ts.TransparentState.tr_var ++ fnl () ++ + str"CONSTANTS: " ++ pr_cpred ts.TransparentState.tr_cst ++ fnl ()) (* display complete goal og_s has goal+sigma on the previous proof step for diffs diff --git a/printing/printer.mli b/printing/printer.mli index f9d1a62895..785f452a7b 100644 --- a/printing/printer.mli +++ b/printing/printer.mli @@ -85,6 +85,7 @@ val pr_sort : evar_map -> Sorts.t -> Pp.t val pr_polymorphic : bool -> Pp.t val pr_cumulative : bool -> bool -> Pp.t val pr_universe_instance : evar_map -> Univ.Instance.t -> Pp.t +val pr_universe_instance_constraints : evar_map -> Univ.Instance.t -> Univ.Constraint.t -> Pp.t val pr_universe_ctx : evar_map -> ?variance:Univ.Variance.t array -> Univ.UContext.t -> Pp.t val pr_abstract_universe_ctx : evar_map -> ?variance:Univ.Variance.t array -> @@ -134,7 +135,7 @@ val pr_context_of : env -> evar_map -> Pp.t val pr_predicate : ('a -> Pp.t) -> (bool * 'a list) -> Pp.t val pr_cpred : Cpred.t -> Pp.t val pr_idpred : Id.Pred.t -> Pp.t -val pr_transparent_state : transparent_state -> Pp.t +val pr_transparent_state : TransparentState.t -> Pp.t (** Proofs, these functions obey [Hyps Limit] and [Compact contexts]. *) diff --git a/printing/printmod.ml b/printing/printmod.ml index cc40c74998..2c3ab46670 100644 --- a/printing/printmod.ml +++ b/printing/printmod.ml @@ -119,7 +119,9 @@ let print_mutual_inductive env mind mib udecl = | BiFinite -> "Variant" | CoFinite -> "CoInductive" in - let bl = UnivNames.universe_binders_with_opt_names (IndRef (mind, 0)) udecl in + let bl = UnivNames.universe_binders_with_opt_names + (Declareops.inductive_polymorphic_context mib) udecl + in let sigma = Evd.from_ctx (UState.of_binders bl) in hov 0 (Printer.pr_polymorphic (Declareops.inductive_is_polymorphic mib) ++ Printer.pr_cumulative @@ -157,7 +159,9 @@ let print_record env mind mib udecl = let cstrtype = hnf_prod_applist_assum env nparamdecls cstrtypes.(0) args in let fields = get_fields cstrtype in let envpar = push_rel_context params env in - let bl = UnivNames.universe_binders_with_opt_names (IndRef (mind,0)) udecl in + let bl = UnivNames.universe_binders_with_opt_names (Declareops.inductive_polymorphic_context mib) + udecl + in let sigma = Evd.from_ctx (UState.of_binders bl) in let keyword = let open Declarations in @@ -296,7 +300,7 @@ let print_body is_impl extent env mp (l,body) = (match extent with | OnlyNames -> mt () | WithContents -> - let bl = UnivNames.universe_binders_with_opt_names (ConstRef (Constant.make2 mp l)) None in + let bl = UnivNames.universe_binders_with_opt_names ctx None in let sigma = Evd.from_ctx (UState.of_binders bl) in str " :" ++ spc () ++ hov 0 (Printer.pr_ltype_env env sigma cb.const_type) ++ diff --git a/proofs/clenvtac.ml b/proofs/clenvtac.ml index b99cf245fe..c7703b52c7 100644 --- a/proofs/clenvtac.ml +++ b/proofs/clenvtac.ml @@ -9,7 +9,6 @@ (************************************************************************) open Util -open Names open Constr open Termops open Evd @@ -102,11 +101,11 @@ let res_pf ?with_evars ?(with_classes=true) ?(flags=dft ()) clenv = provenant de w_Unify. (Utilisé seulement dans prolog.ml) *) let fail_quick_core_unif_flags = { - modulo_conv_on_closed_terms = Some full_transparent_state; + modulo_conv_on_closed_terms = Some TransparentState.full; use_metas_eagerly_in_conv_on_closed_terms = false; use_evars_eagerly_in_conv_on_closed_terms = false; - modulo_delta = empty_transparent_state; - modulo_delta_types = full_transparent_state; + modulo_delta = TransparentState.empty; + modulo_delta_types = TransparentState.full; check_applied_meta_types = false; use_pattern_unification = false; use_meta_bound_pattern_unification = true; (* ? *) diff --git a/proofs/evar_refiner.ml b/proofs/evar_refiner.ml index c80f370fdc..6c4193c66b 100644 --- a/proofs/evar_refiner.ml +++ b/proofs/evar_refiner.ml @@ -10,7 +10,6 @@ open CErrors open Util -open Names open Evd open Evarutil open Evarsolve @@ -38,7 +37,7 @@ let define_and_solve_constraints evk c env evd = match List.fold_left (fun p (pbty,env,t1,t2) -> match p with - | Success evd -> Evarconv.evar_conv_x full_transparent_state env evd pbty t1 t2 + | Success evd -> Evarconv.evar_conv_x TransparentState.full env evd pbty t1 t2 | UnifFailure _ as x -> x) (Success evd) pbs with @@ -53,7 +52,6 @@ let w_refine (evk,evi) (ltac_var,rawc) sigma = let flags = { Pretyping.use_typeclasses = true; Pretyping.solve_unification_constraints = true; - Pretyping.use_hook = None; Pretyping.fail_evar = false; Pretyping.expand_evars = true } in try Pretyping.understand_ltac flags diff --git a/proofs/logic.ml b/proofs/logic.ml index 4d5711c195..f9e2edd888 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -62,6 +62,8 @@ let is_unification_error = function let catchable_exception = function | CErrors.UserError _ | TypeError _ + | Proof.OpenProof _ + (* abstract will call close_proof inside a tactic *) | Notation.NumeralNotationError _ | RefinerError _ | Indrec.RecursionSchemeError _ | Nametab.GlobalizationError _ diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index e6507332b1..81122e6858 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -26,25 +26,6 @@ let _ = Goptions.declare_bool_option { let use_unification_heuristics () = !use_unification_heuristics_ref -let start_proof (id : Id.t) ?pl str sigma hyps c ?init_tac terminator = - let goals = [ (Global.env_of_context hyps , c) ] in - Proof_global.start_proof sigma id ?pl str goals terminator; - let env = Global.env () in - ignore (Proof_global.with_current_proof (fun _ p -> - match init_tac with - | None -> p,(true,[]) - | Some tac -> Proof.run_tactic env tac p)) - -let cook_this_proof p = - match p with - | { Proof_global.id;entries=[constr];persistence;universes } -> - (id,(constr,universes,persistence)) - | _ -> CErrors.anomaly ~label:"Pfedit.cook_proof" (Pp.str "more than one proof term.") - -let cook_proof () = - cook_this_proof (fst - (Proof_global.close_proof ~keep_body_ucst_separate:false (fun x -> x))) - exception NoSuchGoal let _ = CErrors.register_handler begin function | NoSuchGoal -> CErrors.user_err Pp.(str "No such goal.") @@ -152,13 +133,19 @@ let next = let n = ref 0 in fun () -> incr n; !n let build_constant_by_tactic id ctx sign ?(goal_kind = Global, false, Proof Theorem) typ tac = let evd = Evd.from_ctx ctx in let terminator = Proof_global.make_terminator (fun _ -> ()) in - start_proof id goal_kind evd sign typ terminator; + let goals = [ (Global.env_of_context sign , typ) ] in + Proof_global.start_proof evd id goal_kind goals terminator; try let status = by tac in - let _,(const,univs,_) = cook_proof () in - Proof_global.discard_current (); - let univs = UState.demote_seff_univs const univs in - const, status, univs + let open Proof_global in + let { entries; universes } = fst @@ close_proof ~keep_body_ucst_separate:false (fun x -> x) in + match entries with + | [entry] -> + discard_current (); + let univs = UState.demote_seff_univs entry universes in + entry, status, univs + | _ -> + CErrors.anomaly Pp.(str "[build_constant_by_tactic] close_proof returned more than one proof term") with reraise -> let reraise = CErrors.push reraise in Proof_global.discard_current (); @@ -227,36 +214,3 @@ let refine_by_tactic env sigma ty tac = this hack will work in most cases. *) let ans = Safe_typing.inline_private_constants_in_constr env ans neff in ans, sigma - -(**********************************************************************) -(* Support for resolution of evars in tactic interpretation, including - resolution by application of tactics *) - -let implicit_tactic = Summary.ref None ~name:"implicit-tactic" - -let declare_implicit_tactic tac = implicit_tactic := Some tac - -let clear_implicit_tactic () = implicit_tactic := None - -let apply_implicit_tactic tac = (); fun env sigma evk -> - let evi = Evd.find_undefined sigma evk in - match snd (evar_source evk sigma) with - | (Evar_kinds.ImplicitArg _ | Evar_kinds.QuestionMark _) - when - Context.Named.equal Constr.equal (Environ.named_context_of_val evi.evar_hyps) - (Environ.named_context env) -> - let tac = Proofview.tclTHEN tac (Proofview.tclEXTEND [] (Proofview.tclZERO (CErrors.UserError (None,Pp.str"Proof is not complete."))) []) in - (try - let c = Evarutil.nf_evars_universes sigma (EConstr.Unsafe.to_constr evi.evar_concl) in - let c = EConstr.of_constr c in - if Evarutil.has_undefined_evars sigma c then raise Exit; - let (ans, _, ctx) = - build_by_tactic env (Evd.evar_universe_context sigma) c tac in - let sigma = Evd.set_universe_context sigma ctx in - sigma, EConstr.of_constr ans - with e when Logic.catchable_exception e -> raise Exit) - | _ -> raise Exit - -let solve_by_implicit_tactic () = match !implicit_tactic with -| None -> None -| Some tac -> Some (apply_implicit_tactic tac) diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli index 5feb5bd645..155221947a 100644 --- a/proofs/pfedit.mli +++ b/proofs/pfedit.mli @@ -16,34 +16,6 @@ open Environ open Decl_kinds (** {6 ... } *) -(** [start_proof s str env t hook tac] starts a proof of name [s] and - conclusion [t]; [hook] is optionally a function to be applied at - proof end (e.g. to declare the built constructions as a coercion - or a setoid morphism); init_tac is possibly a tactic to - systematically apply at initialization time (e.g. to start the - proof of mutually dependent theorems) *) - -val start_proof : - Id.t -> ?pl:UState.universe_decl -> goal_kind -> Evd.evar_map -> named_context_val -> EConstr.constr -> - ?init_tac:unit Proofview.tactic -> - Proof_global.proof_terminator -> unit - -(** {6 ... } *) -(** [cook_proof opacity] turns the current proof (assumed completed) into - a constant with its name, kind and possible hook (see [start_proof]); - it fails if there is no current proof of if it is not completed; - it also tells if the guardness condition has to be inferred. *) - -val cook_this_proof : - Proof_global.proof_object -> - (Id.t * - (Safe_typing.private_constants Entries.definition_entry * UState.t * goal_kind)) - -val cook_proof : unit -> - (Id.t * - (Safe_typing.private_constants Entries.definition_entry * UState.t * goal_kind)) - -(** {6 ... } *) (** [get_goal_context n] returns the context of the [n]th subgoal of the current focused proof or raises a [UserError] if there is no focused proof or if there is no more subgoals *) @@ -116,13 +88,3 @@ val refine_by_tactic : env -> Evd.evar_map -> EConstr.types -> unit Proofview.ta evars solved by side-effects are NOT purged, so that unexpected failures may occur. Ideally all code using this function should be rewritten in the monad. *) - -(** Declare the default tactic to fill implicit arguments *) - -val declare_implicit_tactic : unit Proofview.tactic -> unit - -(** To remove the default tactic *) -val clear_implicit_tactic : unit -> unit - -(* Raise Exit if cannot solve *) -val solve_by_implicit_tactic : unit -> Pretyping.inference_hook option diff --git a/proofs/proof.ml b/proofs/proof.ml index 8220949856..76a9a9f4c8 100644 --- a/proofs/proof.ml +++ b/proofs/proof.ml @@ -335,28 +335,42 @@ let dependent_start goals = let number_of_goals = List.length (Proofview.initial_goals pr.entry) in _focus end_of_stack (Obj.repr ()) 1 number_of_goals pr -exception UnfinishedProof -exception HasShelvedGoals -exception HasGivenUpGoals -exception HasUnresolvedEvar +type open_error_reason = + | UnfinishedProof + | HasShelvedGoals + | HasGivenUpGoals + | HasUnresolvedEvar + +let print_open_error_reason er = let open Pp in match er with + | UnfinishedProof -> + str "Attempt to save an incomplete proof" + | HasShelvedGoals -> + str "Attempt to save a proof with shelved goals" + | HasGivenUpGoals -> + strbrk "Attempt to save a proof with given up goals. If this is really what you want to do, use Admitted in place of Qed." + | HasUnresolvedEvar -> + strbrk "Attempt to save a proof with existential variables still non-instantiated" + +exception OpenProof of Names.Id.t option * open_error_reason + let _ = CErrors.register_handler begin function - | UnfinishedProof -> CErrors.user_err Pp.(str "Some goals have not been solved.") - | HasShelvedGoals -> CErrors.user_err Pp.(str "Some goals have been left on the shelf.") - | HasGivenUpGoals -> CErrors.user_err Pp.(str "Some goals have been given up.") - | HasUnresolvedEvar -> CErrors.user_err Pp.(str "Some existential variables are uninstantiated.") - | _ -> raise CErrors.Unhandled -end + | OpenProof (pid, reason) -> + let open Pp in + Option.cata (fun pid -> + str " (in proof " ++ Names.Id.print pid ++ str "): ") (mt()) pid ++ print_open_error_reason reason + | _ -> raise CErrors.Unhandled + end -let return p = +let return ?pid (p : t) = if not (is_done p) then - raise UnfinishedProof + raise (OpenProof(pid, UnfinishedProof)) else if has_shelved_goals p then - raise HasShelvedGoals + raise (OpenProof(pid, HasShelvedGoals)) else if has_given_up_goals p then - raise HasGivenUpGoals + raise (OpenProof(pid, HasGivenUpGoals)) else if has_unresolved_evar p then (* spiwack: for compatibility with <= 8.3 proof engine *) - raise HasUnresolvedEvar + raise (OpenProof(pid, HasUnresolvedEvar)) else let p = unfocus end_of_stack_kind p () in Proofview.return p.proofview @@ -449,11 +463,10 @@ module V82 = struct let grab_evars p = if not (is_done p) then - raise UnfinishedProof + raise (OpenProof(None, UnfinishedProof)) else { p with proofview = Proofview.V82.grab p.proofview } - (* Main component of vernac command Existential *) let instantiate_evar n com pr = let tac = diff --git a/proofs/proof.mli b/proofs/proof.mli index 8cf543557b..aaabea3454 100644 --- a/proofs/proof.mli +++ b/proofs/proof.mli @@ -89,11 +89,15 @@ val compact : t -> t Raises [HasShelvedGoals] if some goals are left on the shelf. Raises [HasGivenUpGoals] if some goals have been given up. Raises [HasUnresolvedEvar] if some evars have been left undefined. *) -exception UnfinishedProof -exception HasShelvedGoals -exception HasGivenUpGoals -exception HasUnresolvedEvar -val return : t -> Evd.evar_map +type open_error_reason = + | UnfinishedProof + | HasShelvedGoals + | HasGivenUpGoals + | HasUnresolvedEvar + +exception OpenProof of Names.Id.t option * open_error_reason + +val return : ?pid:Names.Id.t -> t -> Evd.evar_map (*** Focusing actions ***) diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index 25cf789193..cb4b5759dc 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -176,7 +176,6 @@ let simple_with_current_proof f = with_current_proof (fun t p -> f t p , ()) let compact_the_proof () = simple_with_current_proof (fun _ -> Proof.compact) - (* Sets the tactic to be used when a tactic line is closed with [...] *) let set_endline_tactic tac = match !pstates with @@ -416,20 +415,7 @@ let return_proof ?(allow_partial=false) () = proofs, Evd.evar_universe_context evd end else let initial_goals = Proof.initial_goals proof in - let evd = - let error s = - let prf = str " (in proof " ++ Id.print pid ++ str ")" in - raise (CErrors.UserError(Some "last tactic before Qed",s ++ prf)) - in - try Proof.return proof with - | Proof.UnfinishedProof -> - error(str"Attempt to save an incomplete proof") - | Proof.HasShelvedGoals -> - error(str"Attempt to save a proof with shelved goals") - | Proof.HasGivenUpGoals -> - error(strbrk"Attempt to save a proof with given up goals. If this is really what you want to do, use Admitted in place of Qed.") - | Proof.HasUnresolvedEvar-> - error(strbrk"Attempt to save a proof with existential variables still non-instantiated") in + let evd = Proof.return ~pid proof in let eff = Evd.eval_side_effects evd in let evd = Evd.minimize_universes evd in (** ppedrot: FIXME, this is surely wrong. There is no reason to duplicate diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli index 2b04bfab57..e3808bc36d 100644 --- a/proofs/proof_global.mli +++ b/proofs/proof_global.mli @@ -60,14 +60,14 @@ type closed_proof = proof_object * proof_terminator val make_terminator : (proof_ending -> unit) -> proof_terminator val apply_terminator : proof_terminator -> proof_ending -> unit -(** [start_proof id str pl goals terminator] starts a proof of name [id] - with goals [goals] (a list of pairs of environment and - conclusion); [str] describes what kind of theorem/definition this - is (spiwack: for potential printing, I believe is used only by - closing commands and the xml plugin); [terminator] is used at the - end of the proof to close the proof. The proof is started in the - evar map [sigma] (which can typically contain universe - constraints), and with universe bindings pl. *) +(** [start_proof id str pl goals terminator] starts a proof of name + [id] with goals [goals] (a list of pairs of environment and + conclusion); [str] describes what kind of theorem/definition this + is; [terminator] is used at the end of the proof to close the proof + (e.g. to declare the built constructions as a coercion or a setoid + morphism). The proof is started in the evar map [sigma] (which can + typically contain universe constraints), and with universe bindings + pl. *) val start_proof : Evd.evar_map -> Names.Id.t -> ?pl:UState.universe_decl -> Decl_kinds.goal_kind -> (Environ.env * EConstr.types) list -> diff --git a/proofs/proofs.mllib b/proofs/proofs.mllib index 197f71ca91..f9bb2c3d60 100644 --- a/proofs/proofs.mllib +++ b/proofs/proofs.mllib @@ -2,9 +2,9 @@ Miscprint Goal Evar_refiner Proof_type -Logic Refine Proof +Logic Goal_select Proof_bullet Proof_global diff --git a/proofs/redexpr.ml b/proofs/redexpr.ml index 56ce744bc1..0981584bb5 100644 --- a/proofs/redexpr.ml +++ b/proofs/redexpr.ml @@ -160,7 +160,7 @@ let make_flag env f = (fun v red -> red_sub red (make_flag_constant v)) f.rConst red else (* Only rConst *) - let red = red_add_transparent (red_add red fDELTA) all_opaque in + let red = red_add_transparent (red_add red fDELTA) TransparentState.empty in List.fold_right (fun v red -> red_add red (make_flag_constant v)) f.rConst red diff --git a/stm/stm.ml b/stm/stm.ml index b474bd502a..9359ab15e2 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -25,6 +25,7 @@ open CErrors open Names open Feedback open Vernacexpr +open Vernacextend module AsyncOpts = struct @@ -162,7 +163,7 @@ type branch_type = [ `Master | `Proof of proof_mode * depth | `Edit of - proof_mode * Stateid.t * Stateid.t * vernac_qed_type * Vcs_.Branch.t ] + proof_mode * Stateid.t * Stateid.t * Vernacextend.vernac_qed_type * Vcs_.Branch.t ] (* TODO 8.7 : split commands and tactics, since this type is too messy now *) type cmd_t = { ctac : bool; (* is a tactic *) @@ -174,7 +175,7 @@ type cmd_t = { | `TacQueue of solving_tac * anon_abstracting_tac * AsyncTaskQueue.cancel_switch | `QueryQueue of AsyncTaskQueue.cancel_switch | `SkipQueue ] } -type fork_t = aast * Vcs_.Branch.t * Vernacexpr.opacity_guarantee * Names.Id.t list +type fork_t = aast * Vcs_.Branch.t * opacity_guarantee * Names.Id.t list type qed_t = { qast : aast; keep : vernac_qed_type; diff --git a/stm/stm.mli b/stm/stm.mli index 95117f04f4..0c0e19ce5c 100644 --- a/stm/stm.mli +++ b/stm/stm.mli @@ -258,7 +258,7 @@ type dynamic_block_error_recovery = doc -> static_block_declaration -> [ `ValidBlock of recovery_action | `Leaks ] val register_proof_block_delimiter : - Vernacexpr.proof_block_name -> + Vernacextend.proof_block_name -> static_block_detection -> dynamic_block_error_recovery -> unit diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index 4db86817c9..526858bd73 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -12,6 +12,7 @@ open CErrors open Util open Pp open CAst +open Vernacextend open Vernacexpr let default_proof_mode () = Proof_global.get_default_proof_mode_name () [@ocaml.warning "-3"] @@ -209,7 +210,3 @@ let classify_vernac e = | (VtStartProof _ | VtUnknown), _ -> VtUnknown, VtNow) in static_control_classifier e - -let classify_as_query = VtQuery, VtLater -let classify_as_sideeff = VtSideff [], VtLater -let classify_as_proofstep = VtProofStep { parallel = `No; proof_block_detection = None}, VtLater diff --git a/stm/vernac_classifier.mli b/stm/vernac_classifier.mli index e82b191418..9d93ad1f39 100644 --- a/stm/vernac_classifier.mli +++ b/stm/vernac_classifier.mli @@ -8,16 +8,12 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Vernacexpr +open Vernacextend val string_of_vernac_classification : vernac_classification -> string (** What does a vernacular do *) -val classify_vernac : vernac_control -> vernac_classification - -(** Standard constant classifiers *) -val classify_as_query : vernac_classification -val classify_as_sideeff : vernac_classification -val classify_as_proofstep : vernac_classification +val classify_vernac : Vernacexpr.vernac_control -> vernac_classification +(** *) val stm_allow_nested_proofs_option_name : string list diff --git a/tactics/auto.ml b/tactics/auto.ml index 65b2615b6b..81e487b77d 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -45,7 +45,7 @@ let auto_core_unif_flags_of st1 st2 = { use_metas_eagerly_in_conv_on_closed_terms = false; use_evars_eagerly_in_conv_on_closed_terms = false; modulo_delta = st2; - modulo_delta_types = full_transparent_state; + modulo_delta_types = TransparentState.full; check_applied_meta_types = false; use_pattern_unification = false; use_meta_bound_pattern_unification = true; @@ -59,13 +59,13 @@ let auto_unif_flags_of st1 st2 = let flags = auto_core_unif_flags_of st1 st2 in { core_unify_flags = flags; merge_unify_flags = flags; - subterm_unify_flags = { flags with modulo_delta = empty_transparent_state }; + subterm_unify_flags = { flags with modulo_delta = TransparentState.empty }; allow_K_in_toplevel_higher_order_unification = false; resolve_evars = true } let auto_unif_flags = - auto_unif_flags_of full_transparent_state empty_transparent_state + auto_unif_flags_of TransparentState.full TransparentState.empty (* Try unification with the precompiled clause, then use registered Apply *) @@ -291,7 +291,7 @@ let flags_of_state st = auto_unif_flags_of st st let auto_flags_of_state st = - auto_unif_flags_of full_transparent_state st + auto_unif_flags_of TransparentState.full st let hintmap_of sigma secvars hdc concl = match hdc with @@ -358,12 +358,12 @@ and my_find_search_delta sigma db_list local_db secvars hdc concl = let flags = flags_of_state (Hint_db.transparent_state db) in List.map (fun x -> (Some flags, x)) (f db) else - let (ids, csts as st) = Hint_db.transparent_state db in + let st = Hint_db.transparent_state db in let flags, l = let l = match hdc with None -> Hint_db.map_none ~secvars db | Some hdc -> - if (Id.Pred.is_empty ids && Cpred.is_empty csts) + if TransparentState.is_empty st then Hint_db.map_auto sigma ~secvars hdc concl db else Hint_db.map_existential sigma ~secvars hdc concl db in auto_flags_of_state st, l diff --git a/tactics/auto.mli b/tactics/auto.mli index a835c1ed95..72d2292ffb 100644 --- a/tactics/auto.mli +++ b/tactics/auto.mli @@ -22,7 +22,7 @@ val compute_secvars : Proofview.Goal.t -> Id.Pred.t val default_search_depth : int ref -val auto_flags_of_state : transparent_state -> Unification.unify_flags +val auto_flags_of_state : TransparentState.t -> Unification.unify_flags val connect_hint_clenv : polymorphic -> raw_hint -> clausenv -> Proofview.Goal.t -> clausenv * constr diff --git a/tactics/btermdn.ml b/tactics/btermdn.ml index bfee0422e7..2f2bd8d2bc 100644 --- a/tactics/btermdn.ml +++ b/tactics/btermdn.ml @@ -69,13 +69,13 @@ let constr_pat_discr t = | PRef ((VarRef v) as ref), args -> Some(GRLabel ref,args) | _ -> None -let constr_val_discr_st sigma (idpred,cpred) t = +let constr_val_discr_st sigma ts t = let c, l = decomp sigma t in match EConstr.kind sigma c with - | Const (c,u) -> if Cpred.mem c cpred then Everything else Label(GRLabel (ConstRef c),l) + | Const (c,u) -> if TransparentState.is_transparent_constant ts c then Everything else Label(GRLabel (ConstRef c),l) | Ind (ind_sp,u) -> Label(GRLabel (IndRef ind_sp),l) | Construct (cstr_sp,u) -> Label(GRLabel (ConstructRef cstr_sp),l) - | Var id when not (Id.Pred.mem id idpred) -> Label(GRLabel (VarRef id),l) + | Var id when not (TransparentState.is_transparent_variable ts id) -> Label(GRLabel (VarRef id),l) | Prod (n, d, c) -> Label(ProdLabel, [d; c]) | Lambda (n, d, c) -> if List.is_empty l then @@ -85,15 +85,15 @@ let constr_val_discr_st sigma (idpred,cpred) t = | Evar _ -> Everything | _ -> Nothing -let constr_pat_discr_st (idpred,cpred) t = +let constr_pat_discr_st ts t = match decomp_pat t with | PRef ((IndRef _) as ref), args | PRef ((ConstructRef _ ) as ref), args -> Some (GRLabel ref,args) - | PRef ((VarRef v) as ref), args when not (Id.Pred.mem v idpred) -> + | PRef ((VarRef v) as ref), args when not (TransparentState.is_transparent_variable ts v) -> Some(GRLabel ref,args) - | PVar v, args when not (Id.Pred.mem v idpred) -> + | PVar v, args when not (TransparentState.is_transparent_variable ts v) -> Some(GRLabel (VarRef v),args) - | PRef ((ConstRef c) as ref), args when not (Cpred.mem c cpred) -> + | PRef ((ConstRef c) as ref), args when not (TransparentState.is_transparent_constant ts c) -> Some (GRLabel ref, args) | PProd (_, d, c), [] -> Some (ProdLabel, [d ; c]) | PLambda (_, d, c), [] -> Some (LambdaLabel, [d ; c]) diff --git a/tactics/btermdn.mli b/tactics/btermdn.mli index 861c9b6250..cc31fb0599 100644 --- a/tactics/btermdn.mli +++ b/tactics/btermdn.mli @@ -9,7 +9,6 @@ (************************************************************************) open Pattern -open Names (** Discrimination nets with bounded depth. *) @@ -19,7 +18,7 @@ open Names order in such a way patterns having the same prefix have this common prefix shared and the seek for the action associated to the patterns that a term matches are found in time proportional to the maximal -number of nodes of the patterns matching the term. The [transparent_state] +number of nodes of the patterns matching the term. The [TransparentState.t] indicates which constants and variables can be considered as rigid. These dnets are able to cope with existential variables as well, which match [Everything]. *) @@ -31,10 +30,10 @@ sig val empty : t - val add : transparent_state option -> t -> (constr_pattern * Z.t) -> t - val rmv : transparent_state option -> t -> (constr_pattern * Z.t) -> t + val add : TransparentState.t option -> t -> (constr_pattern * Z.t) -> t + val rmv : TransparentState.t option -> t -> (constr_pattern * Z.t) -> t - val lookup : Evd.evar_map -> transparent_state option -> t -> EConstr.constr -> Z.t list + val lookup : Evd.evar_map -> TransparentState.t option -> t -> EConstr.constr -> Z.t list val app : (Z.t -> unit) -> t -> unit end diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index 81cf9289d1..5959dd54b1 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -358,7 +358,7 @@ let rec e_trivial_fail_db only_classes db_list local_db secvars = Eauto.registered_e_assumption :: (tclTHEN Tactics.intro trivial_fail :: [trivial_resolve]) in - tclFIRST (List.map tclCOMPLETE tacl) + tclSOLVE tacl and e_my_find_search db_list local_db secvars hdc complete only_classes env sigma concl = let open Proofview.Notations in @@ -585,9 +585,9 @@ module Search = struct (** Local hints *) let autogoal_cache = Summary.ref ~name:"autogoal_cache" (DirPath.empty, true, Context.Named.empty, - Hint_db.empty full_transparent_state true) + Hint_db.empty TransparentState.full true) - let make_autogoal_hints only_classes ?(st=full_transparent_state) g = + let make_autogoal_hints only_classes ?(st=TransparentState.full) g = let open Proofview in let open Tacmach.New in let sign = Goal.hyps g in @@ -605,7 +605,7 @@ module Search = struct in autogoal_cache := (cwd, only_classes, sign, hints); hints - let make_autogoal ?(st=full_transparent_state) only_classes dep cut i g = + let make_autogoal ?(st=TransparentState.full) only_classes dep cut i g = let hints = make_autogoal_hints only_classes ~st g in { search_hints = hints; search_depth = [i]; last_tac = lazy (str"none"); @@ -843,7 +843,7 @@ module Search = struct let info = make_autogoal ?st only_classes dep (cut_of_hints hints) i gl in search_tac hints depth 1 info - let search_tac ?(st=full_transparent_state) only_classes dep hints depth = + let search_tac ?(st=TransparentState.full) only_classes dep hints depth = let open Proofview in let tac sigma gls i = Goal.enter @@ -873,7 +873,7 @@ module Search = struct | (e,ie) -> Proofview.tclZERO ~info:ie e) in aux 1 - let eauto_tac ?(st=full_transparent_state) ?(unique=false) + let eauto_tac ?(st=TransparentState.full) ?(unique=false) ~only_classes ?strategy ~depth ~dep hints = let open Proofview in let tac = @@ -985,7 +985,7 @@ end (** Binding to either V85 or Search implementations. *) -let typeclasses_eauto ?(only_classes=false) ?(st=full_transparent_state) +let typeclasses_eauto ?(only_classes=false) ?(st=TransparentState.full) ?strategy ~depth dbs = let dbs = List.map_filter (fun db -> try Some (searchtable_map db) diff --git a/tactics/class_tactics.mli b/tactics/class_tactics.mli index 9ba69a0584..46dff34f89 100644 --- a/tactics/class_tactics.mli +++ b/tactics/class_tactics.mli @@ -25,7 +25,7 @@ type search_strategy = Dfs | Bfs val set_typeclasses_strategy : search_strategy -> unit -val typeclasses_eauto : ?only_classes:bool -> ?st:transparent_state -> ?strategy:search_strategy -> +val typeclasses_eauto : ?only_classes:bool -> ?st:TransparentState.t -> ?strategy:search_strategy -> depth:(Int.t option) -> Hints.hint_db_name list -> unit Proofview.tactic @@ -39,7 +39,7 @@ val autoapply : constr -> Hints.hint_db_name -> unit Proofview.tactic module Search : sig val eauto_tac : - ?st:Names.transparent_state -> + ?st:TransparentState.t -> (** The transparent_state used when working with local hypotheses *) ?unique:bool -> (** Should we force a unique solution *) diff --git a/tactics/eauto.ml b/tactics/eauto.ml index 5067315d08..63ef4f850f 100644 --- a/tactics/eauto.ml +++ b/tactics/eauto.ml @@ -29,7 +29,7 @@ open Locusops open Hints open Proofview.Notations -let eauto_unif_flags = auto_flags_of_state full_transparent_state +let eauto_unif_flags = auto_flags_of_state TransparentState.full let e_give_exact ?(flags=eauto_unif_flags) c = Proofview.Goal.enter begin fun gl -> @@ -151,7 +151,7 @@ let rec e_trivial_fail_db db_list local_db = (Tacticals.New.tclTHEN Tactics.intro next) :: (List.map fst (e_trivial_resolve (Tacmach.New.pf_env gl) (Tacmach.New.project gl) db_list local_db secvars (Tacmach.New.pf_concl gl))) in - Tacticals.New.tclFIRST (List.map Tacticals.New.tclCOMPLETE tacl) + Tacticals.New.tclSOLVE tacl end and e_my_find_search env sigma db_list local_db secvars hdc concl = @@ -307,7 +307,7 @@ module SearchProblem = struct let gls = {Evd.it = gl; sigma = lgls.Evd.sigma } in let hyps' = pf_hyps gls in if hyps' == hyps then List.hd s.localdb - else make_local_hint_db (pf_env gls) (project gls) ~ts:full_transparent_state true s.local_lemmas) + else make_local_hint_db (pf_env gls) (project gls) ~ts:TransparentState.full true s.local_lemmas) (List.firstn ((nbgl'-nbgl) + 1) (sig_it lgls)) in { depth = pred s.depth; priority = cost; tacres = lgls; @@ -388,7 +388,7 @@ let make_initial_state dbg n gl dblist localdb lems = } let e_search_auto debug (in_depth,p) lems db_list gl = - let local_db = make_local_hint_db (pf_env gl) (project gl) ~ts:full_transparent_state true lems in + let local_db = make_local_hint_db (pf_env gl) (project gl) ~ts:TransparentState.full true lems in let d = mk_eauto_dbg debug in let tac = match in_depth,d with | (true,Debug) -> Search.debug_depth_first diff --git a/tactics/equality.ml b/tactics/equality.ml index c4a6b1605d..969f539d1f 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -101,8 +101,8 @@ let rewrite_core_unif_flags = { modulo_conv_on_closed_terms = None; use_metas_eagerly_in_conv_on_closed_terms = true; use_evars_eagerly_in_conv_on_closed_terms = false; - modulo_delta = empty_transparent_state; - modulo_delta_types = empty_transparent_state; + modulo_delta = TransparentState.empty; + modulo_delta_types = TransparentState.empty; check_applied_meta_types = true; use_pattern_unification = true; use_meta_bound_pattern_unification = true; @@ -169,7 +169,7 @@ let instantiate_lemma gl c ty l l2r concl = [eqclause] let rewrite_conv_closed_core_unif_flags = { - modulo_conv_on_closed_terms = Some full_transparent_state; + modulo_conv_on_closed_terms = Some TransparentState.full; (* We have this flag for historical reasons, it has e.g. the consequence *) (* to rewrite "?x+2" in "y+(1+1)=0" or to rewrite "?x+?x" in "2+(1+1)=0" *) @@ -178,8 +178,8 @@ let rewrite_conv_closed_core_unif_flags = { (* Combined with modulo_conv_on_closed_terms, this flag allows since 8.2 *) (* to rewrite e.g. "?x+(2+?x)" in "1+(1+2)=0" *) - modulo_delta = empty_transparent_state; - modulo_delta_types = full_transparent_state; + modulo_delta = TransparentState.empty; + modulo_delta_types = TransparentState.full; check_applied_meta_types = true; use_pattern_unification = true; (* To rewrite "?n x y" in "y+x=0" when ?n is *) @@ -204,7 +204,7 @@ let rewrite_conv_closed_unif_flags = { } let rewrite_keyed_core_unif_flags = { - modulo_conv_on_closed_terms = Some full_transparent_state; + modulo_conv_on_closed_terms = Some TransparentState.full; (* We have this flag for historical reasons, it has e.g. the consequence *) (* to rewrite "?x+2" in "y+(1+1)=0" or to rewrite "?x+?x" in "2+(1+1)=0" *) @@ -213,8 +213,8 @@ let rewrite_keyed_core_unif_flags = { (* Combined with modulo_conv_on_closed_terms, this flag allows since 8.2 *) (* to rewrite e.g. "?x+(2+?x)" in "1+(1+2)=0" *) - modulo_delta = full_transparent_state; - modulo_delta_types = full_transparent_state; + modulo_delta = TransparentState.full; + modulo_delta_types = TransparentState.full; check_applied_meta_types = true; use_pattern_unification = true; (* To rewrite "?n x y" in "y+x=0" when ?n is *) diff --git a/tactics/hints.ml b/tactics/hints.ml index 2f2d32e887..e64e08dbde 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -290,9 +290,9 @@ let lookup_tacs sigma concl st se = module Constr_map = Map.Make(GlobRef.Ordered) -let is_transparent_gr (ids, csts) = function - | VarRef id -> Id.Pred.mem id ids - | ConstRef cst -> Cpred.mem cst csts +let is_transparent_gr ts = function + | VarRef id -> TransparentState.is_transparent_variable ts id + | ConstRef cst -> TransparentState.is_transparent_constant ts cst | IndRef _ | ConstructRef _ -> false let strip_params env sigma c = @@ -497,7 +497,7 @@ type hint_db_name = string module Hint_db : sig type t -val empty : ?name:hint_db_name -> transparent_state -> bool -> t +val empty : ?name:hint_db_name -> TransparentState.t -> bool -> t val find : GlobRef.t -> t -> search_entry val map_none : secvars:Id.Pred.t -> t -> full_hint list val map_all : secvars:Id.Pred.t -> GlobRef.t -> t -> full_hint list @@ -513,8 +513,8 @@ val remove_one : GlobRef.t -> t -> t val remove_list : GlobRef.t list -> t -> t val iter : (GlobRef.t option -> hint_mode array list -> full_hint list -> unit) -> t -> unit val use_dn : t -> bool -val transparent_state : t -> transparent_state -val set_transparent_state : t -> transparent_state -> t +val transparent_state : t -> TransparentState.t +val set_transparent_state : t -> TransparentState.t -> t val add_cut : hints_path -> t -> t val add_mode : GlobRef.t -> hint_mode array -> t -> t val cut : t -> hints_path @@ -526,7 +526,7 @@ end = struct type t = { - hintdb_state : Names.transparent_state; + hintdb_state : TransparentState.t; hintdb_cut : hints_path; hintdb_unfolds : Id.Set.t * Cset.t; hintdb_max_id : int; @@ -663,10 +663,13 @@ struct let st',db,rebuild = match v.code.obj with | Unfold_nth egr -> - let addunf (ids,csts) (ids',csts') = + let addunf ts (ids, csts) = + let open TransparentState in match egr with - | EvalVarRef id -> (Id.Pred.add id ids, csts), (Id.Set.add id ids', csts') - | EvalConstRef cst -> (ids, Cpred.add cst csts), (ids', Cset.add cst csts') + | EvalVarRef id -> + { ts with tr_var = Id.Pred.add id ts.tr_var }, (Id.Set.add id ids, csts) + | EvalConstRef cst -> + { ts with tr_cst = Cpred.add cst ts.tr_cst }, (ids, Cset.add cst csts) in let state, unfs = addunf db.hintdb_state db.hintdb_unfolds in state, { db with hintdb_unfolds = unfs }, true @@ -740,8 +743,8 @@ let typeclasses_db = "typeclass_instances" let rewrite_db = "rewrite" let auto_init_db = - Hintdbmap.add typeclasses_db (Hint_db.empty full_transparent_state true) - (Hintdbmap.add rewrite_db (Hint_db.empty cst_full_transparent_state true) + Hintdbmap.add typeclasses_db (Hint_db.empty TransparentState.full true) + (Hintdbmap.add rewrite_db (Hint_db.empty TransparentState.cst_full true) Hintdbmap.empty) let searchtable = Summary.ref ~name:"searchtable" auto_init_db @@ -977,7 +980,7 @@ let make_trivial env sigma poly ?(name=PathAny) r = let get_db dbname = try searchtable_map dbname - with Not_found -> Hint_db.empty ~name:dbname empty_transparent_state false + with Not_found -> Hint_db.empty ~name:dbname TransparentState.empty false let add_hint dbname hintlist = let check (_, h) = @@ -995,18 +998,19 @@ let add_hint dbname hintlist = searchtable_add (dbname,db') let add_transparency dbname target b = + let open TransparentState in let db = get_db dbname in - let (ids, csts as st) = Hint_db.transparent_state db in + let st = Hint_db.transparent_state db in let st' = match target with - | HintsVariables -> (if b then Id.Pred.full else Id.Pred.empty), csts - | HintsConstants -> ids, if b then Cpred.full else Cpred.empty + | HintsVariables -> { st with tr_var = (if b then Id.Pred.full else Id.Pred.empty) } + | HintsConstants -> { st with tr_cst = (if b then Cpred.full else Cpred.empty) } | HintsReferences grs -> - List.fold_left (fun (ids, csts) gr -> - match gr with - | EvalConstRef c -> (ids, (if b then Cpred.add else Cpred.remove) c csts) - | EvalVarRef v -> (if b then Id.Pred.add else Id.Pred.remove) v ids, csts) - st grs + List.fold_left (fun st gr -> + match gr with + | EvalConstRef c -> { st with tr_cst = (if b then Cpred.add else Cpred.remove) c st.tr_cst } + | EvalVarRef v -> { st with tr_var = (if b then Id.Pred.add else Id.Pred.remove) v st.tr_var }) + st grs in searchtable_add (dbname, Hint_db.set_transparent_state db st') let remove_hint dbname grs = @@ -1015,7 +1019,7 @@ let remove_hint dbname grs = searchtable_add (dbname, db') type hint_action = - | CreateDB of bool * transparent_state + | CreateDB of bool * TransparentState.t | AddTransparency of evaluable_global_reference hints_transparency_target * bool | AddHints of hint_entry list | RemoveHints of GlobRef.t list @@ -1373,10 +1377,10 @@ let interp_hints poly = let _, tacexp = Genintern.generic_intern env tacexp in HintsExternEntry ({ hint_priority = Some pri; hint_pattern = pat }, tacexp) -let add_hints ~local dbnames0 h = - if String.List.mem "nocore" dbnames0 then +let add_hints ~local dbnames h = + if String.List.mem "nocore" dbnames then user_err Pp.(str "The hint database \"nocore\" is meant to stay empty."); - let dbnames = if List.is_empty dbnames0 then ["core"] else dbnames0 in + assert (not (List.is_empty dbnames)); let env = Global.env() in let sigma = Evd.from_env env in match h with @@ -1543,7 +1547,7 @@ let pr_hint_db_env env sigma db = in Hint_db.fold fold db (mt ()) in - let (ids, csts) = Hint_db.transparent_state db in + let { TransparentState.tr_var = ids; tr_cst = csts } = Hint_db.transparent_state db in hov 0 ((if Hint_db.use_dn db then str"Discriminated database" else str"Non-discriminated database")) ++ fnl () ++ diff --git a/tactics/hints.mli b/tactics/hints.mli index 6db8feccd0..dd2c63d351 100644 --- a/tactics/hints.mli +++ b/tactics/hints.mli @@ -122,7 +122,7 @@ val glob_hints_path : module Hint_db : sig type t - val empty : ?name:hint_db_name -> transparent_state -> bool -> t + val empty : ?name:hint_db_name -> TransparentState.t -> bool -> t val find : GlobRef.t -> t -> search_entry (** All hints which have no pattern. @@ -155,8 +155,8 @@ module Hint_db : hint_mode array list -> full_hint list -> unit) -> t -> unit val use_dn : t -> bool - val transparent_state : t -> transparent_state - val set_transparent_state : t -> transparent_state -> t + val transparent_state : t -> TransparentState.t + val set_transparent_state : t -> TransparentState.t -> t val add_cut : hints_path -> t -> t val cut : t -> hints_path @@ -191,7 +191,7 @@ val searchtable_add : (hint_db_name * hint_db) -> unit [use_dn] switches the use of the discrimination net for all hints and patterns. *) -val create_hint_db : bool -> hint_db_name -> transparent_state -> bool -> unit +val create_hint_db : bool -> hint_db_name -> TransparentState.t -> bool -> unit val remove_hints : bool -> hint_db_name list -> GlobRef.t list -> unit @@ -273,7 +273,7 @@ val repr_hint : hint -> (raw_hint * clausenv) hint_ast Useful to take the current goal hypotheses as hints; Boolean tells if lemmas with evars are allowed *) -val make_local_hint_db : env -> evar_map -> ?ts:transparent_state -> bool -> delayed_open_constr list -> hint_db +val make_local_hint_db : env -> evar_map -> ?ts:TransparentState.t -> bool -> delayed_open_constr list -> hint_db val make_db_list : hint_db_name list -> hint_db list diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 1646906daa..349cfce205 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -1152,7 +1152,6 @@ let rec intros_move = function let tactic_infer_flags with_evar = { Pretyping.use_typeclasses = true; Pretyping.solve_unification_constraints = true; - Pretyping.use_hook = Pfedit.solve_by_implicit_tactic (); Pretyping.fail_evar = not with_evar; Pretyping.expand_evars = true } @@ -1661,7 +1660,7 @@ let general_apply ?(respect_opaque=false) with_delta with_destruct with_evars let sigma = Tacmach.New.project gl in let ts = if respect_opaque then Conv_oracle.get_transp_state (oracle env) - else full_transparent_state + else TransparentState.full in let flags = if with_delta then default_unify_flags () else default_no_delta_unify_flags ts in @@ -1827,7 +1826,7 @@ let apply_in_once ?(respect_opaque = false) sidecond_first with_delta let sigma = Tacmach.New.project gl in let ts = if respect_opaque then Conv_oracle.get_transp_state (oracle env) - else full_transparent_state + else TransparentState.full in let flags = if with_delta then default_unify_flags () else default_no_delta_unify_flags ts in @@ -4910,7 +4909,7 @@ let constr_eq ~strict x y = | None -> fail end -let unify ?(state=full_transparent_state) x y = +let unify ?(state=TransparentState.full) x y = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in @@ -4923,7 +4922,7 @@ let unify ?(state=full_transparent_state) x y = let flags = { (default_unify_flags ()) with core_unify_flags = core_flags; merge_unify_flags = core_flags; - subterm_unify_flags = { core_flags with modulo_delta = empty_transparent_state } } + subterm_unify_flags = { core_flags with modulo_delta = TransparentState.empty } } in let sigma = w_unify (Tacmach.New.pf_env gl) sigma Reduction.CONV ~flags x y in Proofview.Unsafe.tclEVARS sigma diff --git a/tactics/tactics.mli b/tactics/tactics.mli index b298524ff8..4e91a9a728 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -419,7 +419,7 @@ val generalize_dep : ?with_let:bool (** Don't lose let bindings *) -> constr - are added to the evar map. *) val constr_eq : strict:bool -> constr -> constr -> unit Proofview.tactic -val unify : ?state:Names.transparent_state -> constr -> constr -> unit Proofview.tactic +val unify : ?state:TransparentState.t -> constr -> constr -> unit Proofview.tactic val abstract_generalize : ?generalize_vars:bool -> ?force_dep:bool -> Id.t -> unit Proofview.tactic val specialize_eqs : Id.t -> unit Proofview.tactic diff --git a/test-suite/bugs/closed/bug_2001.v b/test-suite/bugs/closed/bug_2001.v index 652c65706a..31c62b7b36 100644 --- a/test-suite/bugs/closed/bug_2001.v +++ b/test-suite/bugs/closed/bug_2001.v @@ -1,12 +1,10 @@ (* Automatic computing of guard in "Theorem with"; check that guard is not computed when the user explicitly indicated it *) -Unset Automatic Introduction. - Inductive T : Set := | v : T. -Definition f (s:nat) (t:T) : nat. +Definition f : forall (s:nat) (t:T), nat. fix f 2. intros s t. refine diff --git a/test-suite/bugs/closed/gh6165.v b/test-suite/bugs/closed/bug_6165.v index b87a7caaf2..b87a7caaf2 100644 --- a/test-suite/bugs/closed/gh6165.v +++ b/test-suite/bugs/closed/bug_6165.v diff --git a/test-suite/bugs/closed/gh6384.v b/test-suite/bugs/closed/bug_6384.v index cec84642fb..cec84642fb 100644 --- a/test-suite/bugs/closed/gh6384.v +++ b/test-suite/bugs/closed/bug_6384.v diff --git a/test-suite/bugs/closed/gh6385.v b/test-suite/bugs/closed/bug_6385.v index 3bbb664f4f..3bbb664f4f 100644 --- a/test-suite/bugs/closed/gh6385.v +++ b/test-suite/bugs/closed/bug_6385.v diff --git a/test-suite/bugs/closed/bug_6661.v b/test-suite/bugs/closed/bug_6661.v index e88a3704d8..28a9ffc7bd 100644 --- a/test-suite/bugs/closed/bug_6661.v +++ b/test-suite/bugs/closed/bug_6661.v @@ -53,8 +53,6 @@ Definition foo (X:Type) (xy : @total2 X (λ _, X)) : X. exact x. Defined. -Unset Automatic Introduction. - Definition idfun (T : UU) := λ t:T, t. Definition pathscomp0 {X : UU} {a b c : X} (e1 : a = b) (e2 : b = c) : a = c. diff --git a/test-suite/output/PrintUnivsSubgraph.out b/test-suite/output/PrintUnivsSubgraph.out new file mode 100644 index 0000000000..c42e15e4e8 --- /dev/null +++ b/test-suite/output/PrintUnivsSubgraph.out @@ -0,0 +1,5 @@ +Prop < Set +Set < i + < j +i < j + diff --git a/test-suite/output/PrintUnivsSubgraph.v b/test-suite/output/PrintUnivsSubgraph.v new file mode 100644 index 0000000000..ec9cf44d4f --- /dev/null +++ b/test-suite/output/PrintUnivsSubgraph.v @@ -0,0 +1,9 @@ + +Universes i j k l. + +Definition foo : Type@{j} := Type@{i}. + +Definition baz : Type@{k} := Type@{l}. + +Print Universes Subgraph(i j). +(* should print [i < j], not [l < k] (and not prelude universes) *) diff --git a/test-suite/output/UnivBinders.out b/test-suite/output/UnivBinders.out index d63b6dbfce..4d3f7419e6 100644 --- a/test-suite/output/UnivBinders.out +++ b/test-suite/output/UnivBinders.out @@ -41,8 +41,7 @@ Arguments A, Wrap are implicit and maximally inserted Argument scopes are [type_scope _] Polymorphic bar@{u} = nat : Wrap@{u} Set -(* u |= Set < u - *) +(* u |= Set < u *) bar is universe polymorphic Polymorphic foo@{u UnivBinders.17 v} = diff --git a/test-suite/success/Fixpoint.v b/test-suite/success/Fixpoint.v index efb32ef6f7..81c9763ccd 100644 --- a/test-suite/success/Fixpoint.v +++ b/test-suite/success/Fixpoint.v @@ -50,8 +50,6 @@ End folding. (* Check definition by tactics *) -Set Automatic Introduction. - Inductive even : nat -> Type := | even_O : even 0 | even_S : forall n, odd n -> even (S n) diff --git a/test-suite/success/Require.v b/test-suite/success/Require.v index f851d8c7d9..de5987c4f7 100644 --- a/test-suite/success/Require.v +++ b/test-suite/success/Require.v @@ -1,3 +1,8 @@ +(* -*- coq-prog-args: ("-noinit"); -*- *) + Require Import Coq.Arith.Plus. Require Coq.Arith.Minus. Locate Library Coq.Arith.Minus. + +(* Check that Init didn't get exported by the import above *) +Fail Check nat. diff --git a/test-suite/success/autointros.v b/test-suite/success/autointros.v index 0a0812711c..1140a537fc 100644 --- a/test-suite/success/autointros.v +++ b/test-suite/success/autointros.v @@ -1,5 +1,3 @@ -Set Automatic Introduction. - Inductive even : nat -> Prop := | even_0 : even 0 | even_odd : forall n, odd n -> even (S n) diff --git a/theories/Bool/Bool.v b/theories/Bool/Bool.v index 42af3583d4..075288e216 100644 --- a/theories/Bool/Bool.v +++ b/theories/Bool/Bool.v @@ -48,7 +48,7 @@ Proof. discriminate. Qed. Hint Resolve diff_false_true : bool. -Hint Extern 1 (false <> true) => exact diff_false_true. +Hint Extern 1 (false <> true) => exact diff_false_true : core. Lemma eq_true_false_abs : forall b:bool, b = true -> b = false -> False. Proof. @@ -621,7 +621,7 @@ Lemma absurd_eq_true : forall b, False -> b = true. Proof. contradiction. Qed. -Hint Resolve absurd_eq_true. +Hint Resolve absurd_eq_true : core. (* A specific instance of eq_trans that preserves compatibility with old hint bool_2 *) @@ -630,7 +630,7 @@ Lemma trans_eq_bool : forall x y z:bool, x = y -> y = z -> x = z. Proof. apply eq_trans. Qed. -Hint Resolve trans_eq_bool. +Hint Resolve trans_eq_bool : core. (*****************************************) (** * Reflection of [bool] into [Prop] *) diff --git a/theories/Classes/RelationPairs.v b/theories/Classes/RelationPairs.v index 7af2b0fc45..3e6358c8f3 100644 --- a/theories/Classes/RelationPairs.v +++ b/theories/Classes/RelationPairs.v @@ -157,6 +157,6 @@ Section RelProd_Instances. Proof. unfold RelCompFun; firstorder. Qed. End RelProd_Instances. -Hint Unfold RelProd RelCompFun. -Hint Extern 2 (RelProd _ _ _ _) => split. +Hint Unfold RelProd RelCompFun : core. +Hint Extern 2 (RelProd _ _ _ _) => split : core. diff --git a/theories/FSets/FMapAVL.v b/theories/FSets/FMapAVL.v index b0d1824827..8fc04d81e6 100644 --- a/theories/FSets/FMapAVL.v +++ b/theories/FSets/FMapAVL.v @@ -41,7 +41,7 @@ Local Open Scope Int_scope. Local Notation int := I.t. Definition key := X.t. -Hint Transparent key. +Hint Transparent key : core. (** * Trees *) @@ -488,8 +488,8 @@ Functional Scheme map2_opt_ind := Induction for map2_opt Sort Prop. (** * Automation and dedicated tactics. *) -Hint Constructors tree MapsTo In bst. -Hint Unfold lt_tree gt_tree. +Hint Constructors tree MapsTo In bst : core. +Hint Unfold lt_tree gt_tree : core. Tactic Notation "factornode" ident(l) ident(x) ident(d) ident(r) ident(h) "as" ident(s) := @@ -569,7 +569,7 @@ Lemma MapsTo_In : forall k e m, MapsTo k e m -> In k m. Proof. induction 1; auto. Qed. -Hint Resolve MapsTo_In. +Hint Resolve MapsTo_In : core. Lemma In_MapsTo : forall k m, In k m -> exists e, MapsTo k e m. Proof. @@ -588,7 +588,7 @@ Lemma MapsTo_1 : Proof. induction m; simpl; intuition_in; eauto. Qed. -Hint Immediate MapsTo_1. +Hint Immediate MapsTo_1 : core. Lemma In_1 : forall m x y, X.eq x y -> In x m -> In y m. @@ -627,7 +627,7 @@ Proof. unfold gt_tree in *; intuition_in; order. Qed. -Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node. +Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node : core. Lemma lt_left : forall x y l r e h, lt_tree x (Node l y e r h) -> lt_tree x l. @@ -653,7 +653,7 @@ Proof. intuition_in. Qed. -Hint Resolve lt_left lt_right gt_left gt_right. +Hint Resolve lt_left lt_right gt_left gt_right : core. Lemma lt_tree_not_in : forall x m, lt_tree x m -> ~ In x m. @@ -679,7 +679,7 @@ Proof. eauto. Qed. -Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans. +Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans : core. (** * Empty map *) @@ -811,7 +811,7 @@ Lemma create_bst : Proof. unfold create; auto. Qed. -Hint Resolve create_bst. +Hint Resolve create_bst : core. Lemma create_in : forall l x e r y, @@ -828,7 +828,7 @@ Proof. (apply lt_tree_node || apply gt_tree_node); auto; (eapply lt_tree_trans || eapply gt_tree_trans); eauto. Qed. -Hint Resolve bal_bst. +Hint Resolve bal_bst : core. Lemma bal_in : forall l x e r y, In y (bal l x e r) <-> X.eq y x \/ In y l \/ In y r. @@ -869,7 +869,7 @@ Proof. apply MX.eq_lt with x; auto. apply MX.lt_eq with x; auto. Qed. -Hint Resolve add_bst. +Hint Resolve add_bst : core. Lemma add_1 : forall m x y e, X.eq x y -> MapsTo y e (add x e m). Proof. @@ -949,7 +949,7 @@ Proof. destruct 1. apply H2; intuition. Qed. -Hint Resolve remove_min_bst. +Hint Resolve remove_min_bst : core. Lemma remove_min_gt_tree : forall l x e r h, bst (Node l x e r h) -> @@ -968,7 +968,7 @@ Proof. assert (X.lt m#1 x) by order. decompose [or] H; order. Qed. -Hint Resolve remove_min_gt_tree. +Hint Resolve remove_min_gt_tree : core. Lemma remove_min_find : forall l x e r h y, bst (Node l x e r h) -> @@ -1120,7 +1120,7 @@ Proof. intuition; [ apply MX.lt_eq with x | ]; eauto. intuition; [ apply MX.eq_lt with x | ]; eauto. Qed. -Hint Resolve join_bst. +Hint Resolve join_bst : core. Lemma join_find : forall l x d r y, bst l -> bst r -> lt_tree x l -> gt_tree x r -> @@ -1256,7 +1256,7 @@ Proof. rewrite remove_min_in, e1; simpl; auto. change (gt_tree (m2',xd)#2#1 (m2',xd)#1). rewrite <-e1; eauto. Qed. -Hint Resolve concat_bst. +Hint Resolve concat_bst : core. Lemma concat_find : forall m1 m2 y, bst m1 -> bst m2 -> (forall y1 y2, In y1 m1 -> In y2 m2 -> X.lt y1 y2) -> @@ -1344,7 +1344,7 @@ Proof. intros; unfold elements; apply elements_aux_sort; auto. intros; inversion H0. Qed. -Hint Resolve elements_sort. +Hint Resolve elements_sort : core. Lemma elements_nodup : forall s : t elt, bst s -> NoDupA eqk (elements s). Proof. @@ -1612,7 +1612,7 @@ destruct (map_option_2 H) as (d0 & ? & ?). destruct (map_option_2 H') as (d0' & ? & ?). eapply X.lt_trans with x; eauto using MapsTo_In. Qed. -Hint Resolve map_option_bst. +Hint Resolve map_option_bst : core. Ltac nonify e := replace e with (@None elt) by @@ -1711,7 +1711,7 @@ apply X.lt_trans with x1. destruct (map2_opt_2 H1 H6 Hy); intuition. destruct (map2_opt_2 H2 H7 Hy'); intuition. Qed. -Hint Resolve map2_opt_bst. +Hint Resolve map2_opt_bst : core. Ltac map2_aux := match goal with @@ -2066,7 +2066,7 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: Proof. destruct c; simpl; intros; P.MX.elim_comp; auto. Qed. - Hint Resolve cons_Cmp. + Hint Resolve cons_Cmp : core. Lemma compare_end_Cmp : forall e2, Cmp (compare_end e2) nil (P.flatten_e e2). diff --git a/theories/FSets/FMapFacts.v b/theories/FSets/FMapFacts.v index 2d5a79838a..d19c5558d8 100644 --- a/theories/FSets/FMapFacts.v +++ b/theories/FSets/FMapFacts.v @@ -20,7 +20,7 @@ Require Export FMapInterface. Set Implicit Arguments. Unset Strict Implicit. -Hint Extern 1 (Equivalence _) => constructor; congruence. +Hint Extern 1 (Equivalence _) => constructor; congruence : core. (** * Facts about weak maps *) diff --git a/theories/FSets/FMapFullAVL.v b/theories/FSets/FMapFullAVL.v index c0db8646c7..950b30ee4d 100644 --- a/theories/FSets/FMapFullAVL.v +++ b/theories/FSets/FMapFullAVL.v @@ -63,7 +63,7 @@ Inductive avl : t elt -> Prop := (** * Automation and dedicated tactics about [avl]. *) -Hint Constructors avl. +Hint Constructors avl : core. Lemma height_non_negative : forall (s : t elt), avl s -> height s >= 0. @@ -100,7 +100,7 @@ Lemma avl_node : forall x e l r, avl l -> avl r -> Proof. intros; auto. Qed. -Hint Resolve avl_node. +Hint Resolve avl_node : core. (** Results about [height] *) @@ -193,7 +193,7 @@ Lemma add_avl : forall m x e, avl m -> avl (add x e m). Proof. intros; generalize (add_avl_1 x e H); intuition. Qed. -Hint Resolve add_avl. +Hint Resolve add_avl : core. (** * Extraction of minimum binding *) @@ -274,7 +274,7 @@ Lemma remove_avl : forall m x, avl m -> avl (remove x m). Proof. intros; generalize (remove_avl_1 x H); intuition. Qed. -Hint Resolve remove_avl. +Hint Resolve remove_avl : core. (** * Join *) @@ -331,7 +331,7 @@ Lemma join_avl : forall l x d r, avl l -> avl r -> avl (join l x d r). Proof. intros; destruct (join_avl_1 x d H H0); auto. Qed. -Hint Resolve join_avl. +Hint Resolve join_avl : core. (** concat *) @@ -341,7 +341,7 @@ Proof. intros; apply join_avl; auto. generalize (remove_min_avl H0); rewrite e1; simpl; auto. Qed. -Hint Resolve concat_avl. +Hint Resolve concat_avl : core. (** split *) @@ -355,7 +355,7 @@ Proof. Qed. End Elt. -Hint Constructors avl. +Hint Constructors avl : core. Section Map. Variable elt elt' : Type. @@ -713,7 +713,7 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: Proof. destruct c; simpl; intros; MX.elim_comp; auto. Qed. - Hint Resolve cons_Cmp. + Hint Resolve cons_Cmp : core. Lemma compare_aux_Cmp : forall e, Cmp (compare_aux e) (flatten_e (fst e)) (flatten_e (snd e)). diff --git a/theories/FSets/FMapInterface.v b/theories/FSets/FMapInterface.v index 38a96dc393..8970529103 100644 --- a/theories/FSets/FMapInterface.v +++ b/theories/FSets/FMapInterface.v @@ -58,7 +58,7 @@ Definition Cmp (elt:Type)(cmp:elt->elt->bool) e1 e2 := cmp e1 e2 = true. Module Type WSfun (E : DecidableType). Definition key := E.t. - Hint Transparent key. + Hint Transparent key : core. Parameter t : Type -> Type. (** the abstract type of maps *) diff --git a/theories/FSets/FMapList.v b/theories/FSets/FMapList.v index 3e98d11976..6ca158a277 100644 --- a/theories/FSets/FMapList.v +++ b/theories/FSets/FMapList.v @@ -51,7 +51,7 @@ Proof. intro abs. inversion abs. Qed. -Hint Resolve empty_1. +Hint Resolve empty_1 : core. Lemma empty_sorted : Sort empty. Proof. @@ -216,7 +216,7 @@ Proof. compute in H0,H1. simpl; case (X.compare x x''); intuition. Qed. -Hint Resolve add_Inf. +Hint Resolve add_Inf : core. Lemma add_sorted : forall m (Hm:Sort m) x e, Sort (add x e m). Proof. @@ -302,7 +302,7 @@ Proof. inversion_clear Hm. apply Inf_lt with (x'',e''); auto. Qed. -Hint Resolve remove_Inf. +Hint Resolve remove_Inf : core. Lemma remove_sorted : forall m (Hm:Sort m) x, Sort (remove x m). Proof. @@ -586,7 +586,7 @@ Proof. inversion_clear H; auto. Qed. -Hint Resolve map_lelistA. +Hint Resolve map_lelistA : core. Lemma map_sorted : forall (m: t elt)(Hm : sort (@ltk elt) m)(f:elt -> elt'), sort (@ltk elt') (map f m). @@ -654,7 +654,7 @@ Proof. inversion_clear H; auto. Qed. -Hint Resolve mapi_lelistA. +Hint Resolve mapi_lelistA : core. Lemma mapi_sorted : forall m (Hm : sort (@ltk elt) m)(f: key ->elt -> elt'), sort (@ltk elt') (mapi f m). @@ -781,7 +781,7 @@ Proof. inversion_clear H; auto. inversion_clear H0; auto. Qed. -Hint Resolve combine_lelistA. +Hint Resolve combine_lelistA : core. Lemma combine_sorted : forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m'), diff --git a/theories/FSets/FMapWeakList.v b/theories/FSets/FMapWeakList.v index 6736096509..03dce9666d 100644 --- a/theories/FSets/FMapWeakList.v +++ b/theories/FSets/FMapWeakList.v @@ -49,7 +49,7 @@ Proof. inversion abs. Qed. -Hint Resolve empty_1. +Hint Resolve empty_1 : core. Lemma empty_NoDup : NoDupA empty. Proof. @@ -621,7 +621,7 @@ Proof. inversion_clear 1. intros; apply add_NoDup; auto. Qed. -Hint Resolve fold_right_pair_NoDup. +Hint Resolve fold_right_pair_NoDup : core. Lemma combine_NoDup : forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m'), diff --git a/theories/FSets/FSetBridge.v b/theories/FSets/FSetBridge.v index 0c4ecb1f31..3952c28061 100644 --- a/theories/FSets/FSetBridge.v +++ b/theories/FSets/FSetBridge.v @@ -137,7 +137,7 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E. generalize (E.eq_sym H0); case (Pdec x); case (Pdec y); firstorder. Qed. - Hint Resolve compat_P_aux. + Hint Resolve compat_P_aux : core. Definition filter : forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) (s : t), @@ -467,7 +467,7 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E. Proof. intros; unfold elements; case (M.elements s); firstorder. Qed. - Hint Resolve elements_3. + Hint Resolve elements_3 : core. Lemma elements_3w : forall s : t, NoDupA E.eq (elements s). Proof. auto. Qed. @@ -666,7 +666,7 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E. rewrite <- H1; firstorder. Qed. - Hint Resolve compat_P_aux. + Hint Resolve compat_P_aux : core. Definition filter (f : elt -> bool) (s : t) : t := let (s', _) := filter (P:=fun x => f x = true) (f_dec f) s in s'. diff --git a/theories/FSets/FSetInterface.v b/theories/FSets/FSetInterface.v index 0926d3ae9f..fa7f1c5f4e 100644 --- a/theories/FSets/FSetInterface.v +++ b/theories/FSets/FSetInterface.v @@ -253,7 +253,7 @@ Module Type WSfun (E : DecidableType). End Spec. - Hint Transparent elt. + Hint Transparent elt : core. Hint Resolve mem_1 equal_1 subset_1 empty_1 is_empty_1 choose_1 choose_2 add_1 add_2 remove_1 remove_2 singleton_2 union_1 union_2 union_3 diff --git a/theories/FSets/FSetProperties.v b/theories/FSets/FSetProperties.v index c9cfb94ace..17f0e25e7a 100644 --- a/theories/FSets/FSetProperties.v +++ b/theories/FSets/FSetProperties.v @@ -21,8 +21,8 @@ Require Import DecidableTypeEx FSetFacts FSetDecide. Set Implicit Arguments. Unset Strict Implicit. -Hint Unfold transpose compat_op Proper respectful. -Hint Extern 1 (Equivalence _) => constructor; congruence. +Hint Unfold transpose compat_op Proper respectful : core. +Hint Extern 1 (Equivalence _) => constructor; congruence : core. (** First, a functor for Weak Sets in functorial version. *) @@ -732,7 +732,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). Proof. intros; rewrite cardinal_Empty; auto. Qed. - Hint Resolve cardinal_inv_1. + Hint Resolve cardinal_inv_1 : core. Lemma cardinal_inv_2 : forall s n, cardinal s = S n -> { x : elt | In x s }. @@ -769,7 +769,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). exact Equal_cardinal. Qed. - Hint Resolve Add_add Add_remove Equal_remove cardinal_inv_1 Equal_cardinal. + Hint Resolve Add_add Add_remove Equal_remove cardinal_inv_1 Equal_cardinal : core. (** ** Cardinal and set operators *) @@ -887,7 +887,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). auto with set. Qed. - Hint Resolve subset_cardinal union_cardinal add_cardinal_1 add_cardinal_2. + Hint Resolve subset_cardinal union_cardinal add_cardinal_1 add_cardinal_2 : core. End WProperties_fun. @@ -952,7 +952,7 @@ Module OrdProperties (M:S). red; intros x a b H; unfold leb. f_equal; apply gtb_compat; auto. Qed. - Hint Resolve gtb_compat leb_compat. + Hint Resolve gtb_compat leb_compat : core. Lemma elements_split : forall x s, elements s = elements_lt x s ++ elements_ge x s. diff --git a/theories/Init/Datatypes.v b/theories/Init/Datatypes.v index 75f14bb4da..7f0387dd12 100644 --- a/theories/Init/Datatypes.v +++ b/theories/Init/Datatypes.v @@ -136,7 +136,7 @@ Defined. Inductive BoolSpec (P Q : Prop) : bool -> Prop := | BoolSpecT : P -> BoolSpec P Q true | BoolSpecF : Q -> BoolSpec P Q false. -Hint Constructors BoolSpec. +Hint Constructors BoolSpec : core. (********************************************************************) @@ -344,7 +344,7 @@ Inductive CompareSpec (Peq Plt Pgt : Prop) : comparison -> Prop := | CompEq : Peq -> CompareSpec Peq Plt Pgt Eq | CompLt : Plt -> CompareSpec Peq Plt Pgt Lt | CompGt : Pgt -> CompareSpec Peq Plt Pgt Gt. -Hint Constructors CompareSpec. +Hint Constructors CompareSpec : core. (** For having clean interfaces after extraction, [CompareSpec] is declared in Prop. For some situations, it is nonetheless useful to have a @@ -354,7 +354,7 @@ Inductive CompareSpecT (Peq Plt Pgt : Prop) : comparison -> Type := | CompEqT : Peq -> CompareSpecT Peq Plt Pgt Eq | CompLtT : Plt -> CompareSpecT Peq Plt Pgt Lt | CompGtT : Pgt -> CompareSpecT Peq Plt Pgt Gt. -Hint Constructors CompareSpecT. +Hint Constructors CompareSpecT : core. Lemma CompareSpec2Type : forall Peq Plt Pgt c, CompareSpec Peq Plt Pgt c -> CompareSpecT Peq Plt Pgt c. @@ -371,7 +371,7 @@ Definition CompSpec {A} (eq lt : A->A->Prop)(x y:A) : comparison -> Prop := Definition CompSpecT {A} (eq lt : A->A->Prop)(x y:A) : comparison -> Type := CompareSpecT (eq x y) (lt x y) (lt y x). -Hint Unfold CompSpec CompSpecT. +Hint Unfold CompSpec CompSpecT : core. Lemma CompSpec2Type : forall A (eq lt:A->A->Prop) x y c, CompSpec eq lt x y c -> CompSpecT eq lt x y c. diff --git a/theories/Lists/List.v b/theories/Lists/List.v index 4614d215eb..d5241e622c 100644 --- a/theories/Lists/List.v +++ b/theories/Lists/List.v @@ -219,7 +219,7 @@ Section Facts. Proof. auto using app_assoc. Qed. - Hint Resolve app_assoc_reverse. + Hint Resolve app_assoc_reverse : core. (* end hide *) (** [app] commutes with [cons] *) @@ -1569,19 +1569,19 @@ Section SetIncl. Variable A : Type. Definition incl (l m:list A) := forall a:A, In a l -> In a m. - Hint Unfold incl. + Hint Unfold incl : core. Lemma incl_refl : forall l:list A, incl l l. Proof. auto. Qed. - Hint Resolve incl_refl. + Hint Resolve incl_refl : core. Lemma incl_tl : forall (a:A) (l m:list A), incl l m -> incl l (a :: m). Proof. auto with datatypes. Qed. - Hint Immediate incl_tl. + Hint Immediate incl_tl : core. Lemma incl_tran : forall l m n:list A, incl l m -> incl m n -> incl l n. Proof. @@ -1592,13 +1592,13 @@ Section SetIncl. Proof. auto with datatypes. Qed. - Hint Immediate incl_appl. + Hint Immediate incl_appl : core. Lemma incl_appr : forall l m n:list A, incl l n -> incl l (m ++ n). Proof. auto with datatypes. Qed. - Hint Immediate incl_appr. + Hint Immediate incl_appr : core. Lemma incl_cons : forall (a:A) (l m:list A), In a m -> incl l m -> incl (a :: l) m. @@ -1613,7 +1613,7 @@ Section SetIncl. now_show (In a0 l -> In a0 m). auto. Qed. - Hint Resolve incl_cons. + Hint Resolve incl_cons : core. Lemma incl_app : forall l m n:list A, incl l n -> incl m n -> incl (l ++ m) n. Proof. @@ -1621,7 +1621,7 @@ Section SetIncl. now_show (In a n). elim (in_app_or _ _ _ H1); auto. Qed. - Hint Resolve incl_app. + Hint Resolve incl_app : core. End SetIncl. @@ -2180,7 +2180,7 @@ Section Exists_Forall. | Exists_cons_hd : forall x l, P x -> Exists (x::l) | Exists_cons_tl : forall x l, Exists l -> Exists (x::l). - Hint Constructors Exists. + Hint Constructors Exists : core. Lemma Exists_exists (l:list A) : Exists l <-> (exists x, In x l /\ P x). @@ -2214,7 +2214,7 @@ Section Exists_Forall. | Forall_nil : Forall nil | Forall_cons : forall x l, P x -> Forall l -> Forall (x::l). - Hint Constructors Forall. + Hint Constructors Forall : core. Lemma Forall_forall (l:list A): Forall l <-> (forall x, In x l -> P x). @@ -2299,8 +2299,8 @@ Section Exists_Forall. End Exists_Forall. -Hint Constructors Exists. -Hint Constructors Forall. +Hint Constructors Exists : core. +Hint Constructors Forall : core. Section Forall2. @@ -2314,7 +2314,7 @@ Section Forall2. | Forall2_cons : forall x y l l', R x y -> Forall2 l l' -> Forall2 (x::l) (y::l'). - Hint Constructors Forall2. + Hint Constructors Forall2 : core. Theorem Forall2_refl : Forall2 [] []. Proof. intros; apply Forall2_nil. Qed. @@ -2348,7 +2348,7 @@ Section Forall2. Qed. End Forall2. -Hint Constructors Forall2. +Hint Constructors Forall2 : core. Section ForallPairs. @@ -2369,7 +2369,7 @@ Section ForallPairs. | FOP_cons : forall a l, Forall (R a) l -> ForallOrdPairs l -> ForallOrdPairs (a::l). - Hint Constructors ForallOrdPairs. + Hint Constructors ForallOrdPairs : core. Lemma ForallOrdPairs_In : forall l, ForallOrdPairs l -> diff --git a/theories/Lists/ListSet.v b/theories/Lists/ListSet.v index cc7d6f5536..3afdd8df27 100644 --- a/theories/Lists/ListSet.v +++ b/theories/Lists/ListSet.v @@ -193,7 +193,7 @@ Section first_definitions. | auto with datatypes ]. Qed. - Hint Resolve set_add_intro1 set_add_intro2. + Hint Resolve set_add_intro1 set_add_intro2 : core. Lemma set_add_intro : forall (a b:A) (x:set), a = b \/ set_In a x -> set_In a (set_add b x). @@ -224,7 +224,7 @@ Section first_definitions. case H1; trivial. Qed. - Hint Resolve set_add_intro set_add_elim set_add_elim2. + Hint Resolve set_add_intro set_add_elim set_add_elim2 : core. Lemma set_add_not_empty : forall (a:A) (x:set), set_add a x <> empty_set. Proof. @@ -310,7 +310,7 @@ Section first_definitions. intros; elim H0; auto with datatypes. Qed. - Hint Resolve set_union_intro2 set_union_intro1. + Hint Resolve set_union_intro2 set_union_intro1 : core. Lemma set_union_intro : forall (a:A) (x y:set), @@ -393,7 +393,7 @@ Section first_definitions. eauto with datatypes. Qed. - Hint Resolve set_inter_elim1 set_inter_elim2. + Hint Resolve set_inter_elim1 set_inter_elim2 : core. Lemma set_inter_elim : forall (a:A) (x y:set), @@ -471,7 +471,7 @@ Section first_definitions. apply (set_diff_elim1 _ _ _ H). Qed. -Hint Resolve set_diff_intro set_diff_trivial. +Hint Resolve set_diff_intro set_diff_trivial : core. End first_definitions. diff --git a/theories/Lists/SetoidList.v b/theories/Lists/SetoidList.v index 0c5fe55b27..cab4c23df1 100644 --- a/theories/Lists/SetoidList.v +++ b/theories/Lists/SetoidList.v @@ -30,7 +30,7 @@ Inductive InA (x : A) : list A -> Prop := | InA_cons_hd : forall y l, eqA x y -> InA x (y :: l) | InA_cons_tl : forall y l, InA x l -> InA x (y :: l). -Hint Constructors InA. +Hint Constructors InA : core. (** TODO: it would be nice to have a generic definition instead of the previous one. Having [InA = Exists eqA] raises too @@ -62,7 +62,7 @@ Inductive NoDupA : list A -> Prop := | NoDupA_nil : NoDupA nil | NoDupA_cons : forall x l, ~ InA x l -> NoDupA l -> NoDupA (x::l). -Hint Constructors NoDupA. +Hint Constructors NoDupA : core. (** An alternative definition of [NoDupA] based on [ForallOrdPairs] *) @@ -93,7 +93,7 @@ Inductive eqlistA : list A -> list A -> Prop := | eqlistA_cons : forall x x' l l', eqA x x' -> eqlistA l l' -> eqlistA (x::l) (x'::l'). -Hint Constructors eqlistA. +Hint Constructors eqlistA : core. (** We could also have written [eqlistA = Forall2 eqA]. *) @@ -107,8 +107,8 @@ Definition eqarefl := (@Equivalence_Reflexive _ _ eqA_equiv). Definition eqatrans := (@Equivalence_Transitive _ _ eqA_equiv). Definition eqasym := (@Equivalence_Symmetric _ _ eqA_equiv). -Hint Resolve eqarefl eqatrans. -Hint Immediate eqasym. +Hint Resolve eqarefl eqatrans : core. +Hint Immediate eqasym : core. Ltac inv := invlist InA; invlist sort; invlist lelistA; invlist NoDupA. @@ -154,14 +154,14 @@ Lemma InA_eqA : forall l x y, eqA x y -> InA x l -> InA y l. Proof. intros l x y H H'. rewrite <- H. auto. Qed. -Hint Immediate InA_eqA. +Hint Immediate InA_eqA : core. Lemma In_InA : forall l x, In x l -> InA x l. Proof. simple induction l; simpl; intuition. subst; auto. Qed. -Hint Resolve In_InA. +Hint Resolve In_InA : core. Lemma InA_split : forall l x, InA x l -> exists l1 y l2, eqA x y /\ l = l1++y::l2. @@ -786,12 +786,12 @@ Hypothesis ltA_compat : Proper (eqA==>eqA==>iff) ltA. Let sotrans := (@StrictOrder_Transitive _ _ ltA_strorder). -Hint Resolve sotrans. +Hint Resolve sotrans : core. Notation InfA:=(lelistA ltA). Notation SortA:=(sort ltA). -Hint Constructors lelistA sort. +Hint Constructors lelistA sort : core. Lemma InfA_ltA : forall l x y, ltA x y -> InfA y l -> InfA x l. @@ -814,7 +814,7 @@ Lemma InfA_eqA l x y : eqA x y -> InfA y l -> InfA x l. Proof using eqA_equiv ltA_compat. intros H; now rewrite H. Qed. -Hint Immediate InfA_ltA InfA_eqA. +Hint Immediate InfA_ltA InfA_eqA : core. Lemma SortA_InfA_InA : forall l x a, SortA l -> InfA a l -> InA x l -> ltA a x. @@ -1005,7 +1005,7 @@ Qed. End Filter. End Type_with_equality. -Hint Constructors InA eqlistA NoDupA sort lelistA. +Hint Constructors InA eqlistA NoDupA sort lelistA : core. Arguments equivlistA_cons_nil {A} eqA {eqA_equiv} x l _. Arguments equivlistA_nil_eq {A} eqA {eqA_equiv} l _. diff --git a/theories/Lists/SetoidPermutation.v b/theories/Lists/SetoidPermutation.v index 24b96514fd..f5ea303343 100644 --- a/theories/Lists/SetoidPermutation.v +++ b/theories/Lists/SetoidPermutation.v @@ -28,7 +28,7 @@ Inductive PermutationA : list A -> list A -> Prop := | permA_swap x y l : PermutationA (y :: x :: l) (x :: y :: l) | permA_trans l₁ l₂ l₃ : PermutationA l₁ l₂ -> PermutationA l₂ l₃ -> PermutationA l₁ l₃. -Local Hint Constructors PermutationA. +Local Hint Constructors PermutationA : core. Global Instance: Equivalence PermutationA. Proof. diff --git a/theories/Logic/JMeq.v b/theories/Logic/JMeq.v index 25b7811417..3914f44a2c 100644 --- a/theories/Logic/JMeq.v +++ b/theories/Logic/JMeq.v @@ -31,7 +31,7 @@ Arguments JMeq_refl {A x} , [A] x. Register JMeq as core.JMeq.type. Register JMeq_refl as core.JMeq.refl. -Hint Resolve JMeq_refl. +Hint Resolve JMeq_refl : core. Definition JMeq_hom {A : Type} (x y : A) := JMeq x y. @@ -42,7 +42,7 @@ Proof. intros; destruct H; trivial. Qed. -Hint Immediate JMeq_sym. +Hint Immediate JMeq_sym : core. Register JMeq_sym as core.JMeq.sym. diff --git a/theories/MSets/MSetAVL.v b/theories/MSets/MSetAVL.v index aec88f93bf..ac2a143472 100644 --- a/theories/MSets/MSetAVL.v +++ b/theories/MSets/MSetAVL.v @@ -305,13 +305,13 @@ Include MSetGenTree.Props X I. (** Automation and dedicated tactics *) -Local Hint Immediate MX.eq_sym. -Local Hint Unfold In lt_tree gt_tree Ok. -Local Hint Constructors InT bst. -Local Hint Resolve MX.eq_refl MX.eq_trans MX.lt_trans ok. -Local Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node. -Local Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans. -Local Hint Resolve elements_spec2. +Local Hint Immediate MX.eq_sym : core. +Local Hint Unfold In lt_tree gt_tree Ok : core. +Local Hint Constructors InT bst : core. +Local Hint Resolve MX.eq_refl MX.eq_trans MX.lt_trans ok : core. +Local Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node : core. +Local Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans : core. +Local Hint Resolve elements_spec2 : core. (* Sometimes functional induction will expose too much of a tree structure. The following tactic allows factoring back @@ -496,7 +496,7 @@ Proof. specialize (L m); rewrite remove_min_spec, e0 in L; simpl in L; [setoid_replace y with x|inv]; eauto. Qed. -Local Hint Resolve remove_min_gt_tree. +Local Hint Resolve remove_min_gt_tree : core. (** ** Merging two trees *) diff --git a/theories/MSets/MSetGenTree.v b/theories/MSets/MSetGenTree.v index 95868861fa..888f9850c1 100644 --- a/theories/MSets/MSetGenTree.v +++ b/theories/MSets/MSetGenTree.v @@ -46,7 +46,7 @@ End InfoTyp. Module Type Ops (X:OrderedType)(Info:InfoTyp). Definition elt := X.t. -Hint Transparent elt. +Hint Transparent elt : core. Inductive tree : Type := | Leaf : tree @@ -342,11 +342,11 @@ Module Import MX := OrderedTypeFacts X. Scheme tree_ind := Induction for tree Sort Prop. Scheme bst_ind := Induction for bst Sort Prop. -Local Hint Resolve MX.eq_refl MX.eq_trans MX.lt_trans ok. -Local Hint Immediate MX.eq_sym. -Local Hint Unfold In lt_tree gt_tree. -Local Hint Constructors InT bst. -Local Hint Unfold Ok. +Local Hint Resolve MX.eq_refl MX.eq_trans MX.lt_trans ok : core. +Local Hint Immediate MX.eq_sym : core. +Local Hint Unfold In lt_tree gt_tree : core. +Local Hint Constructors InT bst : core. +Local Hint Unfold Ok : core. (** Automatic treatment of [Ok] hypothesis *) @@ -432,7 +432,7 @@ Lemma In_1 : Proof. induction s; simpl; intuition_in; eauto. Qed. -Local Hint Immediate In_1. +Local Hint Immediate In_1 : core. Instance In_compat : Proper (X.eq==>eq==>iff) InT. Proof. @@ -478,7 +478,7 @@ Proof. unfold gt_tree; intuition_in; order. Qed. -Local Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node. +Local Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node : core. Lemma lt_tree_not_in : forall (x : elt) (t : tree), lt_tree x t -> ~ InT x t. @@ -516,7 +516,7 @@ Proof. intros x x' Hx s s' Hs H y Hy. subst. setoid_rewrite <- Hx; auto. Qed. -Local Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans. +Local Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans : core. Ltac induct s x := induction s as [|i l IHl x' r IHr]; simpl; intros; @@ -699,7 +699,7 @@ Proof. intros; unfold elements; apply elements_spec2'; auto. intros; inversion H0. Qed. -Local Hint Resolve elements_spec2. +Local Hint Resolve elements_spec2 : core. Lemma elements_spec2w : forall s `(Ok s), NoDupA X.eq (elements s). Proof. @@ -1035,7 +1035,7 @@ Qed. Definition Cmp c x y := CompSpec L.eq L.lt x y c. -Local Hint Unfold Cmp flip. +Local Hint Unfold Cmp flip : core. Lemma compare_end_Cmp : forall e2, Cmp (compare_end e2) nil (flatten_e e2). diff --git a/theories/MSets/MSetInterface.v b/theories/MSets/MSetInterface.v index f0e757157d..a4bbaef52d 100644 --- a/theories/MSets/MSetInterface.v +++ b/theories/MSets/MSetInterface.v @@ -884,10 +884,10 @@ Module MakeListOrdering (O:OrderedType). O.lt x y -> lt_list (x :: s) (y :: s') | lt_cons_eq : forall x y s s', O.eq x y -> lt_list s s' -> lt_list (x :: s) (y :: s'). - Hint Constructors lt_list. + Hint Constructors lt_list : core. Definition lt := lt_list. - Hint Unfold lt. + Hint Unfold lt : core. Instance lt_strorder : StrictOrder lt. Proof. @@ -933,13 +933,13 @@ Module MakeListOrdering (O:OrderedType). left; MO.order. right; rewrite <- E12; auto. left; MO.order. right; rewrite E12; auto. Qed. - Hint Resolve eq_cons. + Hint Resolve eq_cons : core. Lemma cons_CompSpec : forall c x1 x2 l1 l2, O.eq x1 x2 -> CompSpec eq lt l1 l2 c -> CompSpec eq lt (x1::l1) (x2::l2) c. Proof. destruct c; simpl; inversion_clear 2; auto with relations. Qed. - Hint Resolve cons_CompSpec. + Hint Resolve cons_CompSpec : core. End MakeListOrdering. diff --git a/theories/MSets/MSetList.v b/theories/MSets/MSetList.v index 35fe4cee4e..7b64818b24 100644 --- a/theories/MSets/MSetList.v +++ b/theories/MSets/MSetList.v @@ -231,14 +231,14 @@ Module MakeRaw (X: OrderedType) <: RawSets X. Notation In := (InA X.eq). Existing Instance X.eq_equiv. - Hint Extern 20 => solve [order]. + Hint Extern 20 => solve [order] : core. Definition IsOk s := Sort s. Class Ok (s:t) : Prop := ok : Sort s. - Hint Resolve ok. - Hint Unfold Ok. + Hint Resolve ok : core. + Hint Unfold Ok : core. Instance Sort_Ok s `(Hs : Sort s) : Ok s := { ok := Hs }. @@ -276,7 +276,7 @@ Module MakeRaw (X: OrderedType) <: RawSets X. destruct H; constructor; tauto. Qed. - Hint Extern 1 (Ok _) => rewrite <- isok_iff. + Hint Extern 1 (Ok _) => rewrite <- isok_iff : core. Ltac inv_ok := match goal with | H:sort X.lt (_ :: _) |- _ => inversion_clear H; inv_ok @@ -326,7 +326,7 @@ Module MakeRaw (X: OrderedType) <: RawSets X. intuition. intros; elim_compare x a; inv; intuition. Qed. - Hint Resolve add_inf. + Hint Resolve add_inf : core. Global Instance add_ok s x : forall `(Ok s), Ok (add x s). Proof. @@ -353,7 +353,7 @@ Module MakeRaw (X: OrderedType) <: RawSets X. intros; elim_compare x a; inv; auto. apply Inf_lt with a; auto. Qed. - Hint Resolve remove_inf. + Hint Resolve remove_inf : core. Global Instance remove_ok s x : forall `(Ok s), Ok (remove x s). Proof. @@ -396,7 +396,7 @@ Module MakeRaw (X: OrderedType) <: RawSets X. Proof. induction2. Qed. - Hint Resolve union_inf. + Hint Resolve union_inf : core. Global Instance union_ok s s' : forall `(Ok s, Ok s'), Ok (union s s'). Proof. @@ -422,7 +422,7 @@ Module MakeRaw (X: OrderedType) <: RawSets X. apply Hrec'; auto. apply Inf_lt with x'; auto. Qed. - Hint Resolve inter_inf. + Hint Resolve inter_inf : core. Global Instance inter_ok s s' : forall `(Ok s, Ok s'), Ok (inter s s'). Proof. @@ -452,7 +452,7 @@ Module MakeRaw (X: OrderedType) <: RawSets X. apply Hrec'; auto. apply Inf_lt with x'; auto. Qed. - Hint Resolve diff_inf. + Hint Resolve diff_inf : core. Global Instance diff_ok s s' : forall `(Ok s, Ok s'), Ok (diff s s'). Proof. diff --git a/theories/MSets/MSetProperties.v b/theories/MSets/MSetProperties.v index 3c7dea736b..29e57ff0a2 100644 --- a/theories/MSets/MSetProperties.v +++ b/theories/MSets/MSetProperties.v @@ -21,7 +21,7 @@ Require Import DecidableTypeEx OrdersLists MSetFacts MSetDecide. Set Implicit Arguments. Unset Strict Implicit. -Hint Unfold transpose. +Hint Unfold transpose : core. (** First, a functor for Weak Sets in functorial version. *) @@ -735,7 +735,7 @@ Module WPropertiesOn (Import E : DecidableType)(M : WSetsOn E). Proof. intros; rewrite cardinal_Empty; auto. Qed. - Hint Resolve cardinal_inv_1. + Hint Resolve cardinal_inv_1 : core. Lemma cardinal_inv_2 : forall s n, cardinal s = S n -> { x : elt | In x s }. @@ -774,7 +774,7 @@ Module WPropertiesOn (Import E : DecidableType)(M : WSetsOn E). exact Equal_cardinal. Qed. - Hint Resolve Add_add Add_remove Equal_remove cardinal_inv_1 Equal_cardinal. + Hint Resolve Add_add Add_remove Equal_remove cardinal_inv_1 Equal_cardinal : core. (** ** Cardinal and set operators *) @@ -898,7 +898,7 @@ Module WPropertiesOn (Import E : DecidableType)(M : WSetsOn E). auto with set. Qed. - Hint Resolve subset_cardinal union_cardinal add_cardinal_1 add_cardinal_2. + Hint Resolve subset_cardinal union_cardinal add_cardinal_1 add_cardinal_2 : core. End WPropertiesOn. @@ -922,7 +922,7 @@ Module OrdProperties (M:Sets). Import M.E. Import M. - Hint Resolve elements_spec2. + Hint Resolve elements_spec2 : core. Hint Immediate min_elt_spec1 min_elt_spec2 min_elt_spec3 max_elt_spec1 max_elt_spec2 max_elt_spec3 : set. @@ -961,7 +961,7 @@ Module OrdProperties (M:Sets). Proof. intros a b H; unfold leb. rewrite H; auto. Qed. - Hint Resolve gtb_compat leb_compat. + Hint Resolve gtb_compat leb_compat : core. Lemma elements_split : forall x s, elements s = elements_lt x s ++ elements_ge x s. diff --git a/theories/MSets/MSetRBT.v b/theories/MSets/MSetRBT.v index eab01a55b0..f9105fdf74 100644 --- a/theories/MSets/MSetRBT.v +++ b/theories/MSets/MSetRBT.v @@ -450,13 +450,13 @@ Include MSetGenTree.Props X Color. Local Notation Rd := (Node Red). Local Notation Bk := (Node Black). -Local Hint Immediate MX.eq_sym. -Local Hint Unfold In lt_tree gt_tree Ok. -Local Hint Constructors InT bst. -Local Hint Resolve MX.eq_refl MX.eq_trans MX.lt_trans ok. -Local Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node. -Local Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans. -Local Hint Resolve elements_spec2. +Local Hint Immediate MX.eq_sym : core. +Local Hint Unfold In lt_tree gt_tree Ok : core. +Local Hint Constructors InT bst : core. +Local Hint Resolve MX.eq_refl MX.eq_trans MX.lt_trans ok : core. +Local Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node : core. +Local Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans : core. +Local Hint Resolve elements_spec2 : core. (** ** Singleton set *) @@ -1136,7 +1136,7 @@ Record INV l1 l2 acc : Prop := { acc_sorted : sort X.lt acc; l1_lt_acc x y : InA X.eq x l1 -> InA X.eq y acc -> X.lt x y; l2_lt_acc x y : InA X.eq x l2 -> InA X.eq y acc -> X.lt x y}. -Local Hint Resolve l1_sorted l2_sorted acc_sorted. +Local Hint Resolve l1_sorted l2_sorted acc_sorted : core. Lemma INV_init s1 s2 `(Ok s1, Ok s2) : INV (rev_elements s1) (rev_elements s2) nil. @@ -1506,8 +1506,8 @@ Class Rbt (t:tree) := RBT : exists d, rbt d t. (** ** Basic tactics and results about red-black *) Scheme rbt_ind := Induction for rbt Sort Prop. -Local Hint Constructors rbt rrt arbt. -Local Hint Extern 0 (notred _) => (exact I). +Local Hint Constructors rbt rrt arbt : core. +Local Hint Extern 0 (notred _) => (exact I) : core. Ltac invrb := intros; invtree rrt; invtree rbt; try contradiction. Ltac desarb := match goal with H:arbt _ _ |- _ => destruct H end. Ltac nonzero n := destruct n as [|n]; [try split; invrb|]. @@ -1519,7 +1519,7 @@ Proof. destruct l, r; descolor; invrb; auto. Qed. -Local Hint Resolve rr_nrr_rb. +Local Hint Resolve rr_nrr_rb : core. Lemma arb_nrr_rb n t : arbt n t -> notredred t -> rbt n t. @@ -1533,7 +1533,7 @@ Proof. destruct 1; destruct t; descolor; invrb; auto. Qed. -Local Hint Resolve arb_nrr_rb arb_nr_rb. +Local Hint Resolve arb_nrr_rb arb_nr_rb : core. (** ** A Red-Black tree has indeed a logarithmic depth *) diff --git a/theories/MSets/MSetWeakList.v b/theories/MSets/MSetWeakList.v index 8df1ff1cdb..19058a767e 100644 --- a/theories/MSets/MSetWeakList.v +++ b/theories/MSets/MSetWeakList.v @@ -123,15 +123,15 @@ Module MakeRaw (X:DecidableType) <: WRawSets X. Let eqr:= (@Equivalence_Reflexive _ _ X.eq_equiv). Let eqsym:= (@Equivalence_Symmetric _ _ X.eq_equiv). Let eqtrans:= (@Equivalence_Transitive _ _ X.eq_equiv). - Hint Resolve eqr eqtrans. - Hint Immediate eqsym. + Hint Resolve eqr eqtrans : core. + Hint Immediate eqsym : core. Definition IsOk := NoDup. Class Ok (s:t) : Prop := ok : NoDup s. - Hint Unfold Ok. - Hint Resolve ok. + Hint Unfold Ok : core. + Hint Resolve ok : core. Instance NoDup_Ok s (nd : NoDup s) : Ok s := { ok := nd }. diff --git a/theories/Numbers/Cyclic/ZModulo/ZModulo.v b/theories/Numbers/Cyclic/ZModulo/ZModulo.v index 784e81758c..4bcd22543f 100644 --- a/theories/Numbers/Cyclic/ZModulo/ZModulo.v +++ b/theories/Numbers/Cyclic/ZModulo/ZModulo.v @@ -60,7 +60,7 @@ Section ZModulo. apply Z.lt_gt. unfold wB, base; auto with zarith. Qed. - Hint Resolve wB_pos. + Hint Resolve wB_pos : core. Lemma spec_to_Z_1 : forall x, 0 <= [|x|]. Proof. @@ -71,7 +71,7 @@ Section ZModulo. Proof. unfold to_Z; intros; destruct (Z_mod_lt x wB wB_pos); auto. Qed. - Hint Resolve spec_to_Z_1 spec_to_Z_2. + Hint Resolve spec_to_Z_1 spec_to_Z_2 : core. Lemma spec_to_Z : forall x, 0 <= [|x|] < wB. Proof. @@ -732,7 +732,7 @@ Section ZModulo. Proof. induction p; simpl; auto with zarith. Qed. - Hint Resolve Ptail_pos. + Hint Resolve Ptail_pos : core. Lemma Ptail_bounded : forall p d, Zpos p < 2^(Zpos d) -> Ptail p < Zpos d. Proof. diff --git a/theories/Numbers/Natural/Abstract/NDefOps.v b/theories/Numbers/Natural/Abstract/NDefOps.v index 8e1be0d702..4539dea276 100644 --- a/theories/Numbers/Natural/Abstract/NDefOps.v +++ b/theories/Numbers/Natural/Abstract/NDefOps.v @@ -383,7 +383,7 @@ f_equiv. apply E, half_decrease. rewrite two_succ, <- not_true_iff_false, ltb_lt, nlt_ge, le_succ_l in H. order'. Qed. -Hint Resolve log_good_step. +Hint Resolve log_good_step : core. Theorem log_init : forall n, n < 2 -> log n == 0. Proof. diff --git a/theories/Program/Basics.v b/theories/Program/Basics.v index c2316689fc..d86112abc0 100644 --- a/theories/Program/Basics.v +++ b/theories/Program/Basics.v @@ -26,7 +26,7 @@ Arguments id {A} x. Definition compose {A B C} (g : B -> C) (f : A -> B) := fun x : A => g (f x). -Hint Unfold compose. +Hint Unfold compose : core. Declare Scope program_scope. diff --git a/theories/Program/Wf.v b/theories/Program/Wf.v index 8479b9a2bb..f9d23e3cf6 100644 --- a/theories/Program/Wf.v +++ b/theories/Program/Wf.v @@ -110,7 +110,7 @@ Section Measure_well_founded. End Measure_well_founded. -Hint Resolve measure_wf. +Hint Resolve measure_wf : core. Section Fix_rects. diff --git a/theories/QArith/Qcanon.v b/theories/QArith/Qcanon.v index 81c318138e..f18fca99a0 100644 --- a/theories/QArith/Qcanon.v +++ b/theories/QArith/Qcanon.v @@ -66,7 +66,7 @@ Proof. rewrite hq, hq' in H'. subst q'. f_equal. apply eq_proofs_unicity. intros. repeat decide equality. Qed. -Hint Resolve Qc_is_canon. +Hint Resolve Qc_is_canon : core. Theorem Qc_decomp: forall q q': Qc, (q:Q) = q' -> q = q'. Proof. diff --git a/theories/QArith/Qreals.v b/theories/QArith/Qreals.v index c832962590..b4c869b4dd 100644 --- a/theories/QArith/Qreals.v +++ b/theories/QArith/Qreals.v @@ -21,7 +21,7 @@ intros. now apply not_O_IZR. Qed. -Hint Resolve IZR_nz Rmult_integral_contrapositive. +Hint Resolve IZR_nz Rmult_integral_contrapositive : core. Lemma eqR_Qeq : forall x y : Q, Q2R x = Q2R y -> x==y. Proof. diff --git a/theories/Reals/RIneq.v b/theories/Reals/RIneq.v index 59a1049654..ec283b886e 100644 --- a/theories/Reals/RIneq.v +++ b/theories/Reals/RIneq.v @@ -1087,7 +1087,7 @@ Proof. replace (r2 + r1 + - r2) with r1 by ring. exact H. Qed. -Hint Resolve Ropp_gt_lt_contravar. +Hint Resolve Ropp_gt_lt_contravar : core. Lemma Ropp_lt_gt_contravar : forall r1 r2, r1 < r2 -> - r1 > - r2. Proof. @@ -1204,7 +1204,7 @@ Lemma Rmult_lt_compat_r : forall r r1 r2, 0 < r -> r1 < r2 -> r1 * r < r2 * r. Proof. intros; rewrite (Rmult_comm r1 r); rewrite (Rmult_comm r2 r); auto with real. Qed. -Hint Resolve Rmult_lt_compat_r. +Hint Resolve Rmult_lt_compat_r : core. Lemma Rmult_gt_compat_r : forall r r1 r2, r > 0 -> r1 > r2 -> r1 * r > r2 * r. Proof. eauto using Rmult_lt_compat_r with rorders. Qed. diff --git a/theories/Sets/Cpo.v b/theories/Sets/Cpo.v index 3977097e8c..61fe55770b 100644 --- a/theories/Sets/Cpo.v +++ b/theories/Sets/Cpo.v @@ -95,7 +95,7 @@ End Bounds. Hint Resolve Totally_ordered_definition Upper_Bound_definition Lower_Bound_definition Lub_definition Glb_definition Bottom_definition Definition_of_Complete Definition_of_Complete - Definition_of_Conditionally_complete. + Definition_of_Conditionally_complete : core. Section Specific_orders. Variable U : Type. diff --git a/theories/Sets/Infinite_sets.v b/theories/Sets/Infinite_sets.v index bdeeb6a7c7..a0271a88a3 100644 --- a/theories/Sets/Infinite_sets.v +++ b/theories/Sets/Infinite_sets.v @@ -46,7 +46,7 @@ Section Approx. Defn_of_Approximant : Finite U X -> Included U X A -> Approximant A X. End Approx. -Hint Resolve Defn_of_Approximant. +Hint Resolve Defn_of_Approximant : core. Section Infinite_sets. Variable U : Type. diff --git a/theories/Sets/Powerset.v b/theories/Sets/Powerset.v index 88bcd6555c..50a7e401f8 100644 --- a/theories/Sets/Powerset.v +++ b/theories/Sets/Powerset.v @@ -38,43 +38,43 @@ Variable U : Type. Inductive Power_set (A:Ensemble U) : Ensemble (Ensemble U) := Definition_of_Power_set : forall X:Ensemble U, Included U X A -> In (Ensemble U) (Power_set A) X. -Hint Resolve Definition_of_Power_set. +Hint Resolve Definition_of_Power_set : core. Theorem Empty_set_minimal : forall X:Ensemble U, Included U (Empty_set U) X. intro X; red. intros x H'; elim H'. Qed. -Hint Resolve Empty_set_minimal. +Hint Resolve Empty_set_minimal : core. Theorem Power_set_Inhabited : forall X:Ensemble U, Inhabited (Ensemble U) (Power_set X). intro X. apply Inhabited_intro with (Empty_set U); auto with sets. Qed. -Hint Resolve Power_set_Inhabited. +Hint Resolve Power_set_Inhabited : core. Theorem Inclusion_is_an_order : Order (Ensemble U) (Included U). auto 6 with sets. Qed. -Hint Resolve Inclusion_is_an_order. +Hint Resolve Inclusion_is_an_order : core. Theorem Inclusion_is_transitive : Transitive (Ensemble U) (Included U). elim Inclusion_is_an_order; auto with sets. Qed. -Hint Resolve Inclusion_is_transitive. +Hint Resolve Inclusion_is_transitive : core. Definition Power_set_PO : Ensemble U -> PO (Ensemble U). intro A; try assumption. apply Definition_of_PO with (Power_set A) (Included U); auto with sets. Defined. -Hint Unfold Power_set_PO. +Hint Unfold Power_set_PO : core. Theorem Strict_Rel_is_Strict_Included : same_relation (Ensemble U) (Strict_Included U) (Strict_Rel_of (Ensemble U) (Power_set_PO (Full_set U))). auto with sets. Qed. -Hint Resolve Strict_Rel_Transitive Strict_Rel_is_Strict_Included. +Hint Resolve Strict_Rel_Transitive Strict_Rel_is_Strict_Included : core. Lemma Strict_inclusion_is_transitive_with_inclusion : forall x y z:Ensemble U, @@ -109,7 +109,7 @@ Theorem Empty_set_is_Bottom : forall A:Ensemble U, Bottom (Ensemble U) (Power_set_PO A) (Empty_set U). intro A; apply Bottom_definition; simpl; auto with sets. Qed. -Hint Resolve Empty_set_is_Bottom. +Hint Resolve Empty_set_is_Bottom : core. Theorem Union_minimal : forall a b X:Ensemble U, @@ -117,7 +117,7 @@ Theorem Union_minimal : intros a b X H' H'0; red. intros x H'1; elim H'1; auto with sets. Qed. -Hint Resolve Union_minimal. +Hint Resolve Union_minimal : core. Theorem Intersection_maximal : forall a b X:Ensemble U, @@ -145,7 +145,7 @@ intros a b; red. intros x H'; elim H'; auto with sets. Qed. Hint Resolve Union_increases_l Union_increases_r Intersection_decreases_l - Intersection_decreases_r. + Intersection_decreases_r : core. Theorem Union_is_Lub : forall A a b:Ensemble U, diff --git a/theories/Sets/Relations_1_facts.v b/theories/Sets/Relations_1_facts.v index 296ec42add..d275487e15 100644 --- a/theories/Sets/Relations_1_facts.v +++ b/theories/Sets/Relations_1_facts.v @@ -52,7 +52,7 @@ intros x y z h; elim h; intros H'3 H'4; clear h. intro h; elim h; intros H'5 H'6; clear h. split; apply H'1 with y; auto 10 with sets. Qed. -Hint Resolve Equiv_from_preorder. +Hint Resolve Equiv_from_preorder : core. Theorem Equiv_from_order : forall (U:Type) (R:Relation U), @@ -60,21 +60,21 @@ Theorem Equiv_from_order : Proof. intros U R H'; elim H'; auto 10 with sets. Qed. -Hint Resolve Equiv_from_order. +Hint Resolve Equiv_from_order : core. Theorem contains_is_preorder : forall U:Type, Preorder (Relation U) (contains U). Proof. auto 10 with sets. Qed. -Hint Resolve contains_is_preorder. +Hint Resolve contains_is_preorder : core. Theorem same_relation_is_equivalence : forall U:Type, Equivalence (Relation U) (same_relation U). Proof. unfold same_relation at 1; auto 10 with sets. Qed. -Hint Resolve same_relation_is_equivalence. +Hint Resolve same_relation_is_equivalence : core. Theorem cong_reflexive_same_relation : forall (U:Type) (R R':Relation U), diff --git a/theories/Sets/Relations_3_facts.v b/theories/Sets/Relations_3_facts.v index 0c1f670d0e..18ea019526 100644 --- a/theories/Sets/Relations_3_facts.v +++ b/theories/Sets/Relations_3_facts.v @@ -38,7 +38,7 @@ Proof. intros U R x y H'; red. exists y; auto with sets. Qed. -Hint Resolve Rstar_imp_coherent. +Hint Resolve Rstar_imp_coherent : core. Theorem coherent_symmetric : forall (U:Type) (R:Relation U), Symmetric U (coherent U R). diff --git a/theories/Sets/Uniset.v b/theories/Sets/Uniset.v index 7940bda1a7..0ff304ed6b 100644 --- a/theories/Sets/Uniset.v +++ b/theories/Sets/Uniset.v @@ -41,21 +41,21 @@ Definition Singleton (a:A) := end). Definition In (s:uniset) (a:A) : Prop := charac s a = true. -Hint Unfold In. +Hint Unfold In : core. (** uniset inclusion *) Definition incl (s1 s2:uniset) := forall a:A, leb (charac s1 a) (charac s2 a). -Hint Unfold incl. +Hint Unfold incl : core. (** uniset equality *) Definition seq (s1 s2:uniset) := forall a:A, charac s1 a = charac s2 a. -Hint Unfold seq. +Hint Unfold seq : core. Lemma leb_refl : forall b:bool, leb b b. Proof. destruct b; simpl; auto. Qed. -Hint Resolve leb_refl. +Hint Resolve leb_refl : core. Lemma incl_left : forall s1 s2:uniset, seq s1 s2 -> incl s1 s2. Proof. @@ -71,7 +71,7 @@ Lemma seq_refl : forall x:uniset, seq x x. Proof. destruct x; unfold seq; auto. Qed. -Hint Resolve seq_refl. +Hint Resolve seq_refl : core. Lemma seq_trans : forall x y z:uniset, seq x y -> seq y z -> seq x z. Proof. @@ -94,21 +94,21 @@ Lemma union_empty_left : forall x:uniset, seq x (union Emptyset x). Proof. unfold seq; unfold union; simpl; auto. Qed. -Hint Resolve union_empty_left. +Hint Resolve union_empty_left : core. Lemma union_empty_right : forall x:uniset, seq x (union x Emptyset). Proof. unfold seq; unfold union; simpl. intros x a; rewrite (orb_b_false (charac x a)); auto. Qed. -Hint Resolve union_empty_right. +Hint Resolve union_empty_right : core. Lemma union_comm : forall x y:uniset, seq (union x y) (union y x). Proof. unfold seq; unfold charac; unfold union. destruct x; destruct y; auto with bool. Qed. -Hint Resolve union_comm. +Hint Resolve union_comm : core. Lemma union_ass : forall x y z:uniset, seq (union (union x y) z) (union x (union y z)). @@ -116,7 +116,7 @@ Proof. unfold seq; unfold union; unfold charac. destruct x; destruct y; destruct z; auto with bool. Qed. -Hint Resolve union_ass. +Hint Resolve union_ass : core. Lemma seq_left : forall x y z:uniset, seq x y -> seq (union x z) (union y z). Proof. @@ -124,7 +124,7 @@ unfold seq; unfold union; unfold charac. destruct x; destruct y; destruct z. intros; elim H; auto. Qed. -Hint Resolve seq_left. +Hint Resolve seq_left : core. Lemma seq_right : forall x y z:uniset, seq x y -> seq (union z x) (union z y). Proof. @@ -132,7 +132,7 @@ unfold seq; unfold union; unfold charac. destruct x; destruct y; destruct z. intros; elim H; auto. Qed. -Hint Resolve seq_right. +Hint Resolve seq_right : core. (** All the proofs that follow duplicate [Multiset_of_A] *) diff --git a/theories/Sorting/Heap.v b/theories/Sorting/Heap.v index 2ef162be4e..6a22501afa 100644 --- a/theories/Sorting/Heap.v +++ b/theories/Sorting/Heap.v @@ -36,8 +36,8 @@ Section defs. Hypothesis leA_trans : forall x y z:A, leA x y -> leA y z -> leA x z. Hypothesis leA_antisym : forall x y:A, leA x y -> leA y x -> eqA x y. - Hint Resolve leA_refl. - Hint Immediate eqA_dec leA_dec leA_antisym. + Hint Resolve leA_refl : core. + Hint Immediate eqA_dec leA_dec leA_antisym : core. Let emptyBag := EmptyBag A. Let singletonBag := SingletonBag _ eqA_dec. diff --git a/theories/Sorting/Permutation.v b/theories/Sorting/Permutation.v index 7b99b3626f..f5bc9eee4e 100644 --- a/theories/Sorting/Permutation.v +++ b/theories/Sorting/Permutation.v @@ -31,7 +31,7 @@ Inductive Permutation : list A -> list A -> Prop := | perm_trans l l' l'' : Permutation l l' -> Permutation l' l'' -> Permutation l l''. -Local Hint Constructors Permutation. +Local Hint Constructors Permutation : core. (** Some facts about [Permutation] *) @@ -71,13 +71,13 @@ Qed. End Permutation. -Hint Resolve Permutation_refl perm_nil perm_skip. +Hint Resolve Permutation_refl perm_nil perm_skip : core. (* These hints do not reduce the size of the problem to solve and they must be used with care to avoid combinatoric explosions *) -Local Hint Resolve perm_swap perm_trans. -Local Hint Resolve Permutation_sym Permutation_trans. +Local Hint Resolve perm_swap perm_trans : core. +Local Hint Resolve Permutation_sym Permutation_trans : core. (* This provides reflexivity, symmetry and transitivity and rewriting on morphims to come *) @@ -156,7 +156,7 @@ Qed. Lemma Permutation_cons_append : forall (l : list A) x, Permutation (x :: l) (l ++ x :: nil). Proof. induction l; intros; auto. simpl. rewrite <- IHl; auto. Qed. -Local Hint Resolve Permutation_cons_append. +Local Hint Resolve Permutation_cons_append : core. Theorem Permutation_app_comm : forall (l l' : list A), Permutation (l ++ l') (l' ++ l). @@ -166,7 +166,7 @@ Proof. rewrite app_comm_cons, Permutation_cons_append. now rewrite <- app_assoc. Qed. -Local Hint Resolve Permutation_app_comm. +Local Hint Resolve Permutation_app_comm : core. Theorem Permutation_cons_app : forall (l l1 l2:list A) a, Permutation l (l1 ++ l2) -> Permutation (a :: l) (l1 ++ a :: l2). @@ -175,7 +175,7 @@ Proof. rewrite app_comm_cons, Permutation_cons_append. now rewrite <- app_assoc. Qed. -Local Hint Resolve Permutation_cons_app. +Local Hint Resolve Permutation_cons_app : core. Lemma Permutation_Add a l l' : Add a l l' -> Permutation (a::l) l'. Proof. @@ -188,7 +188,7 @@ Theorem Permutation_middle : forall (l1 l2:list A) a, Proof. auto. Qed. -Local Hint Resolve Permutation_middle. +Local Hint Resolve Permutation_middle : core. Theorem Permutation_rev : forall (l : list A), Permutation l (rev l). Proof. diff --git a/theories/Sorting/Sorted.v b/theories/Sorting/Sorted.v index 89e9c7f3e1..6782dd9ca3 100644 --- a/theories/Sorting/Sorted.v +++ b/theories/Sorting/Sorted.v @@ -137,8 +137,8 @@ Section defs. End defs. -Hint Constructors HdRel. -Hint Constructors Sorted. +Hint Constructors HdRel : core. +Hint Constructors Sorted : core. (* begin hide *) (* Compatibility with deprecated file Sorting.v *) diff --git a/theories/Structures/DecidableType.v b/theories/Structures/DecidableType.v index 24333ad815..f82ca5fa3c 100644 --- a/theories/Structures/DecidableType.v +++ b/theories/Structures/DecidableType.v @@ -38,8 +38,8 @@ Module KeyDecidableType(D:DecidableType). Definition eqke (p p':key*elt) := eq (fst p) (fst p') /\ (snd p) = (snd p'). - Hint Unfold eqk eqke. - Hint Extern 2 (eqke ?a ?b) => split. + Hint Unfold eqk eqke : core. + Hint Extern 2 (eqke ?a ?b) => split : core. (* eqke is stricter than eqk *) @@ -70,8 +70,8 @@ Module KeyDecidableType(D:DecidableType). unfold eqke; intuition; [ eauto | congruence ]. Qed. - Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl. - Hint Immediate eqk_sym eqke_sym. + Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl : core. + Hint Immediate eqk_sym eqke_sym : core. Global Instance eqk_equiv : Equivalence eqk. Proof. split; eauto. Qed. @@ -84,7 +84,7 @@ Module KeyDecidableType(D:DecidableType). Proof. unfold eqke; induction 1; intuition. Qed. - Hint Resolve InA_eqke_eqk. + Hint Resolve InA_eqke_eqk : core. Lemma InA_eqk : forall p q m, eqk p q -> InA eqk p m -> InA eqk q m. Proof. @@ -94,7 +94,7 @@ Module KeyDecidableType(D:DecidableType). Definition MapsTo (k:key)(e:elt):= InA eqke (k,e). Definition In k m := exists e:elt, MapsTo k e m. - Hint Unfold MapsTo In. + Hint Unfold MapsTo In : core. (* An alternative formulation for [In k l] is [exists e, InA eqk (k,e) l] *) @@ -140,13 +140,13 @@ Module KeyDecidableType(D:DecidableType). End Elt. - Hint Unfold eqk eqke. - Hint Extern 2 (eqke ?a ?b) => split. - Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl. - Hint Immediate eqk_sym eqke_sym. - Hint Resolve InA_eqke_eqk. - Hint Unfold MapsTo In. - Hint Resolve In_inv_2 In_inv_3. + Hint Unfold eqk eqke : core. + Hint Extern 2 (eqke ?a ?b) => split : core. + Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl : core. + Hint Immediate eqk_sym eqke_sym : core. + Hint Resolve InA_eqke_eqk : core. + Hint Unfold MapsTo In : core. + Hint Resolve In_inv_2 In_inv_3 : core. End KeyDecidableType. diff --git a/theories/Structures/Equalities.v b/theories/Structures/Equalities.v index 5f60a979c6..4143dba547 100644 --- a/theories/Structures/Equalities.v +++ b/theories/Structures/Equalities.v @@ -53,8 +53,8 @@ Module Type IsEqOrig (Import E:Eq'). Axiom eq_refl : forall x : t, x==x. Axiom eq_sym : forall x y : t, x==y -> y==x. Axiom eq_trans : forall x y z : t, x==y -> y==z -> x==z. - Hint Immediate eq_sym. - Hint Resolve eq_refl eq_trans. + Hint Immediate eq_sym : core. + Hint Resolve eq_refl eq_trans : core. End IsEqOrig. (** * Types with decidable equality *) diff --git a/theories/Structures/EqualitiesFacts.v b/theories/Structures/EqualitiesFacts.v index 7b6ee2eaca..c738b57f44 100644 --- a/theories/Structures/EqualitiesFacts.v +++ b/theories/Structures/EqualitiesFacts.v @@ -22,7 +22,7 @@ Module KeyDecidableType(D:DecidableType). Definition eqk {elt} : relation (key*elt) := D.eq @@1. Definition eqke {elt} : relation (key*elt) := D.eq * Logic.eq. - Hint Unfold eqk eqke. + Hint Unfold eqk eqke : core. (** eqk, eqke are equalities *) @@ -60,7 +60,7 @@ Module KeyDecidableType(D:DecidableType). Lemma eqk_1 {elt} k k' (e e':elt) : eqk (k,e) (k',e') -> D.eq k k'. Proof. trivial. Qed. - Hint Resolve eqke_1 eqke_2 eqk_1. + Hint Resolve eqke_1 eqke_2 eqk_1 : core. (* Additional facts *) @@ -69,7 +69,7 @@ Module KeyDecidableType(D:DecidableType). Proof. induction 1; firstorder. Qed. - Hint Resolve InA_eqke_eqk. + Hint Resolve InA_eqke_eqk : core. Lemma InA_eqk_eqke {elt} p (m:list (key*elt)) : InA eqk p m -> exists q, eqk p q /\ InA eqke q m. @@ -86,7 +86,7 @@ Module KeyDecidableType(D:DecidableType). Definition MapsTo {elt} (k:key)(e:elt):= InA eqke (k,e). Definition In {elt} k m := exists e:elt, MapsTo k e m. - Hint Unfold MapsTo In. + Hint Unfold MapsTo In : core. (* Alternative formulations for [In k l] *) @@ -167,9 +167,9 @@ Module KeyDecidableType(D:DecidableType). eauto with *. Qed. - Hint Extern 2 (eqke ?a ?b) => split. - Hint Resolve InA_eqke_eqk. - Hint Resolve In_inv_2 In_inv_3. + Hint Extern 2 (eqke ?a ?b) => split : core. + Hint Resolve InA_eqke_eqk : core. + Hint Resolve In_inv_2 In_inv_3 : core. End KeyDecidableType. diff --git a/theories/Structures/OrderedType.v b/theories/Structures/OrderedType.v index f6fc247d5a..d000b75bf4 100644 --- a/theories/Structures/OrderedType.v +++ b/theories/Structures/OrderedType.v @@ -42,8 +42,8 @@ Module Type MiniOrderedType. Parameter compare : forall x y : t, Compare lt eq x y. - Hint Immediate eq_sym. - Hint Resolve eq_refl eq_trans lt_not_eq lt_trans. + Hint Immediate eq_sym : core. + Hint Resolve eq_refl eq_trans lt_not_eq lt_trans : core. End MiniOrderedType. @@ -143,9 +143,9 @@ Module OrderedTypeFacts (Import O: OrderedType). Lemma eq_not_gt x y : eq x y -> ~ lt y x. Proof. order. Qed. Lemma lt_not_gt x y : lt x y -> ~ lt y x. Proof. order. Qed. - Hint Resolve gt_not_eq eq_not_lt. - Hint Immediate eq_lt lt_eq le_eq eq_le neq_eq eq_neq. - Hint Resolve eq_not_gt lt_antirefl lt_not_gt. + Hint Resolve gt_not_eq eq_not_lt : core. + Hint Immediate eq_lt lt_eq le_eq eq_le neq_eq eq_neq : core. + Hint Resolve eq_not_gt lt_antirefl lt_not_gt : core. Lemma elim_compare_eq : forall x y : t, @@ -247,8 +247,8 @@ Proof. exact (SortA_NoDupA eq_equiv lt_strorder lt_compat). Qed. End ForNotations. -Hint Resolve ListIn_In Sort_NoDup Inf_lt. -Hint Immediate In_eq Inf_lt. +Hint Resolve ListIn_In Sort_NoDup Inf_lt : core. +Hint Immediate In_eq Inf_lt : core. End OrderedTypeFacts. @@ -266,8 +266,8 @@ Module KeyOrderedType(O:OrderedType). eq (fst p) (fst p') /\ (snd p) = (snd p'). Definition ltk (p p':key*elt) := lt (fst p) (fst p'). - Hint Unfold eqk eqke ltk. - Hint Extern 2 (eqke ?a ?b) => split. + Hint Unfold eqk eqke ltk : core. + Hint Extern 2 (eqke ?a ?b) => split : core. (* eqke is stricter than eqk *) @@ -283,7 +283,7 @@ Module KeyOrderedType(O:OrderedType). Lemma ltk_right_l : forall x k e e', ltk (k,e) x -> ltk (k,e') x. Proof. auto. Qed. - Hint Immediate ltk_right_r ltk_right_l. + Hint Immediate ltk_right_r ltk_right_l : core. (* eqk, eqke are equalities, ltk is a strict order *) @@ -319,9 +319,9 @@ Module KeyOrderedType(O:OrderedType). exact (lt_not_eq H H1). Qed. - Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl. - Hint Resolve ltk_trans ltk_not_eqk ltk_not_eqke. - Hint Immediate eqk_sym eqke_sym. + Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl : core. + Hint Resolve ltk_trans ltk_not_eqk ltk_not_eqke : core. + Hint Immediate eqk_sym eqke_sym : core. Global Instance eqk_equiv : Equivalence eqk. Proof. constructor; eauto. Qed. @@ -359,22 +359,22 @@ Module KeyOrderedType(O:OrderedType). intros (k,e) (k',e') (k'',e''). unfold ltk, eqk; simpl; eauto. Qed. - Hint Resolve eqk_not_ltk. - Hint Immediate ltk_eqk eqk_ltk. + Hint Resolve eqk_not_ltk : core. + Hint Immediate ltk_eqk eqk_ltk : core. Lemma InA_eqke_eqk : forall x m, InA eqke x m -> InA eqk x m. Proof. unfold eqke; induction 1; intuition. Qed. - Hint Resolve InA_eqke_eqk. + Hint Resolve InA_eqke_eqk : core. Definition MapsTo (k:key)(e:elt):= InA eqke (k,e). Definition In k m := exists e:elt, MapsTo k e m. Notation Sort := (sort ltk). Notation Inf := (lelistA ltk). - Hint Unfold MapsTo In. + Hint Unfold MapsTo In : core. (* An alternative formulation for [In k l] is [exists e, InA eqk (k,e) l] *) @@ -405,8 +405,8 @@ Module KeyOrderedType(O:OrderedType). Lemma Inf_lt : forall l x x', ltk x x' -> Inf x' l -> Inf x l. Proof. exact (InfA_ltA ltk_strorder). Qed. - Hint Immediate Inf_eq. - Hint Resolve Inf_lt. + Hint Immediate Inf_eq : core. + Hint Resolve Inf_lt : core. Lemma Sort_Inf_In : forall l p q, Sort l -> Inf q l -> InA eqk p l -> ltk q p. @@ -469,19 +469,19 @@ Module KeyOrderedType(O:OrderedType). End Elt. - Hint Unfold eqk eqke ltk. - Hint Extern 2 (eqke ?a ?b) => split. - Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl. - Hint Resolve ltk_trans ltk_not_eqk ltk_not_eqke. - Hint Immediate eqk_sym eqke_sym. - Hint Resolve eqk_not_ltk. - Hint Immediate ltk_eqk eqk_ltk. - Hint Resolve InA_eqke_eqk. - Hint Unfold MapsTo In. - Hint Immediate Inf_eq. - Hint Resolve Inf_lt. - Hint Resolve Sort_Inf_NotIn. - Hint Resolve In_inv_2 In_inv_3. + Hint Unfold eqk eqke ltk : core. + Hint Extern 2 (eqke ?a ?b) => split : core. + Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl : core. + Hint Resolve ltk_trans ltk_not_eqk ltk_not_eqke : core. + Hint Immediate eqk_sym eqke_sym : core. + Hint Resolve eqk_not_ltk : core. + Hint Immediate ltk_eqk eqk_ltk : core. + Hint Resolve InA_eqke_eqk : core. + Hint Unfold MapsTo In : core. + Hint Immediate Inf_eq : core. + Hint Resolve Inf_lt : core. + Hint Resolve Sort_Inf_NotIn : core. + Hint Resolve In_inv_2 In_inv_3 : core. End KeyOrderedType. diff --git a/theories/Structures/Orders.v b/theories/Structures/Orders.v index 42756ad339..310a22a0a4 100644 --- a/theories/Structures/Orders.v +++ b/theories/Structures/Orders.v @@ -181,7 +181,7 @@ Module OTF_to_TotalOrder (O:OrderedTypeFull) <: TotalOrder we coerce [bool] into [Prop]. *) Local Coercion is_true : bool >-> Sortclass. -Hint Unfold is_true. +Hint Unfold is_true : core. Module Type HasLeb (Import T:Typ). Parameter Inline leb : t -> t -> bool. diff --git a/theories/Structures/OrdersLists.v b/theories/Structures/OrdersLists.v index abdb9eff05..fef9b14a9e 100644 --- a/theories/Structures/OrdersLists.v +++ b/theories/Structures/OrdersLists.v @@ -50,8 +50,8 @@ Proof. exact (InfA_alt O.eq_equiv O.lt_strorder O.lt_compat). Qed. Lemma Sort_NoDup : forall l, Sort l -> NoDup l. Proof. exact (SortA_NoDupA O.eq_equiv O.lt_strorder O.lt_compat) . Qed. -Hint Resolve ListIn_In Sort_NoDup Inf_lt. -Hint Immediate In_eq Inf_lt. +Hint Resolve ListIn_In Sort_NoDup Inf_lt : core. +Hint Immediate In_eq Inf_lt : core. End OrderedTypeLists. @@ -66,7 +66,7 @@ Module KeyOrderedType(O:OrderedType). Definition ltk {elt} : relation (key*elt) := O.lt @@1. - Hint Unfold ltk. + Hint Unfold ltk : core. (* ltk is a strict order *) @@ -109,8 +109,8 @@ Module KeyOrderedType(O:OrderedType). Lemma Inf_lt l x x' : ltk x x' -> Inf x' l -> Inf x l. Proof. apply InfA_ltA; auto with *. Qed. - Hint Immediate Inf_eq. - Hint Resolve Inf_lt. + Hint Immediate Inf_eq : core. + Hint Resolve Inf_lt : core. Lemma Sort_Inf_In l p q : Sort l -> Inf q l -> InA eqk p l -> ltk q p. Proof. apply SortA_InfA_InA; auto with *. Qed. @@ -148,10 +148,10 @@ Module KeyOrderedType(O:OrderedType). End Elt. - Hint Resolve ltk_not_eqk ltk_not_eqke. - Hint Immediate Inf_eq. - Hint Resolve Inf_lt. - Hint Resolve Sort_Inf_NotIn. + Hint Resolve ltk_not_eqk ltk_not_eqke : core. + Hint Immediate Inf_eq : core. + Hint Resolve Inf_lt : core. + Hint Resolve Sort_Inf_NotIn : core. End KeyOrderedType. diff --git a/theories/Vectors/VectorDef.v b/theories/Vectors/VectorDef.v index 4a2bddf35c..7f96aa6b87 100644 --- a/theories/Vectors/VectorDef.v +++ b/theories/Vectors/VectorDef.v @@ -269,28 +269,28 @@ Section SCANNING. Inductive Forall {A} (P: A -> Prop): forall {n} (v: t A n), Prop := |Forall_nil: Forall P [] |Forall_cons {n} x (v: t A n): P x -> Forall P v -> Forall P (x::v). -Hint Constructors Forall. +Hint Constructors Forall : core. Inductive Exists {A} (P:A->Prop): forall {n}, t A n -> Prop := |Exists_cons_hd {m} x (v: t A m): P x -> Exists P (x::v) |Exists_cons_tl {m} x (v: t A m): Exists P v -> Exists P (x::v). -Hint Constructors Exists. +Hint Constructors Exists : core. Inductive In {A} (a:A): forall {n}, t A n -> Prop := |In_cons_hd {m} (v: t A m): In a (a::v) |In_cons_tl {m} x (v: t A m): In a v -> In a (x::v). -Hint Constructors In. +Hint Constructors In : core. Inductive Forall2 {A B} (P:A->B->Prop): forall {n}, t A n -> t B n -> Prop := |Forall2_nil: Forall2 P [] [] |Forall2_cons {m} x1 x2 (v1:t A m) v2: P x1 x2 -> Forall2 P v1 v2 -> Forall2 P (x1::v1) (x2::v2). -Hint Constructors Forall2. +Hint Constructors Forall2 : core. Inductive Exists2 {A B} (P:A->B->Prop): forall {n}, t A n -> t B n -> Prop := |Exists2_cons_hd {m} x1 x2 (v1: t A m) (v2: t B m): P x1 x2 -> Exists2 P (x1::v1) (x2::v2) |Exists2_cons_tl {m} x1 x2 (v1:t A m) v2: Exists2 P v1 v2 -> Exists2 P (x1::v1) (x2::v2). -Hint Constructors Exists2. +Hint Constructors Exists2 : core. End SCANNING. diff --git a/theories/Wellfounded/Inclusion.v b/theories/Wellfounded/Inclusion.v index ff233ef9c6..18c4bedd9a 100644 --- a/theories/Wellfounded/Inclusion.v +++ b/theories/Wellfounded/Inclusion.v @@ -22,7 +22,7 @@ Section WfInclusion. apply Acc_intro; auto with sets. Qed. - Hint Resolve Acc_incl. + Hint Resolve Acc_incl : core. Theorem wf_incl : inclusion A R1 R2 -> well_founded R2 -> well_founded R1. Proof. diff --git a/theories/Wellfounded/Transitive_Closure.v b/theories/Wellfounded/Transitive_Closure.v index 59068623ae..0d56d88869 100644 --- a/theories/Wellfounded/Transitive_Closure.v +++ b/theories/Wellfounded/Transitive_Closure.v @@ -31,7 +31,7 @@ Section Wf_Transitive_Closure. apply Acc_inv with y; auto with sets. Defined. - Hint Resolve Acc_clos_trans. + Hint Resolve Acc_clos_trans : core. Lemma Acc_inv_trans : forall x y:A, trans_clos y x -> Acc R x -> Acc R y. Proof. diff --git a/theories/ZArith/Zdiv.v b/theories/ZArith/Zdiv.v index 74614e114a..c278cada61 100644 --- a/theories/ZArith/Zdiv.v +++ b/theories/ZArith/Zdiv.v @@ -73,7 +73,7 @@ Proof. intros; unfold Remainder, Remainder_alt; omega with *. Qed. -Hint Unfold Remainder. +Hint Unfold Remainder : core. (** Now comes the fully general result about Euclidean division. *) diff --git a/theories/ZArith/Zlogarithm.v b/theories/ZArith/Zlogarithm.v index 24412e9431..b8c7319939 100644 --- a/theories/ZArith/Zlogarithm.v +++ b/theories/ZArith/Zlogarithm.v @@ -47,7 +47,7 @@ Section Log_pos. (* Log of positive integers *) | xI n => Z.succ (Z.succ (log_inf n)) (* 2n+1 *) end. - Hint Unfold log_inf log_sup. + Hint Unfold log_inf log_sup : core. Lemma Psize_log_inf : forall p, Zpos (Pos.size p) = Z.succ (log_inf p). Proof. diff --git a/tools/coq_makefile.ml b/tools/coq_makefile.ml index ca5a232edb..8560bac786 100644 --- a/tools/coq_makefile.ml +++ b/tools/coq_makefile.ml @@ -396,8 +396,9 @@ let _ = | "-destination-of" :: tgt :: rest -> Some tgt, rest | _ -> None, args in - let project = - try cmdline_args_to_project ~curdir:Filename.current_dir_name args + let project = + let warning_fn x = Format.eprintf "%s@\n%!" x in + try cmdline_args_to_project ~warning_fn ~curdir:Filename.current_dir_name args with Parsing_error s -> prerr_endline s; usage_coq_makefile () in if only_destination <> None then begin diff --git a/tools/coqdep.ml b/tools/coqdep.ml index ba88069be9..226a19678f 100644 --- a/tools/coqdep.ml +++ b/tools/coqdep.ml @@ -473,7 +473,8 @@ let add_r_include path l = add_rec_dir_import add_known path (split_period l) let treat_coqproject f = let open CoqProject_file in let iter_sourced f = List.iter (fun {thing} -> f thing) in - let project = read_project_file f in + let warning_fn x = coqdep_warning "%s" x in + let project = read_project_file ~warning_fn f in iter_sourced (fun { path } -> add_caml_dir path) project.ml_includes; iter_sourced (fun ({ path }, l) -> add_q_include path l) project.q_includes; iter_sourced (fun ({ path }, l) -> add_r_include path l) project.r_includes; diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index e4d9e9ac25..66469ff0b9 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -107,7 +107,7 @@ let load_init_vernaculars cur_feeder opts ~state = (* Startup LoadPath and Modules *) (******************************************************************************) (* prelude_data == From Coq Require Export Prelude. *) -let prelude_data = "Prelude", Some "Coq", Some true +let prelude_data = "Prelude", Some "Coq", Some false let require_libs opts = if opts.load_init then prelude_data :: opts.vo_requires else opts.vo_requires diff --git a/vernac/assumptions.ml b/vernac/assumptions.ml index 6beac2032d..3ca2a4ad6b 100644 --- a/vernac/assumptions.ml +++ b/vernac/assumptions.ml @@ -294,7 +294,6 @@ let traverse current t = let type_of_constant cb = cb.Declarations.const_type let assumptions ?(add_opaque=false) ?(add_transparent=false) st gr t = - let (idts, knst) = st in (** Only keep the transitive dependencies *) let (_, graph, ax2ty) = traverse (label_of gr) t in let fold obj _ accu = match obj with @@ -316,7 +315,7 @@ let assumptions ?(add_opaque=false) ?(add_transparent=false) st gr t = let t = type_of_constant cb in let l = try GlobRef.Map_env.find obj ax2ty with Not_found -> [] in ContextObjectMap.add (Axiom (Constant kn,l)) t accu - else if add_opaque && (Declareops.is_opaque cb || not (Cpred.mem kn knst)) then + else if add_opaque && (Declareops.is_opaque cb || not (TransparentState.is_transparent_constant st kn)) then let t = type_of_constant cb in ContextObjectMap.add (Opaque kn) t accu else if add_transparent then diff --git a/vernac/assumptions.mli b/vernac/assumptions.mli index aead345d8c..536185f4aa 100644 --- a/vernac/assumptions.mli +++ b/vernac/assumptions.mli @@ -28,5 +28,5 @@ val traverse : on which a term relies (together with their type). The above warning of {!traverse} also applies. *) val assumptions : - ?add_opaque:bool -> ?add_transparent:bool -> transparent_state -> + ?add_opaque:bool -> ?add_transparent:bool -> TransparentState.t -> GlobRef.t -> constr -> types ContextObjectMap.t diff --git a/vernac/attributes.ml b/vernac/attributes.ml index 88638b295b..bc0b0310b3 100644 --- a/vernac/attributes.ml +++ b/vernac/attributes.ml @@ -9,7 +9,14 @@ (************************************************************************) open CErrors -open Vernacexpr + +(** The type of parsing attribute data *) +type vernac_flags = vernac_flag list +and vernac_flag = string * vernac_flag_value +and vernac_flag_value = + | VernacFlagEmpty + | VernacFlagLeaf of string + | VernacFlagList of vernac_flags let unsupported_attributes = function | [] -> () diff --git a/vernac/attributes.mli b/vernac/attributes.mli index c81082d5ad..c2dde4cbcc 100644 --- a/vernac/attributes.mli +++ b/vernac/attributes.mli @@ -8,7 +8,13 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Vernacexpr +(** The type of parsing attribute data *) +type vernac_flags = vernac_flag list +and vernac_flag = string * vernac_flag_value +and vernac_flag_value = + | VernacFlagEmpty + | VernacFlagLeaf of string + | VernacFlagList of vernac_flags type +'a attribute (** The type of attributes. When parsing attributes if an ['a @@ -80,7 +86,7 @@ val parse_with_extra : 'a attribute -> vernac_flags -> vernac_flags * 'a (** * Defining attributes. *) -type 'a key_parser = 'a option -> Vernacexpr.vernac_flag_value -> 'a +type 'a key_parser = 'a option -> vernac_flag_value -> 'a (** A parser for some key in an attribute. It is given a nonempty ['a option] when the attribute is multiply set for some command. diff --git a/vernac/classes.ml b/vernac/classes.ml index b0dba2485a..95e46b252b 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -188,8 +188,7 @@ let declare_instance_open env sigma ?hook ~tac ~program_mode ~global ~poly k id ] in ignore (Pfedit.by init_refine) - else if Flags.is_auto_intros () then - ignore (Pfedit.by (Tactics.auto_intros_tac ids)); + else ignore (Pfedit.by (Tactics.auto_intros_tac ids)); (match tac with Some tac -> ignore (Pfedit.by tac) | None -> ())) () let do_transparent_instance env env' sigma ?hook ~refine ~tac ~global ~poly ~program_mode cty k u ctx ctx' pri decl imps subst id props = diff --git a/vernac/egramml.mli b/vernac/egramml.mli index a90ef97e7d..3689f60383 100644 --- a/vernac/egramml.mli +++ b/vernac/egramml.mli @@ -21,10 +21,10 @@ type 's grammar_prod_item = ('s, 'a) Extend.symbol) Loc.located -> 's grammar_prod_item val extend_vernac_command_grammar : - Vernacexpr.extend_name -> vernac_expr Pcoq.Entry.t option -> + extend_name -> vernac_expr Pcoq.Entry.t option -> vernac_expr grammar_prod_item list -> unit -val get_extend_vernac_rule : Vernacexpr.extend_name -> vernac_expr grammar_prod_item list +val get_extend_vernac_rule : extend_name -> vernac_expr grammar_prod_item list val proj_symbol : ('a, 'b, 'c) Extend.ty_user_symbol -> ('a, 'b, 'c) Genarg.genarg_type diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index 1d0a5ab0a3..3cdf81ced0 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -30,6 +30,7 @@ open Pcoq.Prim open Pcoq.Constr open Pcoq.Module open Pvernac.Vernac_ +open Attributes let vernac_kw = [ ";"; ","; ">->"; ":<"; "<:"; "where"; "at" ] let _ = List.iter CLexer.add_keyword vernac_kw @@ -989,8 +990,9 @@ GRAMMAR EXTEND Gram | IDENT "Scope"; s = IDENT -> { PrintScope s } | IDENT "Visibility"; s = OPT IDENT -> { PrintVisibility s } | IDENT "Implicit"; qid = smart_global -> { PrintImplicit qid } - | IDENT "Universes"; fopt = OPT ne_string -> { PrintUniverses (false, fopt) } - | IDENT "Sorted"; IDENT "Universes"; fopt = OPT ne_string -> { PrintUniverses (true, fopt) } + | b = [ IDENT "Sorted" -> { true } | -> { false } ]; IDENT "Universes"; + g = OPT printunivs_subgraph; fopt = OPT ne_string -> + { PrintUniverses (b, g, fopt) } | IDENT "Assumptions"; qid = smart_global -> { PrintAssumptions (false, false, qid) } | IDENT "Opaque"; IDENT "Dependencies"; qid = smart_global -> { PrintAssumptions (true, false, qid) } | IDENT "Transparent"; IDENT "Dependencies"; qid = smart_global -> { PrintAssumptions (false, true, qid) } @@ -1000,6 +1002,9 @@ GRAMMAR EXTEND Gram | IDENT "Registered" -> { PrintRegistered } ] ] ; + printunivs_subgraph: + [ [ IDENT "Subgraph"; "("; l = LIST0 reference; ")" -> { l } ] ] + ; class_rawexpr: [ [ IDENT "Funclass" -> { FunClass } | IDENT "Sortclass" -> { SortClass } diff --git a/vernac/himsg.ml b/vernac/himsg.ml index ba31f73030..6c7117b513 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -884,8 +884,6 @@ let explain_not_match_error = function let status b = if b then str"polymorphic" else str"monomorphic" in str "a " ++ status b ++ str" declaration was expected, but a " ++ status (not b) ++ str" declaration was found" - | IncompatibleInstances -> - str"polymorphic universe instances do not match" | IncompatibleUniverses incon -> str"the universe constraints are inconsistent: " ++ Univ.explain_universe_inconsistency UnivNames.pr_with_global_universes incon @@ -894,11 +892,22 @@ let explain_not_match_error = function quote (Printer.safe_pr_lconstr_env env (Evd.from_env env) t1) ++ spc () ++ str "compared to " ++ spc () ++ quote (Printer.safe_pr_lconstr_env env (Evd.from_env env) t2) - | IncompatibleConstraints cst -> - str " the expected (polymorphic) constraints do not imply " ++ - let cst = Univ.UContext.constraints (Univ.AUContext.repr cst) in - (** FIXME: provide a proper naming for the bound variables *) - quote (Univ.pr_constraints (Termops.pr_evd_level Evd.empty) cst) + | IncompatibleConstraints { got; expect } -> + let open Univ in + let pr_auctx auctx = + let sigma = Evd.from_ctx + (UState.of_binders + (UnivNames.universe_binders_with_opt_names auctx None)) + in + let uctx = AUContext.repr auctx in + Printer.pr_universe_instance_constraints sigma + (UContext.instance uctx) + (UContext.constraints uctx) + in + str "incompatible polymorphic binders: got" ++ spc () ++ h 0 (pr_auctx got) ++ spc() ++ + str "but expected" ++ spc() ++ h 0 (pr_auctx expect) ++ + (if not (Int.equal (AUContext.size got) (AUContext.size expect)) then mt() else + fnl() ++ str "(incompatible constraints)") let explain_signature_mismatch l spec why = str "Signature components for label " ++ Label.print l ++ diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml index 3b041b7065..de020926f6 100644 --- a/vernac/lemmas.ml +++ b/vernac/lemmas.ml @@ -306,17 +306,18 @@ let universe_proof_terminator compute_guard hook = | Admitted (id,k,pe,ctx) -> admit (id,k,pe) (UState.universe_binders ctx) (hook (Some ctx)) (); Feedback.feedback Feedback.AddedAxiom - | Proved (opaque,idopt,proof) -> - let is_opaque, export_seff = match opaque with - | Transparent -> false, true - | Opaque -> true, false - in - let (id,(const,univs,persistence)) = Pfedit.cook_this_proof proof in - let const = {const with const_entry_opaque = is_opaque} in - let id = match idopt with - | None -> id - | Some { CAst.v = save_id } -> check_anonymity id save_id; save_id in - save ~export_seff id const univs compute_guard persistence (hook (Some univs)) + | Proved (opaque,idopt, { id; entries=[const]; persistence; universes } ) -> + let is_opaque, export_seff = match opaque with + | Transparent -> false, true + | Opaque -> true, false + in + let const = {const with const_entry_opaque = is_opaque} in + let id = match idopt with + | None -> id + | Some { CAst.v = save_id } -> check_anonymity id save_id; save_id in + save ~export_seff id const universes compute_guard persistence (hook (Some universes)) + | Proved (opaque,idopt, _ ) -> + CErrors.anomaly Pp.(str "[universe_proof_terminator] close_proof returned more than one proof term") end let standard_proof_terminator compute_guard hook = @@ -330,7 +331,7 @@ let initialize_named_context_for_proof () = let d = if variable_opacity id then NamedDecl.LocalAssum (id, NamedDecl.get_type d) else d in Environ.push_named_context_val d signv) sign Environ.empty_named_context_val -let start_proof id ?pl kind sigma ?terminator ?sign c ?init_tac ?(compute_guard=[]) hook = +let start_proof id ?pl kind sigma ?terminator ?sign c ?(compute_guard=[]) hook = let terminator = match terminator with | None -> standard_proof_terminator compute_guard hook | Some terminator -> terminator compute_guard hook @@ -340,19 +341,21 @@ let start_proof id ?pl kind sigma ?terminator ?sign c ?init_tac ?(compute_guard= | Some sign -> sign | None -> initialize_named_context_for_proof () in - Pfedit.start_proof id ?pl kind sigma sign c ?init_tac terminator + let goals = [ Global.env_of_context sign , c ] in + Proof_global.start_proof sigma id ?pl kind goals terminator -let start_proof_univs id ?pl kind sigma ?terminator ?sign c ?init_tac ?(compute_guard=[]) hook = +let start_proof_univs id ?pl kind sigma ?terminator ?sign c ?(compute_guard=[]) hook = let terminator = match terminator with | None -> universe_proof_terminator compute_guard hook | Some terminator -> terminator compute_guard hook in - let sign = + let sign = match sign with | Some sign -> sign | None -> initialize_named_context_for_proof () in - Pfedit.start_proof id ?pl kind sigma sign c ?init_tac terminator + let goals = [ Global.env_of_context sign , c ] in + Proof_global.start_proof sigma id ?pl kind goals terminator let rec_tac_initializer finite guard thms snl = if finite then @@ -372,22 +375,17 @@ let start_proof_with_initialization kind sigma decl recguard thms snl hook = let intro_tac (_, (_, (ids, _))) = Tactics.auto_intros_tac ids in let init_tac,guard = match recguard with | Some (finite,guard,init_tac) -> - let rec_tac = rec_tac_initializer finite guard thms snl in - Some (match init_tac with - | None -> - if Flags.is_auto_intros () then - Tacticals.New.tclTHENS rec_tac (List.map intro_tac thms) - else - rec_tac + let rec_tac = rec_tac_initializer finite guard thms snl in + Some (match init_tac with + | None -> + Tacticals.New.tclTHENS rec_tac (List.map intro_tac thms) | Some tacl -> - Tacticals.New.tclTHENS rec_tac - (if Flags.is_auto_intros () then - List.map2 (fun tac thm -> Tacticals.New.tclTHEN tac (intro_tac thm)) tacl thms - else - tacl)),guard + Tacticals.New.tclTHENS rec_tac + List.(map2 (fun tac thm -> Tacticals.New.tclTHEN tac (intro_tac thm)) tacl thms) + ),guard | None -> - let () = match thms with [_] -> () | _ -> assert false in - (if Flags.is_auto_intros () then Some (intro_tac (List.hd thms)) else None), [] in + let () = match thms with [_] -> () | _ -> assert false in + Some (intro_tac (List.hd thms)), [] in match thms with | [] -> anomaly (Pp.str "No proof to start.") | (id,(t,(_,imps)))::other_thms -> @@ -408,7 +406,11 @@ let start_proof_with_initialization kind sigma decl recguard thms snl hook = List.iter (fun (strength,ref,imps) -> maybe_declare_manual_implicits false ref imps; call_hook (fun exn -> exn) hook strength ref) thms_data in - start_proof_univs id ~pl:decl kind sigma t ?init_tac (fun ctx -> mk_hook (hook ctx)) ~compute_guard:guard + start_proof_univs id ~pl:decl kind sigma t (fun ctx -> mk_hook (hook ctx)) ~compute_guard:guard; + ignore (Proof_global.with_current_proof (fun _ p -> + match init_tac with + | None -> p,(true,[]) + | Some tac -> Proof.run_tactic Global.(env ()) tac p)) let start_proof_com ?inference_hook kind thms hook = let env0 = Global.env () in @@ -418,8 +420,8 @@ let start_proof_com ?inference_hook kind thms hook = let evd, (impls, ((env, ctx), imps)) = interp_context_evars env0 evd bl in let evd, (t', imps') = interp_type_evars_impls ~impls env evd t in let flags = all_and_fail_flags in - let flags = { flags with use_hook = inference_hook } in - let evd = solve_remaining_evars flags env evd Evd.empty in + let hook = inference_hook in + let evd = solve_remaining_evars ?hook flags env evd Evd.empty in let ids = List.map RelDecl.get_name ctx in check_name_freshness (pi1 kind) id; (* XXX: The nf_evar is critical !! *) diff --git a/vernac/lemmas.mli b/vernac/lemmas.mli index 195fcbf4ca..246d8cbe6d 100644 --- a/vernac/lemmas.mli +++ b/vernac/lemmas.mli @@ -18,13 +18,13 @@ val call_hook : Future.fix_exn -> declaration_hook -> Decl_kinds.locality -> Glo val start_proof : Id.t -> ?pl:UState.universe_decl -> goal_kind -> Evd.evar_map -> ?terminator:(Proof_global.lemma_possible_guards -> declaration_hook -> Proof_global.proof_terminator) -> ?sign:Environ.named_context_val -> EConstr.types -> - ?init_tac:unit Proofview.tactic -> ?compute_guard:Proof_global.lemma_possible_guards -> + ?compute_guard:Proof_global.lemma_possible_guards -> declaration_hook -> unit val start_proof_univs : Id.t -> ?pl:UState.universe_decl -> goal_kind -> Evd.evar_map -> ?terminator:(Proof_global.lemma_possible_guards -> (UState.t option -> declaration_hook) -> Proof_global.proof_terminator) -> ?sign:Environ.named_context_val -> EConstr.types -> - ?init_tac:unit Proofview.tactic -> ?compute_guard:Proof_global.lemma_possible_guards -> + ?compute_guard:Proof_global.lemma_possible_guards -> (UState.t option -> declaration_hook) -> unit val start_proof_com : diff --git a/vernac/obligations.ml b/vernac/obligations.ml index c2805674e4..8baf391c70 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -826,26 +826,41 @@ let rec string_of_list sep f = function | x :: ((y :: _) as tl) -> f x ^ sep ^ string_of_list sep f tl (* Solve an obligation using tactics, return the corresponding proof term *) +let warn_solve_errored = CWarnings.create ~name:"solve_obligation_error" ~category:"tactics" (fun err -> + Pp.seq [str "Solve Obligations tactic returned error: "; err; fnl (); + str "This will become an error in the future"]) -let solve_by_tac name evi t poly ctx = +let solve_by_tac ?loc name evi t poly ctx = let id = name in (* spiwack: the status is dropped. *) - let (entry,_,ctx') = Pfedit.build_constant_by_tactic - id ~goal_kind:(goal_kind poly) ctx evi.evar_hyps evi.evar_concl (Tacticals.New.tclCOMPLETE t) in - let env = Global.env () in - let entry = Safe_typing.inline_private_constants_in_definition_entry env entry in - let body, () = Future.force entry.const_entry_body in - let ctx' = Evd.merge_context_set ~sideff:true Evd.univ_rigid (Evd.from_ctx ctx') (snd body) in - Inductiveops.control_only_guard env ctx' (EConstr.of_constr (fst body)); - (fst body), entry.const_entry_type, Evd.evar_universe_context ctx' + try + let (entry,_,ctx') = + Pfedit.build_constant_by_tactic + id ~goal_kind:(goal_kind poly) ctx evi.evar_hyps evi.evar_concl t in + let env = Global.env () in + let entry = Safe_typing.inline_private_constants_in_definition_entry env entry in + let body, () = Future.force entry.const_entry_body in + let ctx' = Evd.merge_context_set ~sideff:true Evd.univ_rigid (Evd.from_ctx ctx') (snd body) in + Inductiveops.control_only_guard env ctx' (EConstr.of_constr (fst body)); + Some (fst body, entry.const_entry_type, Evd.evar_universe_context ctx') + with + | Refiner.FailError (_, s) as exn -> + let _ = CErrors.push exn in + user_err ?loc ~hdr:"solve_obligation" (Lazy.force s) + (* If the proof is open we absorb the error and leave the obligation open *) + | Proof.OpenProof _ -> + None + | e when CErrors.noncritical e -> + let err = CErrors.print e in + warn_solve_errored ?loc err; + None let obligation_terminator name num guard hook auto pf = let open Proof_global in let term = Lemmas.universe_proof_terminator guard hook in match pf with | Admitted _ -> apply_terminator term pf - | Proved (opq, id, proof) -> - let (_, (entry, uctx, _)) = Pfedit.cook_this_proof proof in + | Proved (opq, id, { entries=[entry]; universes=uctx } ) -> begin let env = Global.env () in let entry = Safe_typing.inline_private_constants_in_definition_entry env entry in let ty = entry.Entries.const_entry_type in @@ -904,6 +919,9 @@ let obligation_terminator name num guard hook auto pf = with e when CErrors.noncritical e -> let e = CErrors.push e in pperror (CErrors.iprint (ExplainErr.process_vernac_interp_error e)) + end + | Proved (_, _, _ ) -> + CErrors.anomaly Pp.(str "[obligation_terminator] close_proof returned more than one proof term") let obligation_hook prg obl num auto ctx' _ gr = let obls, rem = prg.prg_obligations in @@ -987,41 +1005,34 @@ and solve_obligation_by_tac prg obls i tac = match obl.obl_body with | Some _ -> None | None -> - try - if List.is_empty (deps_remaining obls obl.obl_deps) then - let obl = subst_deps_obl obls obl in - let tac = - match tac with - | Some t -> t - | None -> - match obl.obl_tac with - | Some t -> t - | None -> !default_tactic - in - let evd = Evd.from_ctx prg.prg_ctx in - let evd = Evd.update_sigma_env evd (Global.env ()) in - let t, ty, ctx = - solve_by_tac obl.obl_name (evar_of_obligation obl) tac - (pi2 prg.prg_kind) (Evd.evar_universe_context evd) - in - let uctx = UState.const_univ_entry ~poly:(pi2 prg.prg_kind) ctx in - let prg = {prg with prg_ctx = ctx} in - let def, obl' = declare_obligation prg obl t ty uctx in - obls.(i) <- obl'; - if def && not (pi2 prg.prg_kind) then ( - (* Declare the term constraints with the first obligation only *) - let evd = Evd.from_env (Global.env ()) in - let evd = Evd.merge_universe_subst evd (Evd.universe_subst (Evd.from_ctx ctx)) in - let ctx' = Evd.evar_universe_context evd in - Some {prg with prg_ctx = ctx'}) - else Some prg - else None - with e when CErrors.noncritical e -> - let (e, _) = CErrors.push e in - match e with - | Refiner.FailError (_, s) -> - user_err ?loc:(fst obl.obl_location) ~hdr:"solve_obligation" (Lazy.force s) - | e -> None (* FIXME really ? *) + if List.is_empty (deps_remaining obls obl.obl_deps) then + let obl = subst_deps_obl obls obl in + let tac = + match tac with + | Some t -> t + | None -> + match obl.obl_tac with + | Some t -> t + | None -> !default_tactic + in + let evd = Evd.from_ctx prg.prg_ctx in + let evd = Evd.update_sigma_env evd (Global.env ()) in + match solve_by_tac ?loc:(fst obl.obl_location) obl.obl_name (evar_of_obligation obl) tac + (pi2 prg.prg_kind) (Evd.evar_universe_context evd) with + | None -> None + | Some (t, ty, ctx) -> + let uctx = UState.const_univ_entry ~poly:(pi2 prg.prg_kind) ctx in + let prg = {prg with prg_ctx = ctx} in + let def, obl' = declare_obligation prg obl t ty uctx in + obls.(i) <- obl'; + if def && not (pi2 prg.prg_kind) then ( + (* Declare the term constraints with the first obligation only *) + let evd = Evd.from_env (Global.env ()) in + let evd = Evd.merge_universe_subst evd (Evd.universe_subst (Evd.from_ctx ctx)) in + let ctx' = Evd.evar_universe_context evd in + Some {prg with prg_ctx = ctx'}) + else Some prg + else None and solve_prg_obligations prg ?oblset tac = let obls, rem = prg.prg_obligations in diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml index 1c1faca599..2ddd210365 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -492,12 +492,13 @@ open Pputils keyword "Print Hint *" | PrintHintDbName s -> keyword "Print HintDb" ++ spc () ++ str s - | PrintUniverses (b, fopt) -> + | PrintUniverses (b, g, fopt) -> let cmd = if b then "Print Sorted Universes" else "Print Universes" in - keyword cmd ++ pr_opt str fopt + let pr_subgraph = prlist_with_sep spc pr_qualid in + keyword cmd ++ pr_opt pr_subgraph g ++ pr_opt str fopt | PrintName (qid,udecl) -> keyword "Print" ++ spc() ++ pr_smart_global qid ++ pr_univ_name_list udecl | PrintModuleType qid -> @@ -1213,6 +1214,7 @@ open Pputils let rec pr_vernac_flag (k, v) = let k = keyword k in + let open Attributes in match v with | VernacFlagEmpty -> k | VernacFlagLeaf v -> k ++ str " = " ++ qs v diff --git a/vernac/pvernac.ml b/vernac/pvernac.ml index b2fa8ec99f..4761e4bbc2 100644 --- a/vernac/pvernac.ml +++ b/vernac/pvernac.ml @@ -42,7 +42,7 @@ module Vernac_ = let command_entry_ref = ref noedit_mode let command_entry = Gram.Entry.of_parser "command_entry" - (fun strm -> Gram.Entry.parse_token !command_entry_ref strm) + (fun strm -> Gram.Entry.parse_token_stream !command_entry_ref strm) end diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 1fab35b650..a78329ad1d 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -319,7 +319,7 @@ let print_registered () = hov 0 (prlist_with_sep fnl pr_lib_ref @@ Coqlib.get_lib_refs ()) -let dump_universes_gen g s = +let dump_universes_gen prl g s = let output = open_out s in let output_constraint, close = if Filename.check_suffix s ".dot" || Filename.check_suffix s ".gv" then begin @@ -344,10 +344,12 @@ let dump_universes_gen g s = | Univ.Lt -> "<" | Univ.Le -> "<=" | Univ.Eq -> "=" - in Printf.fprintf output "%s %s %s ;\n" left kind right + in + Printf.fprintf output "%s %s %s ;\n" left kind right end, (fun () -> close_out output) end in + let output_constraint k l r = output_constraint k (prl l) (prl r) in try UGraph.dump_universes output_constraint g; close (); @@ -357,6 +359,36 @@ let dump_universes_gen g s = close (); iraise reraise +let universe_subgraph ?loc g univ = + let open Univ in + let sigma = Evd.from_env (Global.env()) in + let univs_of q = + let q = Glob_term.(GType (UNamed q)) in + (* this function has a nice error message for not found univs *) + LSet.singleton (Pretyping.interp_known_glob_level ?loc sigma q) + in + let univs = List.fold_left (fun univs q -> LSet.union univs (univs_of q)) LSet.empty g in + let csts = UGraph.constraints_for ~kept:(LSet.add Level.prop (LSet.add Level.set univs)) univ in + let univ = LSet.fold UGraph.add_universe_unconstrained univs UGraph.initial_universes in + UGraph.merge_constraints csts univ + +let print_universes ?loc ~sort ~subgraph dst = + let univ = Global.universes () in + let univ = match subgraph with + | None -> univ + | Some g -> universe_subgraph ?loc g univ + in + let univ = if sort then UGraph.sort_universes univ else univ in + let pr_remaining = + if Global.is_joined_environment () then mt () + else str"There may remain asynchronous universe constraints" + in + let prl = UnivNames.pr_with_global_universes in + begin match dst with + | None -> UGraph.pr_universes prl univ ++ pr_remaining + | Some s -> dump_universes_gen (fun u -> Pp.string_of_ppcmds (prl u)) univ s + end + (*********************) (* "Locate" commands *) @@ -457,8 +489,7 @@ let start_proof_and_print k l hook = Evarutil.is_ground_term sigma concl) then raise Exit; let c, _, ctx = - Pfedit.build_by_tactic env (Evd.evar_universe_context sigma) - concl (Tacticals.New.tclCOMPLETE tac) + Pfedit.build_by_tactic env (Evd.evar_universe_context sigma) concl tac in Evd.set_universe_context sigma ctx, EConstr.of_constr c with Logic_monad.TacticFailure e when Logic.catchable_exception e -> user_err Pp.(str "The statement obligations could not be resolved \ @@ -1064,15 +1095,30 @@ let vernac_restore_state file = (* Commands *) let vernac_create_hintdb ~module_local id b = - Hints.create_hint_db module_local id full_transparent_state b - -let vernac_remove_hints ~module_local dbs ids = - Hints.remove_hints module_local dbs (List.map Smartlocate.global_with_alias ids) + Hints.create_hint_db module_local id TransparentState.full b + +let warn_implicit_core_hint_db = + CWarnings.create ~name:"implicit-core-hint-db" ~category:"deprecated" + (fun () -> strbrk "Adding and removing hints in the core database implicitly is deprecated. " + ++ strbrk"Please specify a hint database.") + +let vernac_remove_hints ~module_local dbnames ids = + let dbnames = + if List.is_empty dbnames then + (warn_implicit_core_hint_db (); ["core"]) + else dbnames + in + Hints.remove_hints module_local dbnames (List.map Smartlocate.global_with_alias ids) -let vernac_hints ~atts lb h = +let vernac_hints ~atts dbnames h = + let dbnames = + if List.is_empty dbnames then + (warn_implicit_core_hint_db (); ["core"]) + else dbnames + in let local, poly = Attributes.(parse Notations.(locality ++ polymorphic) atts) in let local = enforce_module_locality local in - Hints.add_hints ~local lb (Hints.interp_hints poly h) + Hints.add_hints ~local dbnames (Hints.interp_hints poly h) let vernac_syntactic_definition ~module_local lid x y = Dumpglob.dump_definition lid false "syndef"; @@ -1421,14 +1467,6 @@ let _ = let _ = declare_bool_option - { optdepr = true; (* remove in 8.8 *) - optname = "automatic introduction of variables"; - optkey = ["Automatic";"Introduction"]; - optread = Flags.is_auto_intros; - optwrite = Flags.make_auto_intros } - -let _ = - declare_bool_option { optdepr = false; optname = "coercion printing"; optkey = ["Printing";"Coercions"]; @@ -1826,17 +1864,7 @@ let vernac_print ~atts env sigma = | PrintCoercionPaths (cls,clt) -> Prettyp.print_path_between (cl_of_qualid cls) (cl_of_qualid clt) | PrintCanonicalConversions -> Prettyp.print_canonical_projections env sigma - | PrintUniverses (b, dst) -> - let univ = Global.universes () in - let univ = if b then UGraph.sort_universes univ else univ in - let pr_remaining = - if Global.is_joined_environment () then mt () - else str"There may remain asynchronous universe constraints" - in - begin match dst with - | None -> UGraph.pr_universes UnivNames.pr_with_global_universes univ ++ pr_remaining - | Some s -> dump_universes_gen univ s - end + | PrintUniverses (sort, subgraph, dst) -> print_universes ~sort ~subgraph dst | PrintHint r -> Hints.pr_hint_ref env sigma (smart_global r) | PrintHintGoal -> Hints.pr_applicable_hint () | PrintHintDbName s -> Hints.pr_hint_db_by_name env sigma s diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml index 594e9eca48..122005e011 100644 --- a/vernac/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -45,7 +45,7 @@ type printable = | PrintCoercions | PrintCoercionPaths of class_rawexpr * class_rawexpr | PrintCanonicalConversions - | PrintUniverses of bool * string option + | PrintUniverses of bool * qualid list option * string option | PrintHint of qualid or_by_notation | PrintHintGoal | PrintHintDbName of string @@ -219,13 +219,6 @@ type section_subset_expr = {b ("ExtractionBlacklist", 0)} indicates {b Extraction Blacklist {i ident{_1}} ... {i ident{_n}}} command. *) -type extend_name = - (** Name of the vernac entry where the tactic is defined, typically found - after the VERNAC EXTEND statement in the source. *) - string * - (** Index of the extension in the VERNAC EXTEND statement. Each parsing branch - is given an offset, starting from zero. *) - int (* This type allows registering the inlining of constants in native compiler. It will be extended with primitive inductive types and operators *) @@ -253,6 +246,14 @@ type vernac_argument_status = { implicit_status : vernac_implicit_status; } +type extend_name = + (** Name of the vernac entry where the tactic is defined, typically found + after the VERNAC EXTEND statement in the source. *) + string * + (** Index of the extension in the VERNAC EXTEND statement. Each parsing branch + is given an offset, starting from zero. *) + int + type nonrec vernac_expr = | VernacLoad of verbose_flag * string @@ -395,71 +396,11 @@ type nonrec vernac_expr = (* For extension *) | VernacExtend of extend_name * Genarg.raw_generic_argument list -type vernac_flags = vernac_flag list -and vernac_flag = string * vernac_flag_value -and vernac_flag_value = - | VernacFlagEmpty - | VernacFlagLeaf of string - | VernacFlagList of vernac_flags - type vernac_control = - | VernacExpr of vernac_flags * vernac_expr + | VernacExpr of Attributes.vernac_flags * vernac_expr (* boolean is true when the `-time` batch-mode command line flag was set. the flag is used to print differently in `-time` vs `Time foo` *) | VernacTime of bool * vernac_control CAst.t | VernacRedirect of string * vernac_control CAst.t | VernacTimeout of int * vernac_control | VernacFail of vernac_control - -(* A vernac classifier provides information about the exectuion of a - command: - - - vernac_when: encodes if the vernac may alter the parser [thus - forcing immediate execution], or if indeed it is pure and parsing - can continue without its execution. - - - vernac_type: if it is starts, ends, continues a proof or - alters the global state or is a control command like BackTo or is - a query like Check. - - The classification works on the assumption that we have 3 states: - parsing, execution (global enviroment, etc...), and proof - state. For example, commands that only alter the proof state are - considered safe to delegate to a worker. - -*) -type vernac_type = - (* Start of a proof *) - | VtStartProof of vernac_start - (* Command altering the global state, bad for parallel - processing. *) - | VtSideff of vernac_sideff_type - (* End of a proof *) - | VtQed of vernac_qed_type - (* A proof step *) - | VtProofStep of proof_step - (* To be removed *) - | VtProofMode of string - (* Queries are commands assumed to be "pure", that is to say, they - don't modify the interpretation state. *) - | VtQuery - (* To be removed *) - | VtMeta - | VtUnknown -and vernac_qed_type = VtKeep | VtKeepAsAxiom | VtDrop (* Qed/Admitted, Abort *) -and vernac_start = string * opacity_guarantee * Id.t list -and vernac_sideff_type = Id.t list -and opacity_guarantee = - | GuaranteesOpacity (** Only generates opaque terms at [Qed] *) - | Doesn'tGuaranteeOpacity (** May generate transparent terms even with [Qed].*) -and proof_step = { (* TODO: inline with OCaml 4.03 *) - parallel : [ `Yes of solving_tac * anon_abstracting_tac | `No ]; - proof_block_detection : proof_block_name option -} -and solving_tac = bool (* a terminator *) -and anon_abstracting_tac = bool (* abstracting anonymously its result *) -and proof_block_name = string (* open type of delimiters *) -type vernac_when = - | VtNow - | VtLater -type vernac_classification = vernac_type * vernac_when diff --git a/vernac/vernacextend.ml b/vernac/vernacextend.ml index 5fba586298..3a321ecdb4 100644 --- a/vernac/vernacextend.ml +++ b/vernac/vernacextend.ml @@ -12,7 +12,43 @@ open Util open Pp open CErrors -type 'a vernac_command = 'a -> atts:Vernacexpr.vernac_flags -> st:Vernacstate.t -> Vernacstate.t +type vernac_type = + (* Start of a proof *) + | VtStartProof of vernac_start + (* Command altering the global state, bad for parallel + processing. *) + | VtSideff of vernac_sideff_type + (* End of a proof *) + | VtQed of vernac_qed_type + (* A proof step *) + | VtProofStep of { + parallel : [ `Yes of solving_tac * anon_abstracting_tac | `No ]; + proof_block_detection : proof_block_name option + } + (* To be removed *) + | VtProofMode of string + (* Queries are commands assumed to be "pure", that is to say, they + don't modify the interpretation state. *) + | VtQuery + (* To be removed *) + | VtMeta + | VtUnknown +and vernac_qed_type = VtKeep | VtKeepAsAxiom | VtDrop (* Qed/Admitted, Abort *) +and vernac_start = string * opacity_guarantee * Names.Id.t list +and vernac_sideff_type = Names.Id.t list +and opacity_guarantee = + | GuaranteesOpacity (** Only generates opaque terms at [Qed] *) + | Doesn'tGuaranteeOpacity (** May generate transparent terms even with [Qed].*) +and solving_tac = bool (** a terminator *) +and anon_abstracting_tac = bool (** abstracting anonymously its result *) +and proof_block_name = string (** open type of delimiters *) + +type vernac_when = + | VtNow + | VtLater +type vernac_classification = vernac_type * vernac_when + +type 'a vernac_command = 'a -> atts:Attributes.vernac_flags -> st:Vernacstate.t -> Vernacstate.t type plugin_args = Genarg.raw_generic_argument list @@ -68,10 +104,23 @@ let call opn converted_args ~atts ~st = (** VERNAC EXTEND registering *) -type classifier = Genarg.raw_generic_argument list -> Vernacexpr.vernac_classification +type classifier = Genarg.raw_generic_argument list -> vernac_classification + +(** Classifiers *) +let classifiers : classifier array String.Map.t ref = ref String.Map.empty + +let get_vernac_classifier (name, i) args = + (String.Map.find name !classifiers).(i) args + +let declare_vernac_classifier name f = + classifiers := String.Map.add name f !classifiers + +let classify_as_query = VtQuery, VtLater +let classify_as_sideeff = VtSideff [], VtLater +let classify_as_proofstep = VtProofStep { parallel = `No; proof_block_detection = None}, VtLater type (_, _) ty_sig = -| TyNil : (atts:Vernacexpr.vernac_flags -> st:Vernacstate.t -> Vernacstate.t, Vernacexpr.vernac_classification) ty_sig +| TyNil : (atts:Attributes.vernac_flags -> st:Vernacstate.t -> Vernacstate.t, vernac_classification) ty_sig | TyTerminal : string * ('r, 's) ty_sig -> ('r, 's) ty_sig | TyNonTerminal : ('a, 'b, 'c) Extend.ty_user_symbol * ('r, 's) ty_sig -> ('a -> 'r, 'a -> 's) ty_sig @@ -124,7 +173,7 @@ let rec untype_user_symbol : type s a b c. (a, b, c) Extend.ty_user_symbol -> (s | TUentry a -> Aentry (Pcoq.genarg_grammar (Genarg.ExtraArg a)) | TUentryl (a, i) -> Aentryl (Pcoq.genarg_grammar (Genarg.ExtraArg a), string_of_int i) -let rec untype_grammar : type r s. (r, s) ty_sig -> Vernacexpr.vernac_expr Egramml.grammar_prod_item list = function +let rec untype_grammar : type r s. (r, s) ty_sig -> 'a Egramml.grammar_prod_item list = function | TyNil -> [] | TyTerminal (tok, ty) -> Egramml.GramTerminal tok :: untype_grammar ty | TyNonTerminal (tu, ty) -> @@ -132,16 +181,6 @@ let rec untype_grammar : type r s. (r, s) ty_sig -> Vernacexpr.vernac_expr Egram let symb = untype_user_symbol tu in Egramml.GramNonTerminal (Loc.tag (t, symb)) :: untype_grammar ty -let _ = untype_classifier, untype_command, untype_grammar, untype_user_symbol - -let classifiers : classifier array String.Map.t ref = ref String.Map.empty - -let get_vernac_classifier (name, i) args = - (String.Map.find name !classifiers).(i) args - -let declare_vernac_classifier name f = - classifiers := String.Map.add name f !classifiers - let vernac_extend ~command ?classifier ?entry ext = let get_classifier (TyML (_, ty, _, cl)) = match cl with | Some cl -> untype_classifier ty cl diff --git a/vernac/vernacextend.mli b/vernac/vernacextend.mli index bb94f3a6a9..7feaccd9a3 100644 --- a/vernac/vernacextend.mli +++ b/vernac/vernacextend.mli @@ -8,20 +8,75 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +(** Vernacular Extension data *) + +(* A vernac classifier provides information about the exectuion of a + command: + + - vernac_when: encodes if the vernac may alter the parser [thus + forcing immediate execution], or if indeed it is pure and parsing + can continue without its execution. + + - vernac_type: if it is starts, ends, continues a proof or + alters the global state or is a control command like BackTo or is + a query like Check. + + The classification works on the assumption that we have 3 states: + parsing, execution (global enviroment, etc...), and proof + state. For example, commands that only alter the proof state are + considered safe to delegate to a worker. + +*) +type vernac_type = + (* Start of a proof *) + | VtStartProof of vernac_start + (* Command altering the global state, bad for parallel + processing. *) + | VtSideff of vernac_sideff_type + (* End of a proof *) + | VtQed of vernac_qed_type + (* A proof step *) + | VtProofStep of { + parallel : [ `Yes of solving_tac * anon_abstracting_tac | `No ]; + proof_block_detection : proof_block_name option + } + (* To be removed *) + | VtProofMode of string + (* Queries are commands assumed to be "pure", that is to say, they + don't modify the interpretation state. *) + | VtQuery + (* To be removed *) + | VtMeta + | VtUnknown +and vernac_qed_type = VtKeep | VtKeepAsAxiom | VtDrop (* Qed/Admitted, Abort *) +and vernac_start = string * opacity_guarantee * Names.Id.t list +and vernac_sideff_type = Names.Id.t list +and opacity_guarantee = + | GuaranteesOpacity (** Only generates opaque terms at [Qed] *) + | Doesn'tGuaranteeOpacity (** May generate transparent terms even with [Qed].*) +and solving_tac = bool (** a terminator *) +and anon_abstracting_tac = bool (** abstracting anonymously its result *) +and proof_block_name = string (** open type of delimiters *) + +type vernac_when = + | VtNow + | VtLater +type vernac_classification = vernac_type * vernac_when + (** Interpretation of extended vernac phrases. *) -type 'a vernac_command = 'a -> atts:Vernacexpr.vernac_flags -> st:Vernacstate.t -> Vernacstate.t +type 'a vernac_command = 'a -> atts:Attributes.vernac_flags -> st:Vernacstate.t -> Vernacstate.t type plugin_args = Genarg.raw_generic_argument list -val call : Vernacexpr.extend_name -> plugin_args -> atts:Vernacexpr.vernac_flags -> st:Vernacstate.t -> Vernacstate.t +val call : Vernacexpr.extend_name -> plugin_args -> atts:Attributes.vernac_flags -> st:Vernacstate.t -> Vernacstate.t (** {5 VERNAC EXTEND} *) -type classifier = Genarg.raw_generic_argument list -> Vernacexpr.vernac_classification +type classifier = Genarg.raw_generic_argument list -> vernac_classification type (_, _) ty_sig = -| TyNil : (atts:Vernacexpr.vernac_flags -> st:Vernacstate.t -> Vernacstate.t, Vernacexpr.vernac_classification) ty_sig +| TyNil : (atts:Attributes.vernac_flags -> st:Vernacstate.t -> Vernacstate.t, vernac_classification) ty_sig | TyTerminal : string * ('r, 's) ty_sig -> ('r, 's) ty_sig | TyNonTerminal : ('a, 'b, 'c) Extend.ty_user_symbol * ('r, 's) ty_sig -> @@ -32,7 +87,7 @@ type ty_ml = TyML : bool (** deprecated *) * ('r, 's) ty_sig * 'r * 's option -> (** Wrapper to dynamically extend vernacular commands. *) val vernac_extend : command:string -> - ?classifier:(string -> Vernacexpr.vernac_classification) -> + ?classifier:(string -> vernac_classification) -> ?entry:Vernacexpr.vernac_expr Pcoq.Entry.t -> ty_ml list -> unit @@ -55,6 +110,9 @@ val vernac_argument_extend : name:string -> 'a vernac_argument -> ('a, unit, unit) Genarg.genarg_type * 'a Pcoq.Entry.t (** {5 STM classifiers} *) +val get_vernac_classifier : Vernacexpr.extend_name -> classifier -val get_vernac_classifier : - Vernacexpr.extend_name -> classifier +(** Standard constant classifiers *) +val classify_as_query : vernac_classification +val classify_as_sideeff : vernac_classification +val classify_as_proofstep : vernac_classification |