diff options
56 files changed, 751 insertions, 623 deletions
diff --git a/API/API.mli b/API/API.mli index 830c0a0f65..e320e496c0 100644 --- a/API/API.mli +++ b/API/API.mli @@ -1302,6 +1302,10 @@ sig | CoFinite | BiFinite + type discharge = + | DoDischarge + | NoDischarge + type locality = | Discharge | Local @@ -1320,6 +1324,7 @@ sig | IdentityCoercion | Instance | Method + | Let type theorem_kind = | Theorem | Lemma @@ -2077,7 +2082,11 @@ sig val basename : full_path -> Names.Id.t type object_name = full_path * Names.KerName.t - type object_prefix = Names.DirPath.t * (Names.ModPath.t * Names.DirPath.t) + type object_prefix = { + obj_dir : DirPath.t; + obj_mp : ModPath.t; + obj_sec : DirPath.t; + } module Dirset : Set.S with type elt = DirPath.t module Dirmap : Map.ExtS with type key = DirPath.t and module Set := Dirset @@ -3712,7 +3721,7 @@ end module Retyping : (* reconstruct the type of a term knowing that it was already typechecked *) sig val get_type_of : ?polyprop:bool -> ?lax:bool -> Environ.env -> Evd.evar_map -> EConstr.constr -> EConstr.types - val get_sort_family_of : ?polyprop:bool -> Environ.env -> Evd.evar_map -> EConstr.types -> Sorts.family + val get_sort_family_of : ?truncation_style:bool -> ?polyprop:bool -> Environ.env -> Evd.evar_map -> EConstr.types -> Sorts.family val expand_projection : Environ.env -> Evd.evar_map -> Names.Projection.t -> EConstr.constr -> EConstr.constr list -> EConstr.constr val get_sort_of : ?polyprop:bool -> Environ.env -> Evd.evar_map -> EConstr.types -> Sorts.t @@ -4028,8 +4037,6 @@ sig type verbose_flag = bool - type obsolete_locality = bool - type universe_decl_expr = (lident list, Misctypes.glob_constraint list) gen_universe_decl type ident_decl = lident * universe_decl_expr option @@ -4144,29 +4151,27 @@ sig | VernacRedirect of string * vernac_expr Loc.located | VernacTimeout of int * vernac_expr | VernacFail of vernac_expr - | VernacSyntaxExtension of - bool * obsolete_locality * (lstring * syntax_modifier list) - | VernacOpenCloseScope of obsolete_locality * (bool * scope_name) + | VernacSyntaxExtension of bool * (lstring * syntax_modifier list) + | VernacOpenCloseScope of bool * scope_name | VernacDelimiters of scope_name * string option | VernacBindScope of scope_name * class_rawexpr list - | VernacInfix of obsolete_locality * (lstring * syntax_modifier list) * + | VernacInfix of (lstring * syntax_modifier list) * Constrexpr.constr_expr * scope_name option | VernacNotation of - obsolete_locality * Constrexpr.constr_expr * (lstring * syntax_modifier list) * + Constrexpr.constr_expr * (lstring * syntax_modifier list) * scope_name option | VernacNotationAddFormat of string * string * string - | VernacDefinition of - (Decl_kinds.locality option * Decl_kinds.definition_object_kind) * ident_decl * definition_expr + | VernacDefinition of (Decl_kinds.discharge * Decl_kinds.definition_object_kind) * ident_decl * definition_expr | VernacStartTheoremProof of Decl_kinds.theorem_kind * proof_expr list | VernacEndProof of proof_end | VernacExactProof of Constrexpr.constr_expr - | VernacAssumption of (Decl_kinds.locality option * Decl_kinds.assumption_object_kind) * + | VernacAssumption of (Decl_kinds.discharge * Decl_kinds.assumption_object_kind) * inline * (ident_decl list * Constrexpr.constr_expr) with_coercion list | VernacInductive of cumulative_inductive_parsing_flag * Decl_kinds.private_flag * inductive_flag * (inductive_expr * decl_notation list) list | VernacFixpoint of - Decl_kinds.locality option * (fixpoint_expr * decl_notation list) list + Decl_kinds.discharge * (fixpoint_expr * decl_notation list) list | VernacCoFixpoint of - Decl_kinds.locality option * (cofixpoint_expr * decl_notation list) list + Decl_kinds.discharge * (cofixpoint_expr * decl_notation list) list | VernacScheme of (lident option * scheme) list | VernacCombinedScheme of lident * lident list | VernacUniverse of lident list @@ -4177,9 +4182,9 @@ sig Libnames.reference option * bool option * Libnames.reference list | VernacImport of bool * Libnames.reference list | VernacCanonical of Libnames.reference Misctypes.or_by_notation - | VernacCoercion of obsolete_locality * Libnames.reference Misctypes.or_by_notation * + | VernacCoercion of Libnames.reference Misctypes.or_by_notation * class_rawexpr * class_rawexpr - | VernacIdentityCoercion of obsolete_locality * lident * + | VernacIdentityCoercion of lident * class_rawexpr * class_rawexpr | VernacNameSectionHypSet of lident * section_subset_expr | VernacInstance of @@ -4213,9 +4218,9 @@ sig | VernacBackTo of int | VernacCreateHintDb of string * bool | VernacRemoveHints of string list * Libnames.reference list - | VernacHints of obsolete_locality * string list * hints_expr + | VernacHints of string list * hints_expr | VernacSyntacticDefinition of Names.Id.t Loc.located * (Names.Id.t list * Constrexpr.constr_expr) * - obsolete_locality * onlyparsing_flag + onlyparsing_flag | VernacDeclareImplicits of Libnames.reference Misctypes.or_by_notation * (Constrexpr.explicitation * bool * bool) list list | VernacArguments of Libnames.reference Misctypes.or_by_notation * @@ -4795,24 +4800,26 @@ end module Proof : sig - type proof - type 'a focus_kind + type t + type proof = t + [@@ocaml.deprecated "please use [Proof.t]"] - val proof : proof -> + type 'a focus_kind + val proof : t -> Goal.goal list * (Goal.goal list * Goal.goal list) list * Goal.goal list * Goal.goal list * Evd.evar_map val run_tactic : Environ.env -> - unit Proofview.tactic -> proof -> proof * (bool * Proofview_monad.Info.tree) - val unshelve : proof -> proof - val maximal_unfocus : 'a focus_kind -> proof -> proof - val pr_proof : proof -> Pp.t + unit Proofview.tactic -> t -> t * (bool * Proofview_monad.Info.tree) + val unshelve : t -> t + val maximal_unfocus : 'a focus_kind -> t -> t + val pr_proof : t -> Pp.t module V82 : sig - val grab_evars : proof -> proof + val grab_evars : t -> t - val subgoals : proof -> Goal.goal list Evd.sigma + val subgoals : t -> Goal.goal list Evd.sigma [@@ocaml.deprecated "Use the first and fifth argument of [Proof.proof]"] end @@ -4826,7 +4833,9 @@ end module Proof_global : sig - type state + type t + type state = t + [@@ocaml.deprecated "please use [Proof_global.t]"] type proof_mode = { name : string; @@ -4857,14 +4866,14 @@ sig Names.Id.t -> ?pl:Univdecls.universe_decl -> Decl_kinds.goal_kind -> Proofview.telescope -> proof_terminator -> unit val with_current_proof : - (unit Proofview.tactic -> Proof.proof -> Proof.proof * 'a) -> 'a + (unit Proofview.tactic -> Proof.t -> Proof.t * 'a) -> 'a val simple_with_current_proof : - (unit Proofview.tactic -> Proof.proof -> Proof.proof) -> unit + (unit Proofview.tactic -> Proof.t -> Proof.t) -> unit val compact_the_proof : unit -> unit val register_proof_mode : proof_mode -> unit exception NoCurrentProof - val give_me_the_proof : unit -> Proof.proof + val give_me_the_proof : unit -> Proof.t (** @raise NoCurrentProof when outside proof mode. *) val discard_all : unit -> unit @@ -4995,7 +5004,7 @@ sig val by : unit Proofview.tactic -> bool val solve : ?with_end_tac:unit Proofview.tactic -> Vernacexpr.goal_selector -> int option -> unit Proofview.tactic -> - Proof.proof -> Proof.proof * bool + Proof.t -> Proof.t * bool val cook_proof : unit -> (Names.Id.t * (Safe_typing.private_constants Entries.definition_entry * Proof_global.proof_universes * Decl_kinds.goal_kind)) @@ -6108,9 +6117,9 @@ end module Vernacstate : sig - type t = { (* TODO: inline records in OCaml 4.03 *) + type t = { system : States.state; (* summary + libstack *) - proof : Proof_global.state; (* proof state *) + proof : Proof_global.t; (* proof state *) shallow : bool (* is the state trimmed down (libstack) *) } @@ -6128,14 +6137,14 @@ sig type atts = { loc : Loc.t option; locality : bool option; + polymorphic : bool; } - type vernac_command = - Genarg.raw_generic_argument list -> - atts:atts -> st:Vernacstate.t -> - Vernacstate.t + type 'a vernac_command = 'a -> atts:atts -> st:Vernacstate.t -> Vernacstate.t + + type plugin_args = Genarg.raw_generic_argument list - val vinterp_add : deprecation -> Vernacexpr.extend_name -> vernac_command -> unit + val vinterp_add : deprecation -> Vernacexpr.extend_name -> plugin_args vernac_command -> unit end @@ -21,8 +21,11 @@ Tactics - Tactic "decide equality" now able to manage constructors which contain proofs. -Checker +Vernacular Commands +- The deprecated Coercion Local, Open Local Scope, Notation Local syntax + was removed. Use Local as a prefix instead. +Checker - The checker now accepts filenames in addition to logical paths. Changes from 8.7+beta2 to 8.7.0 diff --git a/dev/ci/ci-vst.sh b/dev/ci/ci-vst.sh index 5bfc408e96..5760fbafb0 100755 --- a/dev/ci/ci-vst.sh +++ b/dev/ci/ci-vst.sh @@ -8,6 +8,6 @@ VST_CI_DIR=${CI_BUILD_DIR}/VST # opam install -j ${NJOBS} -y menhir git_checkout ${VST_CI_BRANCH} ${VST_CI_GITURL} ${VST_CI_DIR} -# Targets are: msl veric floyd +# Targets are: msl veric floyd progs , we remove progs to save time # Patch to avoid the upper version limit -( cd ${VST_CI_DIR} && make IGNORECOQVERSION=true ) +( cd ${VST_CI_DIR} && make IGNORECOQVERSION=true .loadpath version.vo msl veric floyd ) diff --git a/dev/doc/changes.md b/dev/doc/changes.md index 707adce308..c69be4f4de 100644 --- a/dev/doc/changes.md +++ b/dev/doc/changes.md @@ -46,9 +46,9 @@ We changed the type of the following functions: - `Global.body_of_constant`: same as above. -We renamed the following datatypes: +We have changed the representation of the following types: -- `Pp.std_ppcmds` -> `Pp.t` +- `Lib.object_prefix` is now a record instead of a nested tuple. Some tactics and related functions now support static configurability, e.g.: diff --git a/dev/tools/backport-pr.sh b/dev/tools/backport-pr.sh new file mode 100755 index 0000000000..bc6ee31916 --- /dev/null +++ b/dev/tools/backport-pr.sh @@ -0,0 +1,60 @@ +#!/usr/bin/env bash + +# Usage: git-backport <PR number> + +set -e + +PRNUM=$1 + +if ! git log master --grep "Merge PR #${PRNUM}" | grep "." > /dev/null; then + echo "PR #${PRNUM} does not exist." + exit 1 +fi + +SIGNATURE_STATUS=$(git log master --grep "Merge PR #${PRNUM}" --format="%G?") +git log master --grep "Merge PR #${PRNUM}" --format="%GG" +if [[ "${SIGNATURE_STATUS}" != "G" ]]; then + echo + read -p "Merge commit does not have a good (valid) signature. Bypass? [y/N] " -n 1 -r + echo + if [[ ! $REPLY =~ ^[Yy]$ ]]; then + exit 1 + fi +fi + +BRANCH=backport-pr-${PRNUM} +RANGE=$(git log master --grep "Merge PR #${PRNUM}" --format="%P" | sed 's/ /../') +MESSAGE=$(git log master --grep "Merge PR #${PRNUM}" --format="%s" | sed 's/Merge/Backport/') + +if git checkout -b ${BRANCH}; then + + if ! git cherry-pick -x ${RANGE}; then + echo "Please fix the conflicts, then exit." + bash + while ! git cherry-pick --continue; do + echo "Please fix the conflicts, then exit." + bash + done + fi + git checkout - + +else + + echo + read -p "Skip directly to merging phase? [y/N] " -n 1 -r + echo + if [[ ! $REPLY =~ ^[Yy]$ ]]; then + exit 1 + fi + +fi + +git merge -S --no-ff ${BRANCH} -m "${MESSAGE}" +git branch -d ${BRANCH} + +# To-Do: +# - Support for backporting a PR before it is merged +# - Automatically backport all PRs in the "Waiting to be backported" column using a command like: +# $ curl -s -H "Authorization: token ${GITHUB_TOKEN}" -H "Accept: application/vnd.github.inertia-preview+json" https://api.github.com/projects/columns/1358120/cards | jq -r '.[].content_url' | grep issue | sed 's/^.*issues\/\([0-9]*\)$/\1/' | tac +# (The ID of the column must first be obtained through https://api.github.com/repos/coq/coq/projects then https://api.github.com/projects/819866/columns.) +# - Then move each of the backported PR to the subsequent columns automatically as well... diff --git a/doc/refman/Classes.tex b/doc/refman/Classes.tex index 22c75b4fc8..cab6739998 100644 --- a/doc/refman/Classes.tex +++ b/doc/refman/Classes.tex @@ -462,11 +462,18 @@ abbreviate a type, like {\tt relation A := A -> A -> Prop}. This is equivalent to {\tt Hint Transparent,Opaque} {\ident} {\tt: typeclass\_instances}. +\subsection{\tt Set Typeclasses Axioms Are Instances} +\optindex{Typeclasses Axioms Are Instances} + +This option (off by default since 8.8) automatically declares axioms +whose type is a typeclass at declaration time as instances of that +class. + \subsection{\tt Set Typeclasses Dependency Order} \optindex{Typeclasses Dependency Order} This option (on by default since 8.6) respects the dependency order between -subgoals, meaning that subgoals which are depended on by other subgoals +subgoals, meaning that subgoals which are depended on by other subgoals come first, while the non-dependent subgoals were put before the dependent ones previously (Coq v8.5 and below). This can result in quite different performance behaviors of proof search. diff --git a/interp/dumpglob.ml b/interp/dumpglob.ml index 13ed65056d..0197cf9ae2 100644 --- a/interp/dumpglob.ml +++ b/interp/dumpglob.ml @@ -72,7 +72,7 @@ open Decl_kinds let type_of_logical_kind = function | IsDefinition def -> (match def with - | Definition -> "def" + | Definition | Let -> "def" | Coercion -> "coe" | SubClass -> "subclass" | CanonicalStructure -> "canonstruc" diff --git a/intf/decl_kinds.ml b/intf/decl_kinds.ml index a977588332..1dea6d9e98 100644 --- a/intf/decl_kinds.ml +++ b/intf/decl_kinds.ml @@ -8,6 +8,8 @@ (** Informal mathematical status of declarations *) +type discharge = DoDischarge | NoDischarge + type locality = Discharge | Local | Global type binding_kind = Explicit | Implicit @@ -40,6 +42,7 @@ type definition_object_kind = | IdentityCoercion | Instance | Method + | Let type assumption_object_kind = Definitional | Logical | Conjectural diff --git a/intf/vernacexpr.ml b/intf/vernacexpr.ml index 96bcba5e8b..5c9141fd6f 100644 --- a/intf/vernacexpr.ml +++ b/intf/vernacexpr.ml @@ -151,10 +151,6 @@ type onlyparsing_flag = Flags.compat_version option If v<>Current, it contains the name of the coq version which this notation is trying to be compatible with *) type locality_flag = bool (* true = Local *) -type obsolete_locality = bool -(* Some grammar entries use obsolete_locality. This bool is to be backward - * compatible. If the grammar is fixed removing deprecated syntax, this - * bool should go away too *) type option_value = Goptions.option_value = | BoolValue of bool @@ -327,31 +323,27 @@ type vernac_expr = | VernacFail of vernac_expr (* Syntax *) - | VernacSyntaxExtension of - bool * obsolete_locality * (lstring * syntax_modifier list) - | VernacOpenCloseScope of obsolete_locality * (bool * scope_name) + | VernacSyntaxExtension of bool * (lstring * syntax_modifier list) + | VernacOpenCloseScope of bool * scope_name | VernacDelimiters of scope_name * string option | VernacBindScope of scope_name * class_rawexpr list - | VernacInfix of obsolete_locality * (lstring * syntax_modifier list) * + | VernacInfix of (lstring * syntax_modifier list) * constr_expr * scope_name option | VernacNotation of - obsolete_locality * constr_expr * (lstring * syntax_modifier list) * + constr_expr * (lstring * syntax_modifier list) * scope_name option | VernacNotationAddFormat of string * string * string (* Gallina *) - | VernacDefinition of - (locality option * definition_object_kind) * ident_decl * definition_expr + | VernacDefinition of (discharge * definition_object_kind) * ident_decl * definition_expr | VernacStartTheoremProof of theorem_kind * proof_expr list | VernacEndProof of proof_end | VernacExactProof of constr_expr - | VernacAssumption of (locality option * assumption_object_kind) * + | VernacAssumption of (discharge * assumption_object_kind) * inline * (ident_decl list * constr_expr) with_coercion list | VernacInductive of cumulative_inductive_parsing_flag * private_flag * inductive_flag * (inductive_expr * decl_notation list) list - | VernacFixpoint of - locality option * (fixpoint_expr * decl_notation list) list - | VernacCoFixpoint of - locality option * (cofixpoint_expr * decl_notation list) list + | VernacFixpoint of discharge * (fixpoint_expr * decl_notation list) list + | VernacCoFixpoint of discharge * (cofixpoint_expr * decl_notation list) list | VernacScheme of (lident option * scheme) list | VernacCombinedScheme of lident * lident list | VernacUniverse of lident list @@ -364,10 +356,9 @@ type vernac_expr = reference option * export_flag option * reference list | VernacImport of export_flag * reference list | VernacCanonical of reference or_by_notation - | VernacCoercion of obsolete_locality * reference or_by_notation * - class_rawexpr * class_rawexpr - | VernacIdentityCoercion of obsolete_locality * lident * + | VernacCoercion of reference or_by_notation * class_rawexpr * class_rawexpr + | VernacIdentityCoercion of lident * class_rawexpr * class_rawexpr | VernacNameSectionHypSet of lident * section_subset_expr (* Type classes *) @@ -418,9 +409,9 @@ type vernac_expr = (* Commands *) | VernacCreateHintDb of string * bool | VernacRemoveHints of string list * reference list - | VernacHints of obsolete_locality * string list * hints_expr + | VernacHints of string list * hints_expr | VernacSyntacticDefinition of Id.t located * (Id.t list * constr_expr) * - obsolete_locality * onlyparsing_flag + onlyparsing_flag | VernacDeclareImplicits of reference or_by_notation * (explicitation * bool * bool) list list | VernacArguments of reference or_by_notation * diff --git a/library/declaremods.ml b/library/declaremods.ml index db83dafef8..41e00a41c6 100644 --- a/library/declaremods.ml +++ b/library/declaremods.ml @@ -180,16 +180,16 @@ let compute_visibility exists i = (** Iterate some function [iter_objects] on all components of a module *) -let do_module exists iter_objects i dir mp sobjs kobjs = - let prefix = (dir,(mp,DirPath.empty)) in +let do_module exists iter_objects i obj_dir obj_mp sobjs kobjs = + let prefix = { obj_dir ; obj_mp; obj_sec = DirPath.empty } in let dirinfo = DirModule prefix in - consistency_checks exists dir dirinfo; - Nametab.push_dir (compute_visibility exists i) dir dirinfo; - ModSubstObjs.set mp sobjs; + consistency_checks exists obj_dir dirinfo; + Nametab.push_dir (compute_visibility exists i) obj_dir dirinfo; + ModSubstObjs.set obj_mp sobjs; (* If we're not a functor, let's iter on the internal components *) if sobjs_no_functor sobjs then begin let objs = expand_sobjs sobjs in - ModObjs.set mp (prefix,objs,kobjs); + ModObjs.set obj_mp (prefix,objs,kobjs); iter_objects (i+1) prefix objs; iter_objects (i+1) prefix kobjs end @@ -222,20 +222,20 @@ let cache_keep _ = anomaly (Pp.str "This module should not be cached!") let load_keep i ((sp,kn),kobjs) = (* Invariant : seg isn't empty *) - let dir = dir_of_sp sp and mp = mp_of_kn kn in - let prefix = (dir,(mp,DirPath.empty)) in + let obj_dir = dir_of_sp sp and obj_mp = mp_of_kn kn in + let prefix = { obj_dir ; obj_mp; obj_sec = DirPath.empty } in let prefix',sobjs,kobjs0 = - try ModObjs.get mp + try ModObjs.get obj_mp with Not_found -> assert false (* a substobjs should already be loaded *) in assert (eq_op prefix' prefix); assert (List.is_empty kobjs0); - ModObjs.set mp (prefix,sobjs,kobjs); + ModObjs.set obj_mp (prefix,sobjs,kobjs); Lib.load_objects i prefix kobjs let open_keep i ((sp,kn),kobjs) = - let dir = dir_of_sp sp and mp = mp_of_kn kn in - let prefix = (dir,(mp,DirPath.empty)) in + let obj_dir = dir_of_sp sp and obj_mp = mp_of_kn kn in + let prefix = { obj_dir; obj_mp; obj_sec = DirPath.empty } in Lib.open_objects i prefix kobjs let in_modkeep : Lib.lib_objects -> obj = @@ -284,9 +284,9 @@ let (in_modtype : substitutive_objects -> obj), (** {6 Declaration of substitutive objects for Include} *) let do_include do_load do_open i ((sp,kn),aobjs) = - let dir = Libnames.dirpath sp in - let mp = KerName.modpath kn in - let prefix = (dir,(mp,DirPath.empty)) in + let obj_dir = Libnames.dirpath sp in + let obj_mp = KerName.modpath kn in + let prefix = { obj_dir; obj_mp; obj_sec = DirPath.empty } in let o = expand_aobjs aobjs in if do_load then Lib.load_objects i prefix o; if do_open then Lib.open_objects i prefix o @@ -577,7 +577,7 @@ let start_module interp_modast export id args res fs = in openmod_info := { cur_typ = res_entry_o; cur_typs = subtyps }; let prefix = Lib.start_module export id mp fs in - Nametab.push_dir (Nametab.Until 1) (fst prefix) (DirOpenModule prefix); + Nametab.push_dir (Nametab.Until 1) (prefix.obj_dir) (DirOpenModule prefix); mp let end_module () = @@ -684,7 +684,7 @@ let start_modtype interp_modast id args mtys fs = let sub_mty_l = build_subtypes interp_modast env mp arg_entries_r mtys in openmodtype_info := sub_mty_l; let prefix = Lib.start_modtype id mp fs in - Nametab.push_dir (Nametab.Until 1) (fst prefix) (DirOpenModtype prefix); + Nametab.push_dir (Nametab.Until 1) (prefix.obj_dir) (DirOpenModtype prefix); mp let end_modtype () = diff --git a/library/kindops.ml b/library/kindops.ml index 882f620862..83985ce974 100644 --- a/library/kindops.ml +++ b/library/kindops.ml @@ -23,45 +23,13 @@ let string_of_theorem_kind = function | Proposition -> "Proposition" | Corollary -> "Corollary" -let string_of_definition_kind def = - let (locality, poly, kind) = def in - let error () = CErrors.anomaly (Pp.str "Internal definition kind.") in - match kind with - | Definition -> - begin match locality with - | Discharge -> "Let" - | Local -> "Local Definition" - | Global -> "Definition" - end - | Example -> - begin match locality with - | Discharge -> error () - | Local -> "Local Example" - | Global -> "Example" - end - | Coercion -> - begin match locality with - | Discharge -> error () - | Local -> "Local Coercion" - | Global -> "Coercion" - end - | SubClass -> - begin match locality with - | Discharge -> error () - | Local -> "Local SubClass" - | Global -> "SubClass" - end - | CanonicalStructure -> - begin match locality with - | Discharge -> error () - | Local -> error () - | Global -> "Canonical Structure" - end - | Instance -> - begin match locality with - | Discharge -> error () - | Local -> "Instance" - | Global -> "Global Instance" - end +let string_of_definition_object_kind = function + | Definition -> "Definition" + | Example -> "Example" + | Coercion -> "Coercion" + | SubClass -> "SubClass" + | CanonicalStructure -> "Canonical Structure" + | Instance -> "Instance" + | Let -> "Let" | (StructureComponent|Scheme|CoFixpoint|Fixpoint|IdentityCoercion|Method) -> CErrors.anomaly (Pp.str "Internal definition kind.") diff --git a/library/kindops.mli b/library/kindops.mli index 77979c9159..06f873e857 100644 --- a/library/kindops.mli +++ b/library/kindops.mli @@ -12,4 +12,4 @@ open Decl_kinds val logical_kind_of_goal_kind : goal_object_kind -> logical_kind val string_of_theorem_kind : theorem_kind -> string -val string_of_definition_kind : definition_kind -> string +val string_of_definition_object_kind : definition_object_kind -> string diff --git a/library/lib.ml b/library/lib.ml index 3dbb16c7b0..499e2ae21f 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -93,12 +93,16 @@ let segment_of_objects prefix = sections, but on the contrary there are many constructions of section paths based on the library path. *) -let initial_prefix = default_library,(Names.ModPath.initial,Names.DirPath.empty) +let initial_prefix = { + obj_dir = default_library; + obj_mp = ModPath.initial; + obj_sec = DirPath.empty; +} type lib_state = { - comp_name : Names.DirPath.t option; + comp_name : DirPath.t option; lib_stk : library_segment; - path_prefix : Names.DirPath.t * (Names.ModPath.t * Names.DirPath.t); + path_prefix : object_prefix; } let initial_lib_state = { @@ -115,10 +119,9 @@ let library_dp () = (* [path_prefix] is a pair of absolute dirpath and a pair of current module path and relative section path *) -let cwd () = fst !lib_state.path_prefix -let current_prefix () = snd !lib_state.path_prefix -let current_mp () = fst (snd !lib_state.path_prefix) -let current_sections () = snd (snd !lib_state.path_prefix) +let cwd () = !lib_state.path_prefix.obj_dir +let current_mp () = !lib_state.path_prefix.obj_mp +let current_sections () = !lib_state.path_prefix.obj_sec let sections_depth () = List.length (Names.DirPath.repr (current_sections ())) let sections_are_opened () = not (Names.DirPath.is_empty (current_sections ())) @@ -136,7 +139,7 @@ let make_path_except_section id = Libnames.make_path (cwd_except_section ()) id let make_kn id = - let mp,dir = current_prefix () in + let mp, dir = current_mp (), current_sections () in Names.KerName.make mp dir (Names.Label.of_id id) let make_oname id = Libnames.make_oname !lib_state.path_prefix id @@ -152,8 +155,11 @@ let recalc_path_prefix () = lib_state := { !lib_state with path_prefix = recalc !lib_state.lib_stk } let pop_path_prefix () = - let dir,(mp,sec) = !lib_state.path_prefix in - lib_state := { !lib_state with path_prefix = pop_dirpath dir, (mp, pop_dirpath sec)} + let op = !lib_state.path_prefix in + lib_state := { !lib_state + with path_prefix = { op with obj_dir = pop_dirpath op.obj_dir; + obj_sec = pop_dirpath op.obj_sec; + } } let find_entry_p p = let rec find = function @@ -226,7 +232,7 @@ let add_anonymous_entry node = add_entry (make_oname (anonymous_id ())) node let add_leaf id obj = - if Names.ModPath.equal (current_mp ()) Names.ModPath.initial then + if ModPath.equal (current_mp ()) ModPath.initial then user_err Pp.(str "No session module started (use -top dir)"); let oname = make_oname id in cache_object (oname,obj); @@ -278,8 +284,8 @@ let current_mod_id () = let start_mod is_type export id mp fs = - let dir = add_dirpath_suffix (cwd ()) id in - let prefix = dir,(mp,Names.DirPath.empty) in + let dir = add_dirpath_suffix (!lib_state.path_prefix.obj_dir) id in + let prefix = { obj_dir = dir; obj_mp = mp; obj_sec = Names.DirPath.empty } in let exists = if is_type then Nametab.exists_cci (make_path id) else Nametab.exists_module dir @@ -328,10 +334,10 @@ let contents_after sp = let (after,_,_) = split_lib sp in after let start_compilation s mp = if !lib_state.comp_name != None then user_err Pp.(str "compilation unit is already started"); - if not (Names.DirPath.is_empty (current_sections ())) then + if not (Names.DirPath.is_empty (!lib_state.path_prefix.obj_sec)) then user_err Pp.(str "some sections are already opened"); - let prefix = s, (mp, Names.DirPath.empty) in - let () = add_anonymous_entry (CompilingLibrary prefix) in + let prefix = Libnames.{ obj_dir = s; obj_mp = mp; obj_sec = DirPath.empty } in + add_anonymous_entry (CompilingLibrary prefix); lib_state := { !lib_state with comp_name = Some s; path_prefix = prefix } @@ -522,15 +528,15 @@ let is_in_section ref = (*************) (* Sections. *) let open_section id = - let olddir,(mp,oldsec) = !lib_state.path_prefix in - let dir = add_dirpath_suffix olddir id in - let prefix = dir, (mp, add_dirpath_suffix oldsec id) in - if Nametab.exists_section dir then + let opp = !lib_state.path_prefix in + let obj_dir = add_dirpath_suffix opp.obj_dir id in + let prefix = { obj_dir; obj_mp = opp.obj_mp; obj_sec = add_dirpath_suffix opp.obj_sec id } in + if Nametab.exists_section obj_dir then user_err ~hdr:"open_section" (Id.print id ++ str " already exists."); let fs = Summary.freeze_summaries ~marshallable:`No in add_entry (make_oname id) (OpenedSection (prefix, fs)); (*Pushed for the lifetime of the section: removed by unfrozing the summary*) - Nametab.push_dir (Nametab.Until 1) dir (DirOpenSection prefix); + Nametab.push_dir (Nametab.Until 1) obj_dir (DirOpenSection prefix); lib_state := { !lib_state with path_prefix = prefix }; add_section () @@ -556,7 +562,7 @@ let close_section () = in let (secdecls,mark,before) = split_lib_at_opening oname in lib_state := { !lib_state with lib_stk = before }; - let full_olddir = fst !lib_state.path_prefix in + let full_olddir = !lib_state.path_prefix.obj_dir in pop_path_prefix (); add_entry oname (ClosedSection (List.rev (mark::secdecls))); let newdecls = List.map discharge_item secdecls in @@ -596,10 +602,10 @@ let init () = (* Misc *) let mp_of_global = function - |VarRef id -> current_mp () - |ConstRef cst -> Names.Constant.modpath cst - |IndRef ind -> Names.ind_modpath ind - |ConstructRef constr -> Names.constr_modpath constr + | VarRef id -> !lib_state.path_prefix.obj_mp + | ConstRef cst -> Names.Constant.modpath cst + | IndRef ind -> Names.ind_modpath ind + | ConstructRef constr -> Names.constr_modpath constr let rec dp_of_mp = function |Names.MPfile dp -> dp diff --git a/library/libnames.ml b/library/libnames.ml index 81878e72f9..a471d83966 100644 --- a/library/libnames.ml +++ b/library/libnames.ml @@ -156,10 +156,15 @@ let qualid_of_dirpath dir = type object_name = full_path * KerName.t -type object_prefix = DirPath.t * (ModPath.t * DirPath.t) +type object_prefix = { + obj_dir : DirPath.t; + obj_mp : ModPath.t; + obj_sec : DirPath.t; +} -let make_oname (dirpath,(mp,dir)) id = - make_path dirpath id, KerName.make mp dir (Label.of_id id) +(* let make_oname (dirpath,(mp,dir)) id = *) +let make_oname { obj_dir; obj_mp; obj_sec } id = + make_path obj_dir id, KerName.make obj_mp obj_sec (Label.of_id id) (* to this type are mapped DirPath.t's in the nametab *) type global_dir_reference = @@ -170,10 +175,10 @@ type global_dir_reference = | DirClosedSection of DirPath.t (* this won't last long I hope! *) -let eq_op (d1, (mp1, p1)) (d2, (mp2, p2)) = - DirPath.equal d1 d2 && - DirPath.equal p1 p2 && - ModPath.equal mp1 mp2 +let eq_op op1 op2 = + DirPath.equal op1.obj_dir op2.obj_dir && + DirPath.equal op1.obj_sec op2.obj_sec && + ModPath.equal op1.obj_mp op2.obj_mp let eq_global_dir_reference r1 r2 = match r1, r2 with | DirOpenModule op1, DirOpenModule op2 -> eq_op op1 op2 diff --git a/library/libnames.mli b/library/libnames.mli index ed01163ee7..71f5422404 100644 --- a/library/libnames.mli +++ b/library/libnames.mli @@ -94,7 +94,25 @@ val qualid_of_ident : Id.t -> qualid type object_name = full_path * KerName.t -type object_prefix = DirPath.t * (ModPath.t * DirPath.t) +(** Object prefix morally contains the "prefix" naming of an object to + be stored by [library], where [obj_dir] is the "absolute" path, + [obj_mp] is the current "module" prefix and [obj_sec] is the + "section" prefix. + + Thus, for an object living inside [Module A. Section B.] the + prefix would be: + + [ { obj_dir = "A.B"; obj_mp = "A"; obj_sec = "B" } ] + + Note that both [obj_dir] and [obj_sec] are "paths" that is to say, + as opposed to [obj_mp] which is a single module name. + + *) +type object_prefix = { + obj_dir : DirPath.t; + obj_mp : ModPath.t; + obj_sec : DirPath.t; +} val eq_op : object_prefix -> object_prefix -> bool diff --git a/library/nametab.ml b/library/nametab.ml index 0ec4a37cdb..222c4cedcb 100644 --- a/library/nametab.ml +++ b/library/nametab.ml @@ -359,8 +359,8 @@ let push_modtype vis sp kn = let push_dir vis dir dir_ref = the_dirtab := DirTab.push vis dir dir_ref !the_dirtab; match dir_ref with - DirModule (_,(mp,_)) -> the_modrevtab := MPmap.add mp dir !the_modrevtab - | _ -> () + | DirModule { obj_mp; _ } -> the_modrevtab := MPmap.add obj_mp dir !the_modrevtab + | _ -> () (* Locate functions *******************************************************) @@ -386,17 +386,17 @@ let locate_dir qid = DirTab.locate qid !the_dirtab let locate_module qid = match locate_dir qid with - | DirModule (_,(mp,_)) -> mp + | DirModule { obj_mp ; _} -> obj_mp | _ -> raise Not_found let full_name_module qid = match locate_dir qid with - | DirModule (dir,_) -> dir + | DirModule { obj_dir ; _} -> obj_dir | _ -> raise Not_found let locate_section qid = match locate_dir qid with - | DirOpenSection (dir, _) + | DirOpenSection { obj_dir; _ } -> obj_dir | DirClosedSection dir -> dir | _ -> raise Not_found diff --git a/parsing/egramcoq.ml b/parsing/egramcoq.ml index 2cb7da5694..9c2766187e 100644 --- a/parsing/egramcoq.ml +++ b/parsing/egramcoq.ml @@ -35,7 +35,7 @@ let default_levels = 100,Extend.RightA,false; 99,Extend.RightA,true; 90,Extend.RightA,true; - 10,Extend.RightA,false; + 10,Extend.LeftA,false; 9,Extend.RightA,false; 8,Extend.RightA,true; 1,Extend.LeftA,false; @@ -46,8 +46,7 @@ let default_pattern_levels = 100,Extend.RightA,false; 99,Extend.RightA,true; 90,Extend.RightA,true; - 11,Extend.LeftA,false; - 10,Extend.RightA,false; + 10,Extend.LeftA,false; 1,Extend.LeftA,false; 0,Extend.RightA,false] diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4 index 844c040fdf..7e5933cea2 100644 --- a/parsing/g_constr.ml4 +++ b/parsing/g_constr.ml4 @@ -377,11 +377,10 @@ GEXTEND Gram [ p = pattern; "|"; pl = LIST1 pattern SEP "|" -> CAst.make ~loc:!@loc @@ CPatOr (p::pl) ] | "99" RIGHTA [ ] | "90" RIGHTA [ ] - | "11" LEFTA + | "10" LEFTA [ p = pattern; "as"; id = ident -> - CAst.make ~loc:!@loc @@ CPatAlias (p, id) ] - | "10" RIGHTA - [ p = pattern; lp = LIST1 NEXT -> + CAst.make ~loc:!@loc @@ CPatAlias (p, id) + | p = pattern; lp = LIST1 NEXT -> (let open CAst in match p with | { v = CPatAtom (Some r) } -> CAst.make ~loc:!@loc @@ CPatCstr (r, None, lp) | { v = CPatCstr (r, None, l2); loc } -> @@ -392,7 +391,7 @@ GEXTEND Gram | _ -> CErrors.user_err ?loc:(cases_pattern_expr_loc p) ~hdr:"compound_pattern" (Pp.str "Such pattern cannot have arguments.")) - |"@"; r = Prim.reference; lp = LIST0 NEXT -> + | "@"; r = Prim.reference; lp = LIST0 NEXT -> CAst.make ~loc:!@loc @@ CPatCstr (r, Some lp, []) ] | "1" LEFTA [ c = pattern; "%"; key=IDENT -> CAst.make ~loc:!@loc @@ CPatDelimiters (key,c) ] diff --git a/parsing/g_proofs.ml4 b/parsing/g_proofs.ml4 index f10d746770..d88f6fa0dc 100644 --- a/parsing/g_proofs.ml4 +++ b/parsing/g_proofs.ml4 @@ -70,19 +70,16 @@ GEXTEND Gram VernacCreateHintDb (id, b) | IDENT "Remove"; IDENT "Hints"; ids = LIST1 global; dbnames = opt_hintbases -> VernacRemoveHints (dbnames, ids) - | IDENT "Hint"; local = obsolete_locality; h = hint; + | IDENT "Hint"; h = hint; dbnames = opt_hintbases -> - VernacHints (local,dbnames, h) + VernacHints (dbnames, h) (* Declare "Resolve" explicitly so as to be able to later extend with "Resolve ->" and "Resolve <-" *) | IDENT "Hint"; IDENT "Resolve"; lc = LIST1 reference_or_constr; info = hint_info; dbnames = opt_hintbases -> - VernacHints (false,dbnames, + VernacHints (dbnames, HintsResolve (List.map (fun x -> (info, true, x)) lc)) ] ]; - obsolete_locality: - [ [ IDENT "Local" -> true | -> false ] ] - ; reference_or_constr: [ [ r = global -> HintsReference r | c = constr -> HintsConstr c ] ] diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index 0e585cff77..444f36833b 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -149,7 +149,7 @@ GEXTEND Gram | d = def_token; id = ident_decl; b = def_body -> VernacDefinition (d, id, b) | IDENT "Let"; id = identref; b = def_body -> - VernacDefinition ((Some Discharge, Definition), (id, None), b) + VernacDefinition ((DoDischarge, Let), (id, None), b) (* Gallina inductive declarations *) | cum = cumulativity_token; priv = private_token; f = finite_token; indl = LIST1 inductive_definition SEP "with" -> @@ -167,13 +167,13 @@ GEXTEND Gram in VernacInductive (cum, priv,f,indl) | "Fixpoint"; recs = LIST1 rec_definition SEP "with" -> - VernacFixpoint (None, recs) + VernacFixpoint (NoDischarge, recs) | IDENT "Let"; "Fixpoint"; recs = LIST1 rec_definition SEP "with" -> - VernacFixpoint (Some Discharge, recs) + VernacFixpoint (DoDischarge, recs) | "CoFixpoint"; corecs = LIST1 corec_definition SEP "with" -> - VernacCoFixpoint (None, corecs) + VernacCoFixpoint (NoDischarge, corecs) | IDENT "Let"; "CoFixpoint"; corecs = LIST1 corec_definition SEP "with" -> - VernacCoFixpoint (Some Discharge, corecs) + VernacCoFixpoint (DoDischarge, corecs) | IDENT "Scheme"; l = LIST1 scheme SEP "with" -> VernacScheme l | IDENT "Combined"; IDENT "Scheme"; id = identref; IDENT "from"; l = LIST1 identref SEP "," -> VernacCombinedScheme (id, l) @@ -195,23 +195,23 @@ GEXTEND Gram | IDENT "Property" -> Property ] ] ; def_token: - [ [ "Definition" -> (None, Definition) - | IDENT "Example" -> (None, Example) - | IDENT "SubClass" -> (None, SubClass) ] ] + [ [ "Definition" -> (NoDischarge,Definition) + | IDENT "Example" -> (NoDischarge,Example) + | IDENT "SubClass" -> (NoDischarge,SubClass) ] ] ; assumption_token: - [ [ "Hypothesis" -> (Some Discharge, Logical) - | "Variable" -> (Some Discharge, Definitional) - | "Axiom" -> (None, Logical) - | "Parameter" -> (None, Definitional) - | IDENT "Conjecture" -> (None, Conjectural) ] ] + [ [ "Hypothesis" -> (DoDischarge, Logical) + | "Variable" -> (DoDischarge, Definitional) + | "Axiom" -> (NoDischarge, Logical) + | "Parameter" -> (NoDischarge, Definitional) + | IDENT "Conjecture" -> (NoDischarge, Conjectural) ] ] ; assumptions_token: - [ [ IDENT "Hypotheses" -> ("Hypotheses", (Some Discharge, Logical)) - | IDENT "Variables" -> ("Variables", (Some Discharge, Definitional)) - | IDENT "Axioms" -> ("Axioms", (None, Logical)) - | IDENT "Parameters" -> ("Parameters", (None, Definitional)) - | IDENT "Conjectures" -> ("Conjectures", (None, Conjectural)) ] ] + [ [ IDENT "Hypotheses" -> ("Hypotheses", (DoDischarge, Logical)) + | IDENT "Variables" -> ("Variables", (DoDischarge, Definitional)) + | IDENT "Axioms" -> ("Axioms", (NoDischarge, Logical)) + | IDENT "Parameters" -> ("Parameters", (NoDischarge, Definitional)) + | IDENT "Conjectures" -> ("Conjectures", (NoDischarge, Conjectural)) ] ] ; inline: [ [ IDENT "Inline"; "("; i = INT; ")" -> InlineAt (int_of_string i) @@ -620,34 +620,22 @@ GEXTEND Gram | IDENT "Canonical"; IDENT "Structure"; qid = global; d = def_body -> let s = coerce_reference_to_id qid in - VernacDefinition - ((Some Global,CanonicalStructure),((Loc.tag s),None),d) + VernacLocal(false, + VernacDefinition ((NoDischarge,CanonicalStructure),((Loc.tag s),None),d)) (* Coercions *) | IDENT "Coercion"; qid = global; d = def_body -> let s = coerce_reference_to_id qid in - VernacDefinition ((None,Coercion),((Loc.tag s),None),d) - | IDENT "Coercion"; IDENT "Local"; qid = global; d = def_body -> - let s = coerce_reference_to_id qid in - VernacDefinition ((Some Decl_kinds.Local,Coercion),((Loc.tag s),None),d) - | IDENT "Identity"; IDENT "Coercion"; IDENT "Local"; f = identref; - ":"; s = class_rawexpr; ">->"; t = class_rawexpr -> - VernacIdentityCoercion (true, f, s, t) + VernacDefinition ((NoDischarge,Coercion),((Loc.tag s),None),d) | IDENT "Identity"; IDENT "Coercion"; f = identref; ":"; s = class_rawexpr; ">->"; t = class_rawexpr -> - VernacIdentityCoercion (false, f, s, t) - | IDENT "Coercion"; IDENT "Local"; qid = global; ":"; - s = class_rawexpr; ">->"; t = class_rawexpr -> - VernacCoercion (true, AN qid, s, t) - | IDENT "Coercion"; IDENT "Local"; ntn = by_notation; ":"; - s = class_rawexpr; ">->"; t = class_rawexpr -> - VernacCoercion (true, ByNotation ntn, s, t) + VernacIdentityCoercion (f, s, t) | IDENT "Coercion"; qid = global; ":"; s = class_rawexpr; ">->"; t = class_rawexpr -> - VernacCoercion (false, AN qid, s, t) + VernacCoercion (AN qid, s, t) | IDENT "Coercion"; ntn = by_notation; ":"; s = class_rawexpr; ">->"; t = class_rawexpr -> - VernacCoercion (false, ByNotation ntn, s, t) + VernacCoercion (ByNotation ntn, s, t) | IDENT "Context"; c = binders -> VernacContext c @@ -1106,11 +1094,11 @@ GEXTEND Gram GLOBAL: syntax; syntax: - [ [ IDENT "Open"; local = obsolete_locality; IDENT "Scope"; sc = IDENT -> - VernacOpenCloseScope (local,(true,sc)) + [ [ IDENT "Open"; IDENT "Scope"; sc = IDENT -> + VernacOpenCloseScope (true,sc) - | IDENT "Close"; local = obsolete_locality; IDENT "Scope"; sc = IDENT -> - VernacOpenCloseScope (local,(false,sc)) + | IDENT "Close"; IDENT "Scope"; sc = IDENT -> + VernacOpenCloseScope (false,sc) | IDENT "Delimit"; IDENT "Scope"; sc = IDENT; "with"; key = IDENT -> VernacDelimiters (sc, Some key) @@ -1120,32 +1108,31 @@ GEXTEND Gram | IDENT "Bind"; IDENT "Scope"; sc = IDENT; "with"; refl = LIST1 class_rawexpr -> VernacBindScope (sc,refl) - | IDENT "Infix"; local = obsolete_locality; - op = ne_lstring; ":="; p = constr; + | IDENT "Infix"; op = ne_lstring; ":="; p = constr; modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ]; sc = OPT [ ":"; sc = IDENT -> sc ] -> - VernacInfix (local,(op,modl),p,sc) - | IDENT "Notation"; local = obsolete_locality; id = identref; + VernacInfix ((op,modl),p,sc) + | IDENT "Notation"; id = identref; idl = LIST0 ident; ":="; c = constr; b = only_parsing -> VernacSyntacticDefinition - (id,(idl,c),local,b) - | IDENT "Notation"; local = obsolete_locality; s = lstring; ":="; + (id,(idl,c),b) + | IDENT "Notation"; s = lstring; ":="; c = constr; modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ]; sc = OPT [ ":"; sc = IDENT -> sc ] -> - VernacNotation (local,c,(s,modl),sc) + VernacNotation (c,(s,modl),sc) | IDENT "Format"; IDENT "Notation"; n = STRING; s = STRING; fmt = STRING -> VernacNotationAddFormat (n,s,fmt) | IDENT "Reserved"; IDENT "Infix"; s = ne_lstring; l = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ] -> let (loc,s) = s in - VernacSyntaxExtension (true, false,((loc,"x '"^s^"' y"),l)) + VernacSyntaxExtension (true,((loc,"x '"^s^"' y"),l)) - | IDENT "Reserved"; IDENT "Notation"; local = obsolete_locality; + | IDENT "Reserved"; IDENT "Notation"; s = ne_lstring; l = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ] - -> VernacSyntaxExtension (false, local,(s,l)) + -> VernacSyntaxExtension (false, (s,l)) (* "Print" "Grammar" should be here but is in "command" entry in order to factorize with other "Print"-based vernac entries *) @@ -1158,9 +1145,6 @@ GEXTEND Gram Some (parse_compat_version s) | -> None ] ] ; - obsolete_locality: - [ [ IDENT "Local" -> true | -> false ] ] - ; level: [ [ IDENT "level"; n = natural -> NumLevel n | IDENT "next"; IDENT "level" -> NextLevel ] ] diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4 index 829556a71e..87609296bc 100644 --- a/plugins/funind/g_indfun.ml4 +++ b/plugins/funind/g_indfun.ml4 @@ -154,7 +154,7 @@ VERNAC COMMAND EXTEND Function | _,((_,(_,CStructRec),_,_,_),_) -> false) recsl in match Vernac_classifier.classify_vernac - (Vernacexpr.VernacFixpoint(None, List.map snd recsl)) + (Vernacexpr.VernacFixpoint(Decl_kinds.NoDischarge, List.map snd recsl)) with | Vernacexpr.VtSideff ids, _ when hard -> Vernacexpr.(VtStartProof ("Classic", GuaranteesOpacity, ids), VtLater) diff --git a/plugins/ssr/ssrvernac.ml4 b/plugins/ssr/ssrvernac.ml4 index 7385ed84c7..3efb7b9147 100644 --- a/plugins/ssr/ssrvernac.ml4 +++ b/plugins/ssr/ssrvernac.ml4 @@ -551,9 +551,9 @@ GEXTEND Gram | IDENT "Canonical"; qid = Constr.global; d = G_vernac.def_body -> let s = coerce_reference_to_id qid in - Vernacexpr.VernacDefinition - ((Some Decl_kinds.Global,Decl_kinds.CanonicalStructure), - ((Loc.tag s),None),(d )) + Vernacexpr.VernacLocal(false,Vernacexpr.VernacDefinition + ((Decl_kinds.NoDischarge,Decl_kinds.CanonicalStructure), + ((Loc.tag s),None),(d ))) ]]; END diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index 5dd6879d39..f8f086fad3 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -166,23 +166,6 @@ let retype ?(polyprop=true) sigma = | Lambda _ | Fix _ | Construct _ -> retype_error NotAType | _ -> decomp_sort env sigma (type_of env t) - and sort_family_of env t = - match EConstr.kind sigma t with - | Cast (c,_, s) when isSort sigma s -> Sorts.family (destSort sigma s) - | Sort _ -> InType - | Prod (name,t,c2) -> - let s2 = sort_family_of (push_rel (LocalAssum (name,t)) env) c2 in - if not (is_impredicative_set env) && - s2 == InSet && sort_family_of env t == InType then InType else s2 - | App(f,args) when is_template_polymorphic env sigma f -> - let t = type_of_global_reference_knowing_parameters env f args in - Sorts.family (sort_of_atomic_type env sigma t args) - | App(f,args) -> - Sorts.family (sort_of_atomic_type env sigma (type_of env f) args) - | Lambda _ | Fix _ | Construct _ -> retype_error NotAType - | _ -> - Sorts.family (decomp_sort env sigma (type_of env t)) - and type_of_global_reference_knowing_parameters env c args = let argtyps = Array.map (fun c -> lazy (EConstr.to_constr sigma (type_of env c))) args in @@ -198,15 +181,34 @@ let retype ?(polyprop=true) sigma = EConstr.of_constr (type_of_constructor env (cstr, u)) | _ -> assert false - in type_of, sort_of, sort_family_of, - type_of_global_reference_knowing_parameters + in type_of, sort_of, type_of_global_reference_knowing_parameters + +let get_sort_family_of ?(truncation_style=false) ?(polyprop=true) env sigma t = + let type_of,_,type_of_global_reference_knowing_parameters = retype ~polyprop sigma in + let rec sort_family_of env t = + match EConstr.kind sigma t with + | Cast (c,_, s) when isSort sigma s -> Sorts.family (destSort sigma s) + | Sort _ -> InType + | Prod (name,t,c2) -> + let s2 = sort_family_of (push_rel (LocalAssum (name,t)) env) c2 in + if not (is_impredicative_set env) && + s2 == InSet && sort_family_of env t == InType then InType else s2 + | App(f,args) when is_template_polymorphic env sigma f -> + if truncation_style then InType else + let t = type_of_global_reference_knowing_parameters env f args in + Sorts.family (sort_of_atomic_type env sigma t args) + | App(f,args) -> + Sorts.family (sort_of_atomic_type env sigma (type_of env f) args) + | Lambda _ | Fix _ | Construct _ -> retype_error NotAType + | Ind _ when truncation_style && is_template_polymorphic env sigma t -> InType + | _ -> + Sorts.family (decomp_sort env sigma (type_of env t)) + in sort_family_of env t let get_sort_of ?(polyprop=true) env sigma t = - let _,f,_,_ = retype ~polyprop sigma in anomaly_on_error (f env) t -let get_sort_family_of ?(polyprop=true) env sigma c = - let _,_,f,_ = retype ~polyprop sigma in anomaly_on_error (f env) c + let _,f,_ = retype ~polyprop sigma in anomaly_on_error (f env) t let type_of_global_reference_knowing_parameters env sigma c args = - let _,_,_,f = retype sigma in anomaly_on_error (f env c) args + let _,_,f = retype sigma in anomaly_on_error (f env c) args let type_of_global_reference_knowing_conclusion env sigma c conclty = match EConstr.kind sigma c with @@ -232,7 +234,7 @@ let type_of_global_reference_knowing_conclusion env sigma c conclty = (* get_type_of polyprop lax env sigma c *) let get_type_of ?(polyprop=true) ?(lax=false) env sigma c = - let f,_,_,_ = retype ~polyprop sigma in + let f,_,_ = retype ~polyprop sigma in if lax then f env c else anomaly_on_error (f env) c (* Makes an unsafe judgment from a constr *) diff --git a/pretyping/retyping.mli b/pretyping/retyping.mli index af86df499c..6fdde90463 100644 --- a/pretyping/retyping.mli +++ b/pretyping/retyping.mli @@ -31,8 +31,11 @@ val get_type_of : val get_sort_of : ?polyprop:bool -> env -> evar_map -> types -> Sorts.t +(* When [truncation_style] is [true], tells if the type has been explicitly + truncated to Prop or (impredicative) Set; in particular, singleton type and + small inductive types, which have all eliminations to Type, are in Type *) val get_sort_family_of : - ?polyprop:bool -> env -> evar_map -> types -> Sorts.family + ?truncation_style:bool -> ?polyprop:bool -> env -> evar_map -> types -> Sorts.family (** Makes an unsafe judgment from a constr *) val get_judgment_of : env -> evar_map -> constr -> unsafe_judgment diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml index 1a74538aa2..46ef2ac031 100644 --- a/printing/ppvernac.ml +++ b/printing/ppvernac.ml @@ -324,23 +324,18 @@ open Decl_kinds | SortClass -> keyword "Sortclass" | RefClass qid -> pr_smart_global qid - let pr_assumption_token many (l,a) = - let l = match l with Some x -> x | None -> Decl_kinds.Global in - match l, a with - | (Discharge,Logical) -> - keyword (if many then "Hypotheses" else "Hypothesis") - | (Discharge,Definitional) -> - keyword (if many then "Variables" else "Variable") - | (Global,Logical) -> + let pr_assumption_token many discharge kind = + match discharge, kind with + | (NoDischarge,Logical) -> keyword (if many then "Axioms" else "Axiom") - | (Global,Definitional) -> + | (NoDischarge,Definitional) -> keyword (if many then "Parameters" else "Parameter") - | (Local, Logical) -> - keyword (if many then "Local Axioms" else "Local Axiom") - | (Local,Definitional) -> - keyword (if many then "Local Parameters" else "Local Parameter") - | (Global,Conjectural) -> str"Conjecture" - | ((Discharge | Local),Conjectural) -> + | (NoDischarge,Conjectural) -> str"Conjecture" + | (DoDischarge,Logical) -> + keyword (if many then "Hypotheses" else "Hypothesis") + | (DoDischarge,Definitional) -> + keyword (if many then "Variables" else "Variable") + | (DoDischarge,Conjectural) -> anomaly (Pp.str "Don't know how to beautify a local conjecture.") let pr_params pr_c (xl,(c,t)) = @@ -631,7 +626,7 @@ open Decl_kinds return (keyword "Fail" ++ spc() ++ pr_vernac_body v) (* Syntax *) - | VernacOpenCloseScope (_,(opening,sc)) -> + | VernacOpenCloseScope (opening,sc) -> return ( keyword (if opening then "Open " else "Close ") ++ keyword "Scope" ++ spc() ++ str sc @@ -660,7 +655,7 @@ open Decl_kinds ++ spc() ++ pr_smart_global q ++ spc() ++ str"[" ++ prlist_with_sep sep pr_opt_scope scl ++ str"]" ) - | VernacInfix (_,((_,s),mv),q,sn) -> (* A Verifier *) + | VernacInfix (((_,s),mv),q,sn) -> (* A Verifier *) return ( hov 0 (hov 0 (keyword "Infix " ++ qs s ++ str " :=" ++ pr_constrarg q) ++ @@ -669,7 +664,7 @@ open Decl_kinds | None -> mt() | Some sc -> spc() ++ str":" ++ spc() ++ str sc)) ) - | VernacNotation (_,c,((_,s),l),opt) -> + | VernacNotation (c,((_,s),l),opt) -> return ( hov 2 (keyword "Notation" ++ spc() ++ qs s ++ str " :=" ++ Flags.without_option Flags.beautify pr_constrarg c ++ pr_syntax_modifiers l ++ @@ -677,7 +672,7 @@ open Decl_kinds | None -> mt() | Some sc -> str" :" ++ spc() ++ str sc)) ) - | VernacSyntaxExtension (_, _,(s,l)) -> + | VernacSyntaxExtension (_, (s, l)) -> return ( keyword "Reserved Notation" ++ spc() ++ pr_located qs s ++ pr_syntax_modifiers l @@ -688,10 +683,9 @@ open Decl_kinds ) (* Gallina *) - | VernacDefinition (d,id,b) -> (* A verifier... *) - let pr_def_token (l,dk) = - let l = match l with Some x -> x | None -> Decl_kinds.Global in - keyword (Kindops.string_of_definition_kind (l,false,dk)) + | VernacDefinition ((discharge,kind),id,b) -> (* A verifier... *) + let pr_def_token dk = + keyword (Kindops.string_of_definition_object_kind dk) in let pr_reduce = function | None -> mt() @@ -712,7 +706,7 @@ open Decl_kinds let (binds,typ,c) = pr_def_body b in return ( hov 2 ( - pr_def_token d ++ spc() + pr_def_token kind ++ spc() ++ pr_ident_decl id ++ binds ++ typ ++ (match c with | None -> mt() @@ -737,13 +731,13 @@ open Decl_kinds ) | VernacExactProof c -> return (hov 2 (keyword "Proof" ++ pr_lconstrarg c)) - | VernacAssumption (stre,t,l) -> + | VernacAssumption ((discharge,kind),t,l) -> let n = List.length (List.flatten (List.map fst (List.map snd l))) in let pr_params (c, (xl, t)) = hov 2 (prlist_with_sep sep pr_ident_decl xl ++ spc() ++ (if c then str":>" else str":" ++ spc() ++ pr_lconstr_expr t)) in let assumptions = prlist_with_sep spc (fun p -> hov 1 (str "(" ++ pr_params p ++ str ")")) l in - return (hov 2 (pr_assumption_token (n > 1) stre ++ + return (hov 2 (pr_assumption_token (n > 1) discharge kind ++ pr_non_empty_arg pr_assumption_inline t ++ spc() ++ assumptions)) | VernacInductive (cum, p,f,l) -> let pr_constructor (coe,(id,c)) = @@ -793,9 +787,8 @@ open Decl_kinds | VernacFixpoint (local, recs) -> let local = match local with - | Some Discharge -> "Let " - | Some Local -> "Local " - | None | Some Global -> "" + | DoDischarge -> "Let " + | NoDischarge -> "" in return ( hov 0 (str local ++ keyword "Fixpoint" ++ spc () ++ @@ -805,9 +798,8 @@ open Decl_kinds | VernacCoFixpoint (local, corecs) -> let local = match local with - | Some Discharge -> keyword "Let" ++ spc () - | Some Local -> keyword "Local" ++ spc () - | None | Some Global -> str "" + | DoDischarge -> keyword "Let" ++ spc () + | NoDischarge -> str "" in let pr_onecorec ((iddecl,bl,c,def),ntn) = pr_ident_decl iddecl ++ spc() ++ pr_binders bl ++ spc() ++ str":" ++ @@ -868,14 +860,14 @@ open Decl_kinds return ( keyword "Canonical Structure" ++ spc() ++ pr_smart_global q ) - | VernacCoercion (_,id,c1,c2) -> + | VernacCoercion (id,c1,c2) -> return ( hov 1 ( keyword "Coercion" ++ spc() ++ pr_smart_global id ++ spc() ++ str":" ++ spc() ++ pr_class_rawexpr c1 ++ spc() ++ str">->" ++ spc() ++ pr_class_rawexpr c2) ) - | VernacIdentityCoercion (_,id,c1,c2) -> + | VernacIdentityCoercion (id,c1,c2) -> return ( hov 1 ( keyword "Identity Coercion" ++ spc() ++ pr_lident id ++ @@ -999,9 +991,9 @@ open Decl_kinds prlist_with_sep spc (fun r -> pr_id (coerce_reference_to_id r)) ids ++ pr_opt_hintbases dbnames) ) - | VernacHints (_, dbnames,h) -> + | VernacHints (dbnames,h) -> return (pr_hints dbnames h pr_constr pr_constr_pattern_expr) - | VernacSyntacticDefinition (id,(ids,c),_,compat) -> + | VernacSyntacticDefinition (id,(ids,c),compat) -> return ( hov 2 (keyword "Notation" ++ spc () ++ pr_lident id ++ spc () ++ diff --git a/printing/prettyp.ml b/printing/prettyp.ml index 602b7a4965..1eb2c31c88 100644 --- a/printing/prettyp.ml +++ b/printing/prettyp.ml @@ -360,10 +360,10 @@ let pr_located_qualid = function str "Notation" ++ spc () ++ pr_path (Nametab.path_of_syndef kn) | Dir dir -> let s,dir = match dir with - | DirOpenModule (dir,_) -> "Open Module", dir - | DirOpenModtype (dir,_) -> "Open Module Type", dir - | DirOpenSection (dir,_) -> "Open Section", dir - | DirModule (dir,_) -> "Module", dir + | DirOpenModule { obj_dir ; _ } -> "Open Module", obj_dir + | DirOpenModtype { obj_dir ; _ } -> "Open Module Type", obj_dir + | DirOpenSection { obj_dir ; _ } -> "Open Section", obj_dir + | DirModule { obj_dir ; _ } -> "Module", obj_dir | DirClosedSection dir -> "Closed Section", dir in str s ++ spc () ++ DirPath.print dir @@ -410,7 +410,7 @@ let locate_term qid = let locate_module qid = let all = Nametab.locate_extended_all_dir qid in let map dir = match dir with - | DirModule (_, (mp, _)) -> Some (Dir dir, Nametab.shortest_qualid_of_module mp) + | DirModule { obj_mp ; _ } -> Some (Dir dir, Nametab.shortest_qualid_of_module obj_mp) | DirOpenModule _ -> Some (Dir dir, qid) | _ -> None in @@ -649,8 +649,8 @@ let gallina_print_library_entry env sigma with_values ent = Some (str " >>>>>>> Section " ++ pr_name oname) | (oname,Lib.ClosedSection _) -> Some (str " >>>>>>> Closed Section " ++ pr_name oname) - | (_,Lib.CompilingLibrary (dir,_)) -> - Some (str " >>>>>>> Library " ++ DirPath.print dir) + | (_,Lib.CompilingLibrary { obj_dir; _ }) -> + Some (str " >>>>>>> Library " ++ DirPath.print obj_dir) | (oname,Lib.OpenedModule _) -> Some (str " >>>>>>> Module " ++ pr_name oname) | (oname,Lib.ClosedModule _) -> @@ -779,8 +779,8 @@ let read_sec_context r = with Not_found -> user_err ?loc ~hdr:"read_sec_context" (str "Unknown section.") in let rec get_cxt in_cxt = function - | (_,Lib.OpenedSection ((dir',_),_) as hd)::rest -> - if DirPath.equal dir dir' then (hd::in_cxt) else get_cxt (hd::in_cxt) rest + | (_,Lib.OpenedSection ({obj_dir;_},_) as hd)::rest -> + if DirPath.equal dir obj_dir then (hd::in_cxt) else get_cxt (hd::in_cxt) rest | (_,Lib.ClosedSection _)::rest -> user_err Pp.(str "Cannot print the contents of a closed section.") (* LEM: Actually, we could if we wanted to. *) @@ -811,7 +811,7 @@ let print_any_name env sigma na udecl = | Term (ConstructRef ((sp,_),_)) -> print_inductive sp udecl | Term (VarRef sp) -> print_section_variable env sigma sp | Syntactic kn -> print_syntactic_def env kn - | Dir (DirModule(dirpath,(mp,_))) -> print_module (printable_body dirpath) mp + | Dir (DirModule { obj_dir; obj_mp; _ } ) -> print_module (printable_body obj_dir) obj_mp | Dir _ -> mt () | ModuleType mp -> print_modtype mp | Other (obj, info) -> info.print obj diff --git a/printing/printer.mli b/printing/printer.mli index 9e8622c6e5..36ca1bdcca 100644 --- a/printing/printer.mli +++ b/printing/printer.mli @@ -186,8 +186,8 @@ val pr_subgoals : ?pr_first:bool -> Pp.t option -> evar_map -> Evar.t val pr_subgoal : int -> evar_map -> goal list -> Pp.t val pr_concl : int -> evar_map -> goal -> Pp.t -val pr_open_subgoals : proof:Proof.proof -> Pp.t -val pr_nth_open_subgoal : proof:Proof.proof -> int -> Pp.t +val pr_open_subgoals : proof:Proof.t -> Pp.t +val pr_nth_open_subgoal : proof:Proof.t -> int -> Pp.t val pr_evar : evar_map -> (Evar.t * evar_info) -> Pp.t val pr_evars_int : evar_map -> int -> evar_info Evar.Map.t -> Pp.t val pr_evars : evar_map -> evar_info Evar.Map.t -> Pp.t @@ -220,7 +220,7 @@ module ContextObjectMap : CMap.ExtS val pr_assumptionset : env -> types ContextObjectMap.t -> Pp.t -val pr_goal_by_id : proof:Proof.proof -> Id.t -> Pp.t +val pr_goal_by_id : proof:Proof.t -> Id.t -> Pp.t type printer_pr = { pr_subgoals : ?pr_first:bool -> Pp.t option -> evar_map -> Evar.t list -> Goal.goal list -> int list -> goal list -> goal list -> Pp.t; diff --git a/printing/printmod.ml b/printing/printmod.ml index c34543bbda..05292b06ba 100644 --- a/printing/printmod.ml +++ b/printing/printmod.ml @@ -245,10 +245,10 @@ let print_kn locals kn = with Not_found -> print_modpath locals kn -let nametab_register_dir mp = +let nametab_register_dir obj_mp = let id = mk_fake_top () in - let dir = DirPath.make [id] in - Nametab.push_dir (Nametab.Until 1) dir (DirModule (dir,(mp,DirPath.empty))) + let obj_dir = DirPath.make [id] in + Nametab.push_dir (Nametab.Until 1) obj_dir (DirModule { obj_dir; obj_mp; obj_sec = DirPath.empty }) (** Nota: the [global_reference] we register in the nametab below might differ from internal ones, since we cannot recreate here diff --git a/proofs/goal.mli b/proofs/goal.mli index ad968cdfb3..37dd9d3c0c 100644 --- a/proofs/goal.mli +++ b/proofs/goal.mli @@ -58,7 +58,7 @@ module V82 : sig (* Principal part of the progress tactical *) val progress : goal list Evd.sigma -> goal Evd.sigma -> bool - + (* Principal part of tclNOTSAMEGOAL *) val same_goal : Evd.evar_map -> goal -> Evd.evar_map -> goal -> bool diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli index d676a0874b..2acb678d7f 100644 --- a/proofs/pfedit.mli +++ b/proofs/pfedit.mli @@ -74,7 +74,7 @@ val current_proof_statement : val solve : ?with_end_tac:unit Proofview.tactic -> Vernacexpr.goal_selector -> int option -> unit Proofview.tactic -> - Proof.proof -> Proof.proof*bool + Proof.t -> Proof.t * bool (** [by tac] applies tactic [tac] to the 1st subgoal of the current focused proof or raises a UserError if there is no focused proof or diff --git a/proofs/proof.ml b/proofs/proof.ml index 413b5fdd7e..04e707cd66 100644 --- a/proofs/proof.ml +++ b/proofs/proof.ml @@ -98,7 +98,7 @@ let done_cond ?(loose_end=false) k = CondDone (loose_end,k) (* Subpart of the type of proofs. It contains the parts of the proof which are under control of the undo mechanism *) -type proof = { +type t = { (* Current focused proofview *) proofview: Proofview.proofview; (* Entry for the proofview *) @@ -115,6 +115,8 @@ type proof = { initial_euctx : UState.t } +type proof = t + (*** General proof functions ***) let proof p = diff --git a/proofs/proof.mli b/proofs/proof.mli index 83777fc966..0b5e771ef3 100644 --- a/proofs/proof.mli +++ b/proofs/proof.mli @@ -30,7 +30,9 @@ *) (* Type of a proof. *) -type proof +type t +type proof = t +[@@ocaml.deprecated "please use [Proof.t]"] (* Returns a stylised view of a proof for use by, for instance, ide-s. *) @@ -42,7 +44,7 @@ type proof shelf (the list of goals on the shelf), a representation of the given up goals (the list of the given up goals) and the underlying evar_map *) -val proof : proof -> +val proof : t -> Goal.goal list * (Goal.goal list * Goal.goal list) list * Goal.goal list @@ -61,26 +63,26 @@ type 'a pre_goals = { (** List of the goals that have been given up *) } -val map_structured_proof : proof -> (Evd.evar_map -> Goal.goal -> 'a) -> ('a pre_goals) +val map_structured_proof : t -> (Evd.evar_map -> Goal.goal -> 'a) -> ('a pre_goals) (*** General proof functions ***) -val start : Evd.evar_map -> (Environ.env * EConstr.types) list -> proof -val dependent_start : Proofview.telescope -> proof -val initial_goals : proof -> (EConstr.constr * EConstr.types) list -val initial_euctx : proof -> UState.t +val start : Evd.evar_map -> (Environ.env * EConstr.types) list -> t +val dependent_start : Proofview.telescope -> t +val initial_goals : t -> (EConstr.constr * EConstr.types) list +val initial_euctx : t -> UState.t (* Returns [true] if the considered proof is completed, that is if no goal remain to be considered (this does not require that all evars have been solved). *) -val is_done : proof -> bool +val is_done : t -> bool (* Like is_done, but this time it really means done (i.e. nothing left to do) *) -val is_complete : proof -> bool +val is_complete : t -> bool (* Returns the list of partial proofs to initial goals. *) -val partial_proof : proof -> EConstr.constr list +val partial_proof : t -> EConstr.constr list -val compact : proof -> proof +val compact : t -> t (* Returns the proofs (with their type) of the initial goals. Raises [UnfinishedProof] is some goals remain to be considered. @@ -91,7 +93,7 @@ exception UnfinishedProof exception HasShelvedGoals exception HasGivenUpGoals exception HasUnresolvedEvar -val return : proof -> Evd.evar_map +val return : t -> Evd.evar_map (*** Focusing actions ***) @@ -131,7 +133,7 @@ val done_cond : ?loose_end:bool -> 'a focus_kind -> 'a focus_condition (* focus command (focuses on the [i]th subgoal) *) (* spiwack: there could also, easily be a focus-on-a-range tactic, is there a need for it? *) -val focus : 'a focus_condition -> 'a -> int -> proof -> proof +val focus : 'a focus_condition -> 'a -> int -> t -> t exception FullyUnfocused exception CannotUnfocusThisWay @@ -147,59 +149,59 @@ exception NoSuchGoals of int * int Raises [FullyUnfocused] if the proof is not focused. Raises [CannotUnfocusThisWay] if the proof the unfocusing condition is not met. *) -val unfocus : 'a focus_kind -> proof -> unit -> proof +val unfocus : 'a focus_kind -> t -> unit -> t (* [unfocused p] returns [true] when [p] is fully unfocused. *) -val unfocused : proof -> bool +val unfocused : t -> bool (* [get_at_focus k] gets the information stored at the closest focus point of kind [k]. Raises [NoSuchFocus] if there is no focus point of kind [k]. *) exception NoSuchFocus -val get_at_focus : 'a focus_kind -> proof -> 'a +val get_at_focus : 'a focus_kind -> t -> 'a (* [is_last_focus k] check if the most recent focus is of kind [k] *) -val is_last_focus : 'a focus_kind -> proof -> bool +val is_last_focus : 'a focus_kind -> t -> bool (* returns [true] if there is no goal under focus. *) -val no_focused_goal : proof -> bool +val no_focused_goal : t -> bool (*** Tactics ***) (* the returned boolean signal whether an unsafe tactic has been used. In which case it is [false]. *) val run_tactic : Environ.env -> - unit Proofview.tactic -> proof -> proof*(bool*Proofview_monad.Info.tree) + unit Proofview.tactic -> t -> t * (bool*Proofview_monad.Info.tree) -val maximal_unfocus : 'a focus_kind -> proof -> proof +val maximal_unfocus : 'a focus_kind -> t -> t (*** Commands ***) -val in_proof : proof -> (Evd.evar_map -> 'a) -> 'a +val in_proof : t -> (Evd.evar_map -> 'a) -> 'a (* Remove all the goals from the shelf and adds them at the end of the focused goals. *) -val unshelve : proof -> proof +val unshelve : t -> t -val pr_proof : proof -> Pp.t +val pr_proof : t -> Pp.t (*** Compatibility layer with <=v8.2 ***) module V82 : sig - val subgoals : proof -> Goal.goal list Evd.sigma + val subgoals : t -> Goal.goal list Evd.sigma [@@ocaml.deprecated "Use the first and fifth argument of [Proof.proof]"] (* All the subgoals of the proof, including those which are not focused. *) - val background_subgoals : proof -> Goal.goal list Evd.sigma + val background_subgoals : t -> Goal.goal list Evd.sigma - val top_goal : proof -> Goal.goal Evd.sigma + val top_goal : t -> Goal.goal Evd.sigma (* returns the existential variable used to start the proof *) - val top_evars : proof -> Evar.t list + val top_evars : t -> Evar.t list (* Turns the unresolved evars into goals. Raises [UnfinishedProof] if there are still unsolved goals. *) - val grab_evars : proof -> proof + val grab_evars : t -> t (* Implements the Existential command *) - val instantiate_evar : int -> Constrexpr.constr_expr -> proof -> proof + val instantiate_evar : int -> Constrexpr.constr_expr -> t -> t end diff --git a/proofs/proof_bullet.ml b/proofs/proof_bullet.ml index 4f575ab4be..2149163314 100644 --- a/proofs/proof_bullet.ml +++ b/proofs/proof_bullet.ml @@ -25,8 +25,8 @@ let pr_bullet b = type behavior = { name : string; - put : proof -> t -> proof; - suggest: proof -> Pp.t + put : Proof.t -> t -> Proof.t; + suggest: Proof.t -> Pp.t } let behaviors = Hashtbl.create 4 @@ -110,7 +110,7 @@ module Strict = struct let push (b:t) pr = focus bullet_cond (b::get_bullets pr) 1 pr - let suggest_bullet (prf : proof): suggestion = + let suggest_bullet (prf : Proof.t): suggestion = if is_done prf then ProofFinished else if not (no_focused_goal prf) then (* No suggestion if a bullet is not mandatory, look for an unfinished bullet *) @@ -137,7 +137,7 @@ module Strict = struct in loop prf - let rec pop_until (prf : proof) bul : proof = + let rec pop_until (prf : Proof.t) bul : Proof.t = let prf', b = pop prf in if bullet_eq bul b then prf' else pop_until prf' bul diff --git a/proofs/proof_bullet.mli b/proofs/proof_bullet.mli index 9e924fec97..09fcabf50a 100644 --- a/proofs/proof_bullet.mli +++ b/proofs/proof_bullet.mli @@ -12,8 +12,6 @@ (* *) (**********************************************************) -open Proof - type t = Vernacexpr.bullet (** A [behavior] is the data of a put function which @@ -22,8 +20,8 @@ type t = Vernacexpr.bullet with a name to identify the behavior. *) type behavior = { name : string; - put : proof -> t -> proof; - suggest: proof -> Pp.t + put : Proof.t -> t -> Proof.t; + suggest: Proof.t -> Pp.t } (** A registered behavior can then be accessed in Coq @@ -39,8 +37,8 @@ val register_behavior : behavior -> unit (** Handles focusing/defocusing with bullets: *) -val put : proof -> t -> proof -val suggest : proof -> Pp.t +val put : Proof.t -> t -> Proof.t +val suggest : Proof.t -> Pp.t (**********************************************************) (* *) diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index aa5621770c..c1e1c2edad 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -90,12 +90,15 @@ type pstate = { terminator : proof_terminator CEphemeron.key; endline_tactic : Genarg.glob_generic_argument option; section_vars : Context.Named.t option; - proof : Proof.proof; + proof : Proof.t; strength : Decl_kinds.goal_kind; mode : proof_mode CEphemeron.key; universe_decl: Univdecls.universe_decl; } +type t = pstate list +type state = t + let make_terminator f = f let apply_terminator f = f @@ -467,8 +470,6 @@ module V82 = struct pid, (goals, strength) end -type state = pstate list - let freeze ~marshallable = match marshallable with | `Yes -> diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli index eed62f912e..059459042b 100644 --- a/proofs/proof_global.mli +++ b/proofs/proof_global.mli @@ -10,6 +10,10 @@ toplevel. In particular it defines the global proof environment. *) +type t +type state = t +[@@ocaml.deprecated "please use [Proof_global.t]"] + val there_are_pending_proofs : unit -> bool val check_no_pending_proof : unit -> unit @@ -21,7 +25,7 @@ val discard_current : unit -> unit val discard_all : unit -> unit exception NoCurrentProof -val give_me_the_proof : unit -> Proof.proof +val give_me_the_proof : unit -> Proof.t (** @raise NoCurrentProof when outside proof mode. *) val compact_the_proof : unit -> unit @@ -107,9 +111,9 @@ val get_open_goals : unit -> int no current proof. The return boolean is set to [false] if an unsafe tactic has been used. *) val with_current_proof : - (unit Proofview.tactic -> Proof.proof -> Proof.proof*'a) -> 'a + (unit Proofview.tactic -> Proof.t -> Proof.t * 'a) -> 'a val simple_with_current_proof : - (unit Proofview.tactic -> Proof.proof -> Proof.proof) -> unit + (unit Proofview.tactic -> Proof.t -> Proof.t) -> unit (** Sets the tactic to be used when a tactic line is closed with [...] *) val set_endline_tactic : Genarg.glob_generic_argument -> unit @@ -129,11 +133,10 @@ module V82 : sig Decl_kinds.goal_kind) end -type state -val freeze : marshallable:[`Yes | `No | `Shallow] -> state -val unfreeze : state -> unit -val proof_of_state : state -> Proof.proof -val copy_terminators : src:state -> tgt:state -> state +val freeze : marshallable:[`Yes | `No | `Shallow] -> t +val unfreeze : t -> unit +val proof_of_state : t -> Proof.t +val copy_terminators : src:t -> tgt:t -> t (**********************************************************) diff --git a/stm/stm.ml b/stm/stm.ml index 0ee9ea0841..8aa832da84 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -762,7 +762,7 @@ end = struct (* {{{ *) let fix_exn_ref = ref (fun x -> x) type proof_part = - Proof_global.state * Summary.frozen_bits (* only meta counters *) + Proof_global.t * Summary.frozen_bits (* only meta counters *) type partial_state = [ `Full of Vernacstate.t @@ -1023,7 +1023,7 @@ let stm_vernac_interp ?proof ?route id st { verbose; loc; expr } : Vernacstate.t | VernacShow ShowScript -> ShowScript.show_script (); st | expr -> stm_pperr_endline Pp.(fun () -> str "interpreting " ++ Ppvernac.pr_vernac expr); - try Vernacentries.interp ?verbosely:(Some verbose) ?proof st (Loc.tag ?loc expr) + try Vernacentries.interp ?verbosely:(Some verbose) ?proof ~st (Loc.tag ?loc expr) with e -> let e = CErrors.push e in Exninfo.iraise Hooks.(call_process_error_once e) diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index 3aa2cd707e..1ca572a36c 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -103,8 +103,7 @@ let rec classify_vernac e = | VernacUnsetOption (["Default";"Proof";"Using"]) | VernacSetOption (["Default";"Proof";"Using"],_) -> VtSideff [], VtNow (* StartProof *) - | VernacDefinition ( - (Some Decl_kinds.Discharge,Decl_kinds.Definition),((_,i),_),ProveBody _) -> + | VernacDefinition ((Decl_kinds.DoDischarge,_),((_,i),_),ProveBody _) -> VtStartProof(default_proof_mode (),Doesn'tGuaranteeOpacity,[i]), VtLater | VernacDefinition (_,((_,i),_),ProveBody _) -> VtStartProof(default_proof_mode (),GuaranteesOpacity,[i]), VtLater @@ -113,19 +112,29 @@ let rec classify_vernac e = CList.map_filter (function (Some ((_,i),pl), _) -> Some i | _ -> None) l in VtStartProof (default_proof_mode (),GuaranteesOpacity,ids), VtLater | VernacGoal _ -> VtStartProof (default_proof_mode (),GuaranteesOpacity,[]), VtLater - | VernacFixpoint (_,l) -> + | VernacFixpoint (discharge,l) -> + let guarantee = + match discharge with + | Decl_kinds.NoDischarge -> GuaranteesOpacity + | Decl_kinds.DoDischarge -> Doesn'tGuaranteeOpacity + in let ids, open_proof = List.fold_left (fun (l,b) ((((_,id),_),_,_,_,p),_) -> id::l, b || p = None) ([],false) l in if open_proof - then VtStartProof (default_proof_mode (),GuaranteesOpacity,ids), VtLater + then VtStartProof (default_proof_mode (),guarantee,ids), VtLater else VtSideff ids, VtLater - | VernacCoFixpoint (_,l) -> + | VernacCoFixpoint (discharge,l) -> + let guarantee = + match discharge with + | Decl_kinds.NoDischarge -> GuaranteesOpacity + | Decl_kinds.DoDischarge -> Doesn'tGuaranteeOpacity + in let ids, open_proof = List.fold_left (fun (l,b) ((((_,id),_),_,_,p),_) -> id::l, b || p = None) ([],false) l in if open_proof - then VtStartProof (default_proof_mode (),GuaranteesOpacity,ids), VtLater + then VtStartProof (default_proof_mode (),guarantee,ids), VtLater else VtSideff ids, VtLater (* Sideff: apply to all open branches. usually run on master only *) | VernacAssumption (_,_,l) -> diff --git a/tactics/equality.ml b/tactics/equality.ml index c36ad980ef..0d6263246e 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -739,7 +739,7 @@ let keep_proof_equalities = function let find_positions env sigma ~keep_proofs ~no_discr t1 t2 = let project env sorts posn t1 t2 = let ty1 = get_type_of env sigma t1 in - let s = get_sort_family_of env sigma ty1 in + let s = get_sort_family_of ~truncation_style:true env sigma ty1 in if Sorts.List.mem s sorts then [(List.rev posn,t1,t2)] else [] in diff --git a/test-suite/bugs/closed/3125.v b/test-suite/bugs/closed/3125.v new file mode 100644 index 0000000000..797146174d --- /dev/null +++ b/test-suite/bugs/closed/3125.v @@ -0,0 +1,27 @@ +(* Not considering singleton template-polymorphic inductive types as + propositions for injection/inversion *) + +(* This is also #4560 and #6273 *) + +Inductive foo := foo_1. + +Goal forall (a b : foo), Some a = Some b -> a = b. +Proof. + intros a b H. + inversion H. + reflexivity. +Qed. + +(* Check that Prop is not concerned *) + +Inductive bar : Prop := bar_1. + +Goal + forall (a b : bar), + Some a = Some b -> + a = b. +Proof. + intros a b H. + inversion H. + Fail reflexivity. +Abort. diff --git a/test-suite/bugs/closed/3559.v b/test-suite/bugs/closed/3559.v index da12b68689..5210b27032 100644 --- a/test-suite/bugs/closed/3559.v +++ b/test-suite/bugs/closed/3559.v @@ -65,6 +65,7 @@ Axiom path_iff_hprop_uncurried : forall `{IsHProp A, IsHProp B}, (A <-> B) -> A = B. Inductive V : Type@{U'} := | set {A : Type@{U}} (f : A -> V) : V. Axiom is0trunc_V : IsTrunc (trunc_S (trunc_S minus_two)) V. +Existing Instance is0trunc_V. Axiom bisimulation : V@{U' U} -> V@{U' U} -> hProp@{U'}. Axiom bisimulation_refl : forall (v : V), bisimulation v v. Axiom bisimulation_eq : forall (u v : V), bisimulation u v -> u = v. diff --git a/test-suite/bugs/closed/HoTT_coq_064.v b/test-suite/bugs/closed/HoTT_coq_064.v index b4c745375f..d02a5f120c 100644 --- a/test-suite/bugs/closed/HoTT_coq_064.v +++ b/test-suite/bugs/closed/HoTT_coq_064.v @@ -178,6 +178,7 @@ Definition IsColimit `{Funext} C D (F : Functor D C) Generalizable All Variables. Axiom fs : Funext. +Existing Instance fs. Section bar. diff --git a/test-suite/success/Notations.v b/test-suite/success/Notations.v index e3f90f6d94..3c0ad20700 100644 --- a/test-suite/success/Notations.v +++ b/test-suite/success/Notations.v @@ -147,3 +147,9 @@ Inductive EQ {A} (x:A) : A -> Prop := REFL : x === x Fail Check {x@{u},y|x=x}. Fail Check {?[n],y|0=0}. + +(* Check that 10 is well declared left associative *) + +Section C. +Notation "f $$$ x" := (id f x) (at level 10, left associativity). +End C. diff --git a/test-suite/success/Typeclasses.v b/test-suite/success/Typeclasses.v index 6b1f0315bc..cd6eac35cf 100644 --- a/test-suite/success/Typeclasses.v +++ b/test-suite/success/Typeclasses.v @@ -240,3 +240,20 @@ Module IterativeDeepening. Qed. End IterativeDeepening. + +Module AxiomsAreInstances. + Set Typeclasses Axioms Are Instances. + Class TestClass1 := {}. + Axiom testax1 : TestClass1. + Definition testdef1 : TestClass1 := _. + + Unset Typeclasses Axioms Are Instances. + Class TestClass2 := {}. + Axiom testax2 : TestClass2. + Fail Definition testdef2 : TestClass2 := _. + + (* we didn't break typeclasses *) + Existing Instance testax2. + Definition testdef2 : TestClass2 := _. + +End AxiomsAreInstances. diff --git a/test-suite/success/bteauto.v b/test-suite/success/bteauto.v index 3178c6fc15..730b367d60 100644 --- a/test-suite/success/bteauto.v +++ b/test-suite/success/bteauto.v @@ -55,6 +55,7 @@ Module Backtracking. Axiom A : Type. Existing Class A. Axioms a b c d e: A. + Existing Instances a b c d e. Ltac get_value H := eval cbv delta [H] in H. diff --git a/theories/Compat/Coq87.v b/theories/Compat/Coq87.v index ef1737bf85..aeef9595d3 100644 --- a/theories/Compat/Coq87.v +++ b/theories/Compat/Coq87.v @@ -15,3 +15,6 @@ and breaks at least fiat-crypto. *) Declare ML Module "omega_plugin". Unset Omega UseLocalDefs. + + +Set Typeclasses Axioms Are Instances. diff --git a/vernac/command.ml b/vernac/command.ml index 373e5a1be2..01c7f149bc 100644 --- a/vernac/command.ml +++ b/vernac/command.ml @@ -174,6 +174,24 @@ let do_definition ident k univdecl bl red_option c ctypopt hook = (* 2| Variable/Hypothesis/Parameter/Axiom declarations *) +let axiom_into_instance = ref false + +let _ = + let open Goptions in + declare_bool_option + { optdepr = false; + optname = "automatically declare axioms whose type is a typeclass as instances"; + optkey = ["Typeclasses";"Axioms";"Are";"Instances"]; + optread = (fun _ -> !axiom_into_instance); + optwrite = (:=) axiom_into_instance; } + +let should_axiom_into_instance = function + | Discharge -> + (* The typeclass behaviour of Variable and Context doesn't depend + on section status *) + true + | Global | Local -> !axiom_into_instance + let declare_assumption is_coe (local,p,kind) (c,ctx) pl imps impl nl (_,ident) = match local with | Discharge when Lib.sections_are_opened () -> @@ -195,6 +213,7 @@ match local with (r,Univ.Instance.empty,true) | Global | Local | Discharge -> + let do_instance = should_axiom_into_instance local in let local = DeclareDef.get_locality ident ~kind:"axiom" local in let inl = match nl with | NoInline -> None @@ -207,7 +226,7 @@ match local with let () = maybe_declare_manual_implicits false gr imps in let () = Universes.register_universe_binders gr pl in let () = assumption_message ident in - let () = Typeclasses.declare_instance None false gr in + let () = if do_instance then Typeclasses.declare_instance None false gr in let () = if is_coe then Class.try_add_new_coercion gr ~local p in let inst = match ctx with | Polymorphic_const_entry ctx -> Univ.UContext.instance ctx diff --git a/vernac/lemmas.mli b/vernac/lemmas.mli index 1b1304db5b..a4854b4a6b 100644 --- a/vernac/lemmas.mli +++ b/vernac/lemmas.mli @@ -56,7 +56,7 @@ val standard_proof_terminator : (** {6 ... } *) (** A hook the next three functions pass to cook_proof *) -val set_save_hook : (Proof.proof -> unit) -> unit +val set_save_hook : (Proof.t -> unit) -> unit val save_proof : ?proof:Proof_global.closed_proof -> Vernacexpr.proof_end -> unit diff --git a/vernac/locality.ml b/vernac/locality.ml index 681b1ab207..87b4116252 100644 --- a/vernac/locality.ml +++ b/vernac/locality.ml @@ -6,36 +6,14 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Decl_kinds + (** * Managing locality *) let local_of_bool = function - | true -> Decl_kinds.Local - | false -> Decl_kinds.Global - -(** Extracting the locality flag *) - -(* Commands which supported an inlined Local flag *) - -let warn_deprecated_local_syntax = - CWarnings.create ~name:"deprecated-local-syntax" ~category:"deprecated" - (fun () -> - Pp.strbrk "Deprecated syntax: use \"Local\" as a prefix.") - -let enforce_locality_full locality_flag local = - let local = - match locality_flag with - | Some false when local -> - CErrors.user_err Pp.(str "Cannot be simultaneously Local and Global.") - | Some true when local -> - CErrors.user_err Pp.(str "Use only prefix \"Local\".") - | None -> - if local then begin - warn_deprecated_local_syntax (); - Some true - end else - None - | Some b -> Some b in - local + | true -> Local + | false -> Global + (** Positioning locality for commands supporting discharging and export outside of modules *) @@ -48,15 +26,16 @@ let make_non_locality = function Some false -> false | _ -> true let make_locality = function Some true -> true | _ -> false -let enforce_locality locality_flag local = - make_locality (enforce_locality_full locality_flag local) +let enforce_locality_exp locality_flag discharge = + match locality_flag, discharge with + | Some b, NoDischarge -> local_of_bool b + | None, NoDischarge -> Global + | None, DoDischarge -> Discharge + | Some true, DoDischarge -> CErrors.user_err Pp.(str "Local not allowed in this case") + | Some false, DoDischarge -> CErrors.user_err Pp.(str "Global not allowed in this case") -let enforce_locality_exp locality_flag local = - match locality_flag, local with - | None, Some local -> local - | Some b, None -> local_of_bool b - | None, None -> Decl_kinds.Global - | Some _, Some _ -> CErrors.user_err Pp.(str "Local non allowed in this case") +let enforce_locality locality_flag = + make_locality locality_flag (* For commands whose default is to not discharge but to export: Global in sections forces discharge, Global not in section is the default; @@ -65,8 +44,8 @@ let enforce_locality_exp locality_flag local = let make_section_locality = function Some b -> b | None -> Lib.sections_are_opened () -let enforce_section_locality locality_flag local = - make_section_locality (enforce_locality_full locality_flag local) +let enforce_section_locality locality_flag = + make_section_locality locality_flag (** Positioning locality for commands supporting export but not discharge *) @@ -83,5 +62,5 @@ let make_module_locality = function | Some true -> true | None -> false -let enforce_module_locality locality_flag local = - make_module_locality (enforce_locality_full locality_flag local) +let enforce_module_locality locality_flag = + make_module_locality locality_flag diff --git a/vernac/locality.mli b/vernac/locality.mli index bef66d8bc5..922538b233 100644 --- a/vernac/locality.mli +++ b/vernac/locality.mli @@ -8,10 +8,6 @@ (** * Managing locality *) -(** Commands which supported an inlined Local flag *) - -val enforce_locality_full : bool option -> bool -> bool option - (** * Positioning locality for commands supporting discharging and export outside of modules *) @@ -22,16 +18,15 @@ val enforce_locality_full : bool option -> bool -> bool option val make_locality : bool option -> bool val make_non_locality : bool option -> bool -val enforce_locality : bool option -> bool -> bool -val enforce_locality_exp : - bool option -> Decl_kinds.locality option -> Decl_kinds.locality +val enforce_locality_exp : bool option -> Decl_kinds.discharge -> Decl_kinds.locality +val enforce_locality : bool option -> bool (** For commands whose default is to not discharge but to export: Global in sections forces discharge, Global not in section is the default; Local in sections is the default, Local not in section forces non-export *) val make_section_locality : bool option -> bool -val enforce_section_locality : bool option -> bool -> bool +val enforce_section_locality : bool option -> bool (** * Positioning locality for commands supporting export but not discharge *) @@ -40,4 +35,4 @@ val enforce_section_locality : bool option -> bool -> bool Local in sections is the default, Local not in section forces non-export *) val make_module_locality : bool option -> bool -val enforce_module_locality : bool option -> bool -> bool +val enforce_module_locality : bool option -> bool diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 2f278ceb16..f8ec05fdbf 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -29,6 +29,7 @@ open Redexpr open Lemmas open Misctypes open Locality +open Vernacinterp module NamedDecl = Context.Named.Declaration @@ -185,8 +186,8 @@ let print_module r = try let globdir = Nametab.locate_dir qid in match globdir with - DirModule (dirpath,(mp,_)) -> - Feedback.msg_notice (Printmod.print_module (Printmod.printable_body dirpath) mp) + DirModule { obj_dir; obj_mp; _ } -> + Feedback.msg_notice (Printmod.print_module (Printmod.printable_body obj_dir) obj_mp) | _ -> raise Not_found with Not_found -> Feedback.msg_error (str"Unknown Module " ++ pr_qualid qid) @@ -408,8 +409,8 @@ let dump_global r = (**********) (* Syntax *) -let vernac_syntax_extension locality local infix l = - let local = enforce_module_locality locality local in +let vernac_syntax_extension atts infix l = + let local = enforce_module_locality atts.locality in if infix then Metasyntax.check_infix_modifiers (snd l); Metasyntax.add_syntax_extension local l @@ -420,20 +421,20 @@ let vernac_delimiters sc = function let vernac_bind_scope sc cll = Metasyntax.add_class_scope sc (List.map scope_class_of_qualid cll) -let vernac_open_close_scope locality local (b,s) = - let local = enforce_section_locality locality local in +let vernac_open_close_scope ~atts (b,s) = + let local = enforce_section_locality atts.locality in Notation.open_close_scope (local,b,s) -let vernac_arguments_scope locality r scl = - let local = make_section_locality locality in +let vernac_arguments_scope ~atts r scl = + let local = make_section_locality atts.locality in Notation.declare_arguments_scope local (smart_global r) scl -let vernac_infix locality local = - let local = enforce_module_locality locality local in +let vernac_infix ~atts = + let local = enforce_module_locality atts.locality in Metasyntax.add_infix local (Global.env()) -let vernac_notation locality local = - let local = enforce_module_locality locality local in +let vernac_notation ~atts = + let local = enforce_module_locality atts.locality in Metasyntax.add_notation local (Global.env()) (***********) @@ -471,33 +472,33 @@ let vernac_definition_hook p = function | SubClass -> Class.add_subclass_hook p | _ -> no_hook -let vernac_definition locality p (local,k) ((loc,id as lid),pl) def = - let local = enforce_locality_exp locality local in - let hook = vernac_definition_hook p k in +let vernac_definition ~atts discharge kind ((loc,id as lid),pl) def = + let local = enforce_locality_exp atts.locality discharge in + let hook = vernac_definition_hook atts.polymorphic kind in let () = match local with | Discharge -> Dumpglob.dump_definition lid true "var" | Local | Global -> Dumpglob.dump_definition lid false "def" in (match def with | ProveBody (bl,t) -> (* local binders, typ *) - start_proof_and_print (local,p,DefinitionBody k) + start_proof_and_print (local, atts.polymorphic, DefinitionBody kind) [Some (lid,pl), (bl,t)] hook | DefineBody (bl,red_option,c,typ_opt) -> - let red_option = match red_option with + let red_option = match red_option with | None -> None | Some r -> - let sigma, env= Pfedit.get_current_context () in + let sigma, env = Pfedit.get_current_context () in Some (snd (Hook.get f_interp_redexp env sigma r)) in - do_definition id (local,p,k) pl bl red_option c typ_opt hook) + do_definition id (local, atts.polymorphic, kind) pl bl red_option c typ_opt hook) -let vernac_start_proof locality p kind l = - let local = enforce_locality_exp locality None in +let vernac_start_proof ~atts kind l = + let local = enforce_locality_exp atts.locality NoDischarge in if Dumpglob.dump () then List.iter (fun (id, _) -> match id with | Some (lid,_) -> Dumpglob.dump_definition lid false "prf" | None -> ()) l; - start_proof_and_print (local, p, Proof kind) l no_hook + start_proof_and_print (local, atts.polymorphic, Proof kind) l no_hook let vernac_end_proof ?proof = function | Admitted -> save_proof ?proof Admitted @@ -510,10 +511,10 @@ let vernac_exact_proof c = save_proof (Vernacexpr.(Proved(Opaque,None))); if not status then Feedback.feedback Feedback.AddedAxiom -let vernac_assumption locality poly (local, kind) l nl = - let local = enforce_locality_exp locality local in +let vernac_assumption ~atts discharge kind l nl = + let local = enforce_locality_exp atts.locality discharge in let global = local == Global in - let kind = local, poly, kind in + let kind = local, atts.polymorphic, kind in List.iter (fun (is_coe,(idl,c)) -> if Dumpglob.dump () then List.iter (fun (lid, _) -> @@ -553,8 +554,8 @@ let vernac_record cum k poly finite struc binders sort nameopt cfs = then the type is declared private (as per the [Private] keyword). [finite] indicates whether the type is inductive, co-inductive or neither. *) -let vernac_inductive cum poly lo finite indl = - let is_cumulative = should_treat_as_cumulative cum poly in +let vernac_inductive ~atts cum lo finite indl = + let is_cumulative = should_treat_as_cumulative cum atts.polymorphic in if Dumpglob.dump () then List.iter (fun (((coe,(lid,_)), _, _, _, cstrs), _) -> match cstrs with @@ -571,13 +572,13 @@ let vernac_inductive cum poly lo finite indl = user_err Pp.(str "The Variant keyword does not support syntax { ... }.") | [ ( id , bl , c , b, RecordDecl (oc,fs) ), [] ] -> vernac_record cum (match b with Class _ -> Class false | _ -> b) - poly finite id bl c oc fs + atts.polymorphic finite id bl c oc fs | [ ( id , bl , c , Class _, Constructors [l]), [] ] -> let f = let (coe, ((loc, id), ce)) = l in let coe' = if coe then Some true else None in (((coe', AssumExpr ((loc, Name id), ce)), None), []) - in vernac_record cum (Class true) poly finite id bl c None [f] + in vernac_record cum (Class true) atts.polymorphic finite id bl c None [f] | [ ( _ , _, _, Class _, Constructors _), [] ] -> user_err Pp.(str "Inductive classes not supported") | [ ( id , bl , c , Class _, _), _ :: _ ] -> @@ -591,19 +592,19 @@ let vernac_inductive cum poly lo finite indl = | _ -> user_err Pp.(str "Cannot handle mutually (co)inductive records.") in let indl = List.map unpack indl in - do_mutual_inductive indl is_cumulative poly lo finite + do_mutual_inductive indl is_cumulative atts.polymorphic lo finite -let vernac_fixpoint locality poly local l = - let local = enforce_locality_exp locality local in +let vernac_fixpoint ~atts discharge l = + let local = enforce_locality_exp atts.locality discharge in if Dumpglob.dump () then List.iter (fun (((lid,_), _, _, _, _), _) -> Dumpglob.dump_definition lid false "def") l; - do_fixpoint local poly l + do_fixpoint local atts.polymorphic l -let vernac_cofixpoint locality poly local l = - let local = enforce_locality_exp locality local in +let vernac_cofixpoint ~atts discharge l = + let local = enforce_locality_exp atts.locality discharge in if Dumpglob.dump () then List.iter (fun (((lid,_), _, _, _), _) -> Dumpglob.dump_definition lid false "def") l; - do_cofixpoint local poly l + do_cofixpoint local atts.polymorphic l let vernac_scheme l = if Dumpglob.dump () then @@ -621,19 +622,19 @@ let vernac_combined_scheme lid l = List.iter (fun lid -> dump_global (Misctypes.AN (Ident lid))) l); Indschemes.do_combined_scheme lid l -let vernac_universe loc poly l = - if poly && not (Lib.sections_are_opened ()) then - user_err ?loc ~hdr:"vernac_universe" +let vernac_universe ~atts l = + if atts.polymorphic && not (Lib.sections_are_opened ()) then + user_err ?loc:atts.loc ~hdr:"vernac_universe" (str"Polymorphic universes can only be declared inside sections, " ++ str "use Monomorphic Universe instead"); - do_universe poly l + do_universe atts.polymorphic l -let vernac_constraint loc poly l = - if poly && not (Lib.sections_are_opened ()) then - user_err ?loc ~hdr:"vernac_constraint" +let vernac_constraint ~atts l = + if atts.polymorphic && not (Lib.sections_are_opened ()) then + user_err ?loc:atts.loc ~hdr:"vernac_constraint" (str"Polymorphic universe constraints can only be declared" ++ str " inside sections, use Monomorphic Constraint instead"); - do_constraint poly l + do_constraint atts.polymorphic l (**********************) (* Modules *) @@ -811,32 +812,32 @@ let vernac_require from import qidl = let vernac_canonical r = Recordops.declare_canonical_structure (smart_global r) -let vernac_coercion locality poly local ref qids qidt = - let local = enforce_locality locality local in +let vernac_coercion ~atts ref qids qidt = + let local = enforce_locality atts.locality in let target = cl_of_qualid qidt in let source = cl_of_qualid qids in let ref' = smart_global ref in - Class.try_add_new_coercion_with_target ref' ~local poly ~source ~target; + Class.try_add_new_coercion_with_target ref' ~local atts.polymorphic ~source ~target; Flags.if_verbose Feedback.msg_info (pr_global ref' ++ str " is now a coercion") -let vernac_identity_coercion locality poly local id qids qidt = - let local = enforce_locality locality local in +let vernac_identity_coercion ~atts id qids qidt = + let local = enforce_locality atts.locality in let target = cl_of_qualid qidt in let source = cl_of_qualid qids in - Class.try_add_new_identity_coercion id ~local poly ~source ~target + Class.try_add_new_identity_coercion id ~local atts.polymorphic ~source ~target (* Type classes *) -let vernac_instance abst locality poly sup inst props pri = - let global = not (make_section_locality locality) in +let vernac_instance ~atts abst sup inst props pri = + let global = not (make_section_locality atts.locality) in Dumpglob.dump_constraint inst false "inst"; - ignore(Classes.new_instance ~abstract:abst ~global poly sup inst props pri) + ignore(Classes.new_instance ~abstract:abst ~global atts.polymorphic sup inst props pri) -let vernac_context poly l = - if not (Classes.context poly l) then Feedback.feedback Feedback.AddedAxiom +let vernac_context ~atts l = + if not (Classes.context atts.polymorphic l) then Feedback.feedback Feedback.AddedAxiom -let vernac_declare_instances locality insts = - let glob = not (make_section_locality locality) in +let vernac_declare_instances ~atts insts = + let glob = not (make_section_locality atts.locality) in List.iter (fun (id, info) -> Classes.existing_instance glob id (Some info)) insts let vernac_declare_class id = @@ -904,8 +905,8 @@ let vernac_remove_loadpath path = let vernac_add_ml_path isrec path = (if isrec then Mltop.add_rec_ml_dir else Mltop.add_ml_dir) (expand path) -let vernac_declare_ml_module locality l = - let local = make_locality locality in +let vernac_declare_ml_module ~atts l = + let local = make_locality atts.locality in Mltop.declare_ml_modules local (List.map expand l) let vernac_chdir = function @@ -938,25 +939,25 @@ let vernac_restore_state file = (************) (* Commands *) -let vernac_create_hintdb locality id b = - let local = make_module_locality locality in +let vernac_create_hintdb ~atts id b = + let local = make_module_locality atts.locality in Hints.create_hint_db local id full_transparent_state b -let vernac_remove_hints locality dbs ids = - let local = make_module_locality locality in +let vernac_remove_hints ~atts dbs ids = + let local = make_module_locality atts.locality in Hints.remove_hints local dbs (List.map Smartlocate.global_with_alias ids) -let vernac_hints locality poly local lb h = - let local = enforce_module_locality locality local in - Hints.add_hints local lb (Hints.interp_hints poly h) +let vernac_hints ~atts lb h = + let local = enforce_module_locality atts.locality in + Hints.add_hints local lb (Hints.interp_hints atts.polymorphic h) -let vernac_syntactic_definition locality lid x local y = +let vernac_syntactic_definition ~atts lid x y = Dumpglob.dump_definition lid false "syndef"; - let local = enforce_module_locality locality local in + let local = enforce_module_locality atts.locality in Metasyntax.add_syntactic_definition (Global.env()) (snd lid) x local y -let vernac_declare_implicits locality r l = - let local = make_section_locality locality in +let vernac_declare_implicits ~atts r l = + let local = make_section_locality atts.locality in match l with | [] -> Impargs.declare_implicits local (smart_global r) @@ -976,7 +977,7 @@ let warn_arguments_assert = (* [nargs_for_red] is the number of arguments required to trigger reduction, [args] is the main list of arguments statuses, [more_implicits] is a list of extra lists of implicit statuses *) -let vernac_arguments locality reference args more_implicits nargs_for_red flags = +let vernac_arguments ~atts reference args more_implicits nargs_for_red flags = let assert_flag = List.mem `Assert flags in let rename_flag = List.mem `Rename flags in let clear_scopes_flag = List.mem `ClearScopes flags in @@ -1184,7 +1185,7 @@ let vernac_arguments locality reference args more_implicits nargs_for_red flags (* Actions *) if renaming_specified then begin - let local = make_section_locality locality in + let local = make_section_locality atts.locality in Arguments_renaming.rename_arguments local sr names end; @@ -1194,20 +1195,20 @@ let vernac_arguments locality reference args more_implicits nargs_for_red flags with UserError _ -> Notation.find_delimiters_scope ?loc k)) scopes in - vernac_arguments_scope locality reference scopes + vernac_arguments_scope ~atts reference scopes end; if implicits_specified || clear_implicits_flag then - vernac_declare_implicits locality reference implicits; + vernac_declare_implicits ~atts reference implicits; if default_implicits_flag then - vernac_declare_implicits locality reference []; + vernac_declare_implicits ~atts reference []; if red_modifiers_specified then begin match sr with | ConstRef _ as c -> Reductionops.ReductionBehaviour.set - (make_section_locality locality) c + (make_section_locality atts.locality) c (rargs, Option.default ~-1 nargs_for_red, red_flags) | _ -> user_err (strbrk "Modifiers of the behavior of the simpl tactic "++ @@ -1235,8 +1236,8 @@ let vernac_reserve bl = Reserve.declare_reserved_type idl t) in List.iter sb_decl bl -let vernac_generalizable locality = - let local = make_non_locality locality in +let vernac_generalizable ~atts = + let local = make_non_locality atts.locality in Implicit_quantifiers.declare_generalizable local let _ = @@ -1473,8 +1474,8 @@ let _ = optread = Nativenorm.get_profiling_enabled; optwrite = Nativenorm.set_profiling_enabled } -let vernac_set_strategy locality l = - let local = make_locality locality in +let vernac_set_strategy ~atts l = + let local = make_locality atts.locality in let glob_ref r = match smart_global r with | ConstRef sp -> EvalConstRef sp @@ -1484,8 +1485,8 @@ let vernac_set_strategy locality l = let l = List.map (fun (lev,ql) -> (lev,List.map glob_ref ql)) l in Redexpr.set_strategy local l -let vernac_set_opacity locality (v,l) = - let local = make_non_locality locality in +let vernac_set_opacity ~atts (v,l) = + let local = make_non_locality atts.locality in let glob_ref r = match smart_global r with | ConstRef sp -> EvalConstRef sp @@ -1495,18 +1496,18 @@ let vernac_set_opacity locality (v,l) = let l = List.map glob_ref l in Redexpr.set_strategy local [v,l] -let vernac_set_option locality key = function - | StringValue s -> set_string_option_value_gen locality key s - | StringOptValue (Some s) -> set_string_option_value_gen locality key s - | StringOptValue None -> unset_option_value_gen locality key - | IntValue n -> set_int_option_value_gen locality key n - | BoolValue b -> set_bool_option_value_gen locality key b +let vernac_set_option ~atts key = function + | StringValue s -> set_string_option_value_gen atts.locality key s + | StringOptValue (Some s) -> set_string_option_value_gen atts.locality key s + | StringOptValue None -> unset_option_value_gen atts.locality key + | IntValue n -> set_int_option_value_gen atts.locality key n + | BoolValue b -> set_bool_option_value_gen atts.locality key b -let vernac_set_append_option locality key s = - set_string_option_append_value_gen locality key s +let vernac_set_append_option ~atts key s = + set_string_option_append_value_gen atts.locality key s -let vernac_unset_option locality key = - unset_option_value_gen locality key +let vernac_unset_option ~atts key = + unset_option_value_gen atts.locality key let vernac_add_option key lv = let f = function @@ -1547,8 +1548,8 @@ let query_command_selector ?loc = function | _ -> user_err ?loc ~hdr:"query_command_selector" (str "Query commands only support the single numbered goal selector.") -let vernac_check_may_eval ?loc redexp glopt rc = - let glopt = query_command_selector ?loc glopt in +let vernac_check_may_eval ~atts redexp glopt rc = + let glopt = query_command_selector ?loc:atts.loc glopt in let (sigma, env) = get_current_context_of_args glopt in let sigma', c = interp_open_constr env sigma rc in let c = EConstr.Unsafe.to_constr c in @@ -1582,8 +1583,8 @@ let vernac_check_may_eval ?loc redexp glopt rc = in Feedback.msg_notice (print_eval redfun env sigma' rc j) -let vernac_declare_reduction locality s r = - let local = make_locality locality in +let vernac_declare_reduction ~atts s r = + let local = make_locality atts.locality in declare_red_expr local s (snd (Hook.get f_interp_redexp (Global.env()) Evd.empty r)) (* The same but avoiding the current goal context if any *) @@ -1637,8 +1638,10 @@ let print_about_hyp_globs ?loc ref_or_by_not udecl glopt = let sigma, env = Pfedit.get_current_context () in print_about env sigma ref_or_by_not udecl - -let vernac_print ?loc env sigma = let open Feedback in function +let vernac_print ~atts env sigma = + let open Feedback in + let loc = atts.loc in + function | PrintTables -> msg_notice (print_tables ()) | PrintFullContext-> msg_notice (print_full_context_typ env sigma) | PrintSectionContext qid -> msg_notice (print_sec_context_typ env sigma qid) @@ -1747,8 +1750,8 @@ let _ = optread = (fun () -> !search_output_name_only); optwrite = (:=) search_output_name_only } -let vernac_search ?loc s gopt r = - let gopt = query_command_selector ?loc gopt in +let vernac_search ~atts s gopt r = + let gopt = query_command_selector ?loc:atts.loc gopt in let r = interp_search_restriction r in let env,gopt = match gopt with | None -> @@ -1915,7 +1918,8 @@ let vernac_load interp fname = * is the outdated/deprecated "Local" attribute of some vernacular commands * still parsed as the obsolete_locality grammar entry for retrocompatibility. * loc is the Loc.t of the vernacular command being interpreted. *) -let interp ?proof ?loc locality poly st c = +let interp ?proof ~atts ~st c = + let open Vernacinterp in vernac_pperr_endline (fun () -> str "interpreting: " ++ Ppvernac.pr_vernac c); match c with (* The below vernac are candidates for removal from the main type @@ -1954,31 +1958,33 @@ let interp ?proof ?loc locality poly st c = | VernacLocal _ -> assert false (* Syntax *) - | VernacSyntaxExtension (infix, local,sl) -> - vernac_syntax_extension locality local infix sl + | VernacSyntaxExtension (infix, sl) -> + vernac_syntax_extension atts infix sl | VernacDelimiters (sc,lr) -> vernac_delimiters sc lr | VernacBindScope (sc,rl) -> vernac_bind_scope sc rl - | VernacOpenCloseScope (local, s) -> vernac_open_close_scope locality local s - | VernacArgumentsScope (qid,scl) -> vernac_arguments_scope locality qid scl - | VernacInfix (local,mv,qid,sc) -> vernac_infix locality local mv qid sc - | VernacNotation (local,c,infpl,sc) -> - vernac_notation locality local c infpl sc + | VernacOpenCloseScope (b, s) -> vernac_open_close_scope ~atts (b,s) + | VernacArgumentsScope (qid,scl) -> vernac_arguments_scope ~atts qid scl + | VernacInfix (mv,qid,sc) -> vernac_infix ~atts mv qid sc + | VernacNotation (c,infpl,sc) -> + vernac_notation ~atts c infpl sc | VernacNotationAddFormat(n,k,v) -> Metasyntax.add_notation_extra_printing_rule n k v (* Gallina *) - | VernacDefinition (k,lid,d) -> vernac_definition locality poly k lid d - | VernacStartTheoremProof (k,l) -> vernac_start_proof locality poly k l + | VernacDefinition ((discharge,kind),lid,d) -> + vernac_definition ~atts discharge kind lid d + | VernacStartTheoremProof (k,l) -> vernac_start_proof ~atts k l | VernacEndProof e -> vernac_end_proof ?proof e | VernacExactProof c -> vernac_exact_proof c - | VernacAssumption (stre,nl,l) -> vernac_assumption locality poly stre l nl - | VernacInductive (cum, priv,finite,l) -> vernac_inductive cum poly priv finite l - | VernacFixpoint (local, l) -> vernac_fixpoint locality poly local l - | VernacCoFixpoint (local, l) -> vernac_cofixpoint locality poly local l + | VernacAssumption ((discharge,kind),nl,l) -> + vernac_assumption ~atts discharge kind l nl + | VernacInductive (cum, priv,finite,l) -> vernac_inductive ~atts cum priv finite l + | VernacFixpoint (discharge, l) -> vernac_fixpoint ~atts discharge l + | VernacCoFixpoint (discharge, l) -> vernac_cofixpoint ~atts discharge l | VernacScheme l -> vernac_scheme l | VernacCombinedScheme (id, l) -> vernac_combined_scheme id l - | VernacUniverse l -> vernac_universe loc poly l - | VernacConstraint l -> vernac_constraint loc poly l + | VernacUniverse l -> vernac_universe ~atts l + | VernacConstraint l -> vernac_constraint ~atts l (* Modules *) | VernacDeclareModule (export,lid,bl,mtyo) -> @@ -1999,15 +2005,15 @@ let interp ?proof ?loc locality poly st c = | VernacRequire (from, export, qidl) -> vernac_require from export qidl | VernacImport (export,qidl) -> vernac_import export qidl | VernacCanonical qid -> vernac_canonical qid - | VernacCoercion (local,r,s,t) -> vernac_coercion locality poly local r s t - | VernacIdentityCoercion (local,(_,id),s,t) -> - vernac_identity_coercion locality poly local id s t + | VernacCoercion (r,s,t) -> vernac_coercion ~atts r s t + | VernacIdentityCoercion ((_,id),s,t) -> + vernac_identity_coercion ~atts id s t (* Type classes *) | VernacInstance (abst, sup, inst, props, info) -> - vernac_instance abst locality poly sup inst props info - | VernacContext sup -> vernac_context poly sup - | VernacDeclareInstances insts -> vernac_declare_instances locality insts + vernac_instance ~atts abst sup inst props info + | VernacContext sup -> vernac_context ~atts sup + | VernacDeclareInstances insts -> vernac_declare_instances ~atts insts | VernacDeclareClass id -> vernac_declare_class id (* Solving *) @@ -2017,7 +2023,7 @@ let interp ?proof ?loc locality poly st c = | VernacAddLoadPath (isrec,s,alias) -> vernac_add_loadpath isrec s alias | VernacRemoveLoadPath s -> vernac_remove_loadpath s | VernacAddMLPath (isrec,s) -> vernac_add_ml_path isrec s - | VernacDeclareMLModule l -> vernac_declare_ml_module locality l + | VernacDeclareMLModule l -> vernac_declare_ml_module ~atts l | VernacChdir s -> vernac_chdir s (* State management *) @@ -2025,40 +2031,40 @@ let interp ?proof ?loc locality poly st c = | VernacRestoreState s -> vernac_restore_state s (* Commands *) - | VernacCreateHintDb (dbname,b) -> vernac_create_hintdb locality dbname b - | VernacRemoveHints (dbnames,ids) -> vernac_remove_hints locality dbnames ids - | VernacHints (local,dbnames,hints) -> - vernac_hints locality poly local dbnames hints - | VernacSyntacticDefinition (id,c,local,b) -> - vernac_syntactic_definition locality id c local b + | VernacCreateHintDb (dbname,b) -> vernac_create_hintdb ~atts dbname b + | VernacRemoveHints (dbnames,ids) -> vernac_remove_hints ~atts dbnames ids + | VernacHints (dbnames,hints) -> + vernac_hints ~atts dbnames hints + | VernacSyntacticDefinition (id,c,b) -> + vernac_syntactic_definition ~atts id c b | VernacDeclareImplicits (qid,l) -> - vernac_declare_implicits locality qid l + vernac_declare_implicits ~atts qid l | VernacArguments (qid, args, more_implicits, nargs, flags) -> - vernac_arguments locality qid args more_implicits nargs flags + vernac_arguments ~atts qid args more_implicits nargs flags | VernacReserve bl -> vernac_reserve bl - | VernacGeneralizable gen -> vernac_generalizable locality gen - | VernacSetOpacity qidl -> vernac_set_opacity locality qidl - | VernacSetStrategy l -> vernac_set_strategy locality l - | VernacSetOption (key,v) -> vernac_set_option locality key v - | VernacSetAppendOption (key,v) -> vernac_set_append_option locality key v - | VernacUnsetOption key -> vernac_unset_option locality key + | VernacGeneralizable gen -> vernac_generalizable ~atts gen + | VernacSetOpacity qidl -> vernac_set_opacity ~atts qidl + | VernacSetStrategy l -> vernac_set_strategy ~atts l + | VernacSetOption (key,v) -> vernac_set_option ~atts key v + | VernacSetAppendOption (key,v) -> vernac_set_append_option ~atts key v + | VernacUnsetOption key -> vernac_unset_option ~atts key | VernacRemoveOption (key,v) -> vernac_remove_option key v | VernacAddOption (key,v) -> vernac_add_option key v | VernacMemOption (key,v) -> vernac_mem_option key v | VernacPrintOption key -> vernac_print_option key - | VernacCheckMayEval (r,g,c) -> vernac_check_may_eval ?loc r g c - | VernacDeclareReduction (s,r) -> vernac_declare_reduction locality s r + | VernacCheckMayEval (r,g,c) -> vernac_check_may_eval ~atts r g c + | VernacDeclareReduction (s,r) -> vernac_declare_reduction ~atts s r | VernacGlobalCheck c -> vernac_global_check c | VernacPrint p -> let sigma, env = Pfedit.get_current_context () in - vernac_print ?loc env sigma p - | VernacSearch (s,g,r) -> vernac_search ?loc s g r + vernac_print ~atts env sigma p + | VernacSearch (s,g,r) -> vernac_search ~atts s g r | VernacLocate l -> vernac_locate l | VernacRegister (id, r) -> vernac_register id r | VernacComments l -> Flags.if_verbose Feedback.msg_info (str "Comments ok\n") (* Proof management *) - | VernacGoal t -> vernac_start_proof locality poly Theorem [None,([],t)] + | VernacGoal t -> vernac_start_proof ~atts Theorem [None,([],t)] | VernacFocus n -> vernac_focus n | VernacUnfocus -> vernac_unfocus () | VernacUnfocused -> vernac_unfocused () @@ -2071,7 +2077,7 @@ let interp ?proof ?loc locality poly st c = let using = Option.append using (Proof_using.get_default_proof_using ()) in let tacs = if Option.is_empty tac then "tac:no" else "tac:yes" in let usings = if Option.is_empty using then "using:no" else "using:yes" in - Aux_file.record_in_aux_at ?loc "VernacProof" (tacs^" "^usings); + Aux_file.record_in_aux_at ?loc:atts.loc "VernacProof" (tacs^" "^usings); Option.iter vernac_set_end_tac tac; Option.iter vernac_set_used_variables using | VernacProofMode mn -> Proof_global.set_proof_mode mn [@ocaml.warning "-3"] @@ -2079,7 +2085,7 @@ let interp ?proof ?loc locality poly st c = (* Extensions *) | VernacExtend (opn,args) -> (* XXX: Here we are returning the state! :) *) - let _st : Vernacstate.t = Vernacinterp.call ?locality ?loc (opn,args) ~st in + let _st : Vernacstate.t = Vernacinterp.call ~atts opn args ~st in () (* Vernaculars that take a locality flag *) @@ -2111,7 +2117,7 @@ let check_vernac_supports_polymorphism c p = | None, _ -> () | Some _, ( VernacDefinition _ | VernacFixpoint _ | VernacCoFixpoint _ - | VernacAssumption _ | VernacInductive _ + | VernacAssumption _ | VernacInductive _ | VernacStartTheoremProof _ | VernacCoercion _ | VernacIdentityCoercion _ | VernacInstance _ | VernacDeclareInstances _ @@ -2120,7 +2126,7 @@ let check_vernac_supports_polymorphism c p = | Some _, _ -> user_err Pp.(str "This command does not support Polymorphism") let enforce_polymorphism = function - | None -> Flags.is_universe_polymorphism () + | None -> Flags.is_universe_polymorphism () | Some b -> Flags.make_polymorphic_flag b; b (** A global default timeout, controlled by option "Set Default Timeout n". @@ -2188,42 +2194,57 @@ let with_fail st b f = | _ -> assert false end -let interp ?(verbosely=true) ?proof st (loc,c) = +let interp ?(verbosely=true) ?proof ~st (loc,c) = let orig_program_mode = Flags.is_program_mode () in - let rec aux ?locality ?polymorphism isprogcmd = function - - | VernacProgram c when not isprogcmd -> aux ?locality ?polymorphism true c - | VernacProgram _ -> user_err Pp.(str "Program mode specified twice") - | VernacLocal (b, c) when Option.is_empty locality -> - aux ~locality:b ?polymorphism isprogcmd c - | VernacPolymorphic (b, c) when polymorphism = None -> - aux ?locality ~polymorphism:b isprogcmd c - | VernacPolymorphic (b, c) -> user_err Pp.(str "Polymorphism specified twice") - | VernacLocal _ -> user_err Pp.(str "Locality specified twice") + let rec aux ?polymorphism ~atts isprogcmd = function + + | VernacProgram c when not isprogcmd -> + aux ?polymorphism ~atts true c + + | VernacProgram _ -> + user_err Pp.(str "Program mode specified twice") + + | VernacPolymorphic (b, c) when polymorphism = None -> + aux ~polymorphism:b ~atts:atts isprogcmd c + + | VernacPolymorphic (b, c) -> + user_err Pp.(str "Polymorphism specified twice") + + | VernacLocal (b, c) when Option.is_empty atts.locality -> + aux ?polymorphism ~atts:{atts with locality = Some b} isprogcmd c + + | VernacLocal _ -> + user_err Pp.(str "Locality specified twice") + | VernacFail v -> - with_fail st true (fun () -> aux ?locality ?polymorphism isprogcmd v) + with_fail st true (fun () -> aux ?polymorphism ~atts isprogcmd v) + | VernacTimeout (n,v) -> - current_timeout := Some n; - aux ?locality ?polymorphism isprogcmd v + current_timeout := Some n; + aux ?polymorphism ~atts isprogcmd v + | VernacRedirect (s, (_,v)) -> - Topfmt.with_output_to_file s (aux ?locality ?polymorphism isprogcmd) v + Topfmt.with_output_to_file s (aux ?polymorphism ~atts isprogcmd) v + | VernacTime (_,v) -> - System.with_time !Flags.time - (aux ?locality ?polymorphism isprogcmd) v; - | VernacLoad (_,fname) -> vernac_load (aux false) fname - | c -> - check_vernac_supports_locality c locality; - check_vernac_supports_polymorphism c polymorphism; - let poly = enforce_polymorphism polymorphism in - Obligations.set_program_mode isprogcmd; - try - vernac_timeout begin fun () -> + System.with_time !Flags.time (aux ?polymorphism ~atts isprogcmd) v; + + | VernacLoad (_,fname) -> vernac_load (aux ?polymorphism ~atts false) fname + + | c -> + check_vernac_supports_locality c atts.locality; + check_vernac_supports_polymorphism c polymorphism; + let polymorphic = enforce_polymorphism polymorphism in + Obligations.set_program_mode isprogcmd; + try + vernac_timeout begin fun () -> + let atts = { atts with polymorphic } in if verbosely - then Flags.verbosely (interp ?proof ?loc locality poly st) c - else Flags.silently (interp ?proof ?loc locality poly st) c; + then Flags.verbosely (interp ?proof ~atts ~st) c + else Flags.silently (interp ?proof ~atts ~st) c; if orig_program_mode || not !Flags.program_mode || isprogcmd then Flags.program_mode := orig_program_mode; - ignore (Flags.use_polymorphic_flag ()) + ignore (Flags.use_polymorphic_flag ()) end with | reraise when @@ -2238,12 +2259,14 @@ let interp ?(verbosely=true) ?proof st (loc,c) = ignore (Flags.use_polymorphic_flag ()); iraise e in - if verbosely then Flags.verbosely (aux false) c - else aux false c + let atts = { loc; locality = None; polymorphic = false; } in + if verbosely + then Flags.verbosely (aux ~atts orig_program_mode) c + else aux ~atts orig_program_mode c (* XXX: There is a bug here in case of an exception, see @gares comments on the PR *) -let interp ?verbosely ?proof st cmd = +let interp ?verbosely ?proof ~st cmd = Vernacstate.unfreeze_interp_state st; - interp ?verbosely ?proof st cmd; + interp ?verbosely ?proof ~st cmd; Vernacstate.freeze_interp_state `No diff --git a/vernac/vernacentries.mli b/vernac/vernacentries.mli index 67001bc24e..a559912a09 100644 --- a/vernac/vernacentries.mli +++ b/vernac/vernacentries.mli @@ -18,7 +18,7 @@ val vernac_require : val interp : ?verbosely:bool -> ?proof:Proof_global.closed_proof -> - Vernacstate.t -> Vernacexpr.vernac_expr Loc.located -> Vernacstate.t + st:Vernacstate.t -> Vernacexpr.vernac_expr Loc.located -> Vernacstate.t (** Prepare a "match" template for a given inductive type. For each branch of the match, we list the constructor name diff --git a/vernac/vernacinterp.ml b/vernac/vernacinterp.ml index 47dec19588..c0b93c1638 100644 --- a/vernac/vernacinterp.ml +++ b/vernac/vernacinterp.ml @@ -15,17 +15,17 @@ type deprecation = bool type atts = { loc : Loc.t option; locality : bool option; + polymorphic : bool; } -type vernac_command = - Genarg.raw_generic_argument list -> - atts:atts -> st:Vernacstate.t -> - Vernacstate.t +type 'a vernac_command = 'a -> atts:atts -> st:Vernacstate.t -> Vernacstate.t + +type plugin_args = Genarg.raw_generic_argument list (* Table of vernac entries *) let vernac_tab = (Hashtbl.create 211 : - (Vernacexpr.extend_name, deprecation * vernac_command) Hashtbl.t) + (Vernacexpr.extend_name, deprecation * plugin_args vernac_command) Hashtbl.t) let vinterp_add depr s f = try @@ -58,7 +58,7 @@ let warn_deprecated_command = (* Interpretation of a vernac command *) -let call ?locality ?loc (opn,converted_args) = +let call opn converted_args ~atts ~st = let phase = ref "Looking up command" in try let depr, callback = vinterp_map opn in @@ -74,8 +74,7 @@ let call ?locality ?loc (opn,converted_args) = phase := "Checking arguments"; let hunk = callback converted_args in phase := "Executing command"; - let atts = { loc; locality } in - hunk ~atts + hunk ~atts ~st with | Drop -> raise Drop | reraise -> diff --git a/vernac/vernacinterp.mli b/vernac/vernacinterp.mli index 602ccba157..ab3d4bfc52 100644 --- a/vernac/vernacinterp.mli +++ b/vernac/vernacinterp.mli @@ -13,19 +13,15 @@ type deprecation = bool type atts = { loc : Loc.t option; locality : bool option; + polymorphic : bool; } -type vernac_command = - Genarg.raw_generic_argument list -> - atts:atts -> st:Vernacstate.t -> - Vernacstate.t +type 'a vernac_command = 'a -> atts:atts -> st:Vernacstate.t -> Vernacstate.t -val vinterp_add : deprecation -> Vernacexpr.extend_name -> vernac_command -> unit - -val overwriting_vinterp_add : Vernacexpr.extend_name -> vernac_command -> unit +type plugin_args = Genarg.raw_generic_argument list val vinterp_init : unit -> unit +val vinterp_add : deprecation -> Vernacexpr.extend_name -> plugin_args vernac_command -> unit +val overwriting_vinterp_add : Vernacexpr.extend_name -> plugin_args vernac_command -> unit -val call : ?locality:bool -> ?loc:Loc.t -> - Vernacexpr.extend_name * Genarg.raw_generic_argument list -> - st:Vernacstate.t -> Vernacstate.t +val call : Vernacexpr.extend_name -> plugin_args -> atts:atts -> st:Vernacstate.t -> Vernacstate.t diff --git a/vernac/vernacstate.ml b/vernac/vernacstate.ml index eb1359d52b..4a1ae14e3c 100644 --- a/vernac/vernacstate.ml +++ b/vernac/vernacstate.ml @@ -8,7 +8,7 @@ type t = { system : States.state; (* summary + libstack *) - proof : Proof_global.state; (* proof state *) + proof : Proof_global.t; (* proof state *) shallow : bool (* is the state trimmed down (libstack) *) } diff --git a/vernac/vernacstate.mli b/vernac/vernacstate.mli index bcfa49aa38..3ed27ddb7a 100644 --- a/vernac/vernacstate.mli +++ b/vernac/vernacstate.mli @@ -8,7 +8,7 @@ type t = { system : States.state; (* summary + libstack *) - proof : Proof_global.state; (* proof state *) + proof : Proof_global.t; (* proof state *) shallow : bool (* is the state trimmed down (libstack) *) } |