diff options
161 files changed, 1967 insertions, 708 deletions
diff --git a/.gitattributes b/.gitattributes index 00f78b4494..f2c096f2d6 100644 --- a/.gitattributes +++ b/.gitattributes @@ -1,3 +1,36 @@ .gitattributes export-ignore .gitignore export-ignore .mailmap export-ignore + +*.asciidoc whitespace=trailing-space,tab-in-indent +*.bat whitespace=cr-at-eol,trailing-space,tab-in-indent +*.bib whitespace=trailing-space,tab-in-indent +*.c whitespace=trailing-space,tab-in-indent +*.css whitespace=trailing-space,tab-in-indent +*.dtd whitespace=trailing-space,tab-in-indent +*.el whitespace=trailing-space,tab-in-indent +*.h whitespace=trailing-space,tab-in-indent +*.html whitespace=trailing-space,tab-in-indent +*.hva whitespace=trailing-space,tab-in-indent +*.js whitespace=trailing-space,tab-in-indent +*.json whitespace=trailing-space,tab-in-indent +*.lang whitespace=trailing-space,tab-in-indent +*.md whitespace=trailing-space,tab-in-indent +*.merlin whitespace=trailing-space,tab-in-indent +*.ml whitespace=trailing-space,tab-in-indent +*.ml4 whitespace=trailing-space,tab-in-indent +*.mli whitespace=trailing-space,tab-in-indent +*.mll whitespace=trailing-space,tab-in-indent +*.mllib whitespace=trailing-space,tab-in-indent +*.mlp whitespace=trailing-space,tab-in-indent +*.mlpack whitespace=trailing-space,tab-in-indent +*.nsh whitespace=trailing-space,tab-in-indent +*.nsi whitespace=trailing-space,tab-in-indent +*.py whitespace=trailing-space,tab-in-indent +*.sh whitespace=trailing-space,tab-in-indent +*.sty whitespace=trailing-space,tab-in-indent +*.tex whitespace=trailing-space,tab-in-indent +*.txt whitespace=trailing-space,tab-in-indent +*.v whitespace=trailing-space,tab-in-indent +*.xml whitespace=trailing-space,tab-in-indent +*.yml whitespace=trailing-space,tab-in-indent @@ -55,6 +55,7 @@ Tom Hutchinson <thutchin@gforge> thutchin <thutchin@85f007b7-5 Cezary Kaliszyk <cek@gforge> cek <cek@85f007b7-540e-0410-9357-904b9bb8a0f7> Florent Kirchner <fkirchne@gforge> fkirchne <fkirchne@85f007b7-540e-0410-9357-904b9bb8a0f7> Florent Kirchner <fkirchne@gforge> kirchner <kirchner@85f007b7-540e-0410-9357-904b9bb8a0f7> +Johannes Kloos <jkloos@mpi-sws.org> jkloos <jkloos@mpi-sws.org> Matej KoÅ¡Ãk <matej.kosik@inria.fr> Matej Kosik <m4tej.kosik@gmail.com> Matej KoÅ¡Ãk <matej.kosik@inria.fr> Matej Kosik <matej.kosik@inria.fr> Marc Lasson <marc.lasson@gmail.com> mlasson <marc.lasson@gmail.com> diff --git a/.travis.yml b/.travis.yml index 8d70e346ad..3b90f7cf47 100644 --- a/.travis.yml +++ b/.travis.yml @@ -37,9 +37,10 @@ env: # Main test suites matrix: - TEST_TARGET="test-suite" COMPILER="4.02.3+32bit" + - TEST_TARGET="test-suite" COMPILER="4.06.0+trunk" CAMLP5_VER="7.03" EXTRA_OPAM="num" FINDLIB_VER="1.7.3" - TEST_TARGET="validate" TW="travis_wait" - TEST_TARGET="validate" COMPILER="4.02.3+32bit" TW="travis_wait" - - TEST_TARGET="validate" COMPILER="4.05.0+flambda" CAMLP5_VER="7.01" NATIVE_COMP="no" EXTRA_CONF="-flambda-opts -O3" NATIVE_COMP="no" + - TEST_TARGET="validate" COMPILER="4.06.0+trunk+flambda" CAMLP5_VER="7.03" NATIVE_COMP="no" EXTRA_CONF="-flambda-opts -O3" EXTRA_OPAM="num" FINDLIB_VER="1.7.3" - TEST_TARGET="ci-bignums TIMED=1" - TEST_TARGET="ci-color TIMED=1" - TEST_TARGET="ci-compcert TIMED=1" @@ -65,6 +66,17 @@ env: matrix: include: + - env: + - TEST_TARGET="lint" + install: [] + before_script: [] + addons: + apt: + sources: [] + packages: [] + script: + - dev/lint-repository.sh + # Full Coq test-suite with two compilers - env: - TEST_TARGET="test-suite" @@ -95,7 +107,7 @@ matrix: - TEST_TARGET="test-suite" - COMPILER="4.05.0" - FINDLIB_VER="1.7.3" - - CAMLP5_VER="7.01" + - CAMLP5_VER="7.03" - EXTRA_CONF="-coqide opt -with-doc yes" - EXTRA_OPAM="lablgtk-extras hevea" addons: @@ -109,7 +121,7 @@ matrix: - TEST_TARGET="test-suite" - COMPILER="4.05.0+flambda" - FINDLIB_VER="1.7.3" - - CAMLP5_VER="7.01" + - CAMLP5_VER="7.03" - NATIVE_COMP="no" - EXTRA_CONF="-coqide opt -with-doc yes -flambda-opts -O3" - EXTRA_OPAM="lablgtk-extras hevea" @@ -139,7 +151,7 @@ matrix: - env: - TEST_TARGET="coqocaml" - COMPILER="4.05.0" - - CAMLP5_VER="7.01" + - CAMLP5_VER="7.03" - FINDLIB_VER="1.7.3" - EXTRA_CONF="-coqide opt -warn-error" - EXTRA_OPAM="lablgtk-extras hevea" diff --git a/API/API.ml b/API/API.ml index bf99d0febd..6e61063e4b 100644 --- a/API/API.ml +++ b/API/API.ml @@ -131,6 +131,7 @@ module Geninterp = Geninterp (******************************************************************************) (* Pretyping *) (******************************************************************************) +module Ltac_pretype = Ltac_pretype module Locusops = Locusops module Pretype_errors = Pretype_errors module Reductionops = Reductionops diff --git a/API/API.mli b/API/API.mli index a41009fa2f..ccb71179dd 100644 --- a/API/API.mli +++ b/API/API.mli @@ -2757,13 +2757,6 @@ sig | PFix of Term.fixpoint | PCoFix of Term.cofixpoint - type constr_under_binders = Names.Id.t list * EConstr.constr - - (** Types of substitutions with or w/o bound variables *) - - type patvar_map = EConstr.constr Names.Id.Map.t - type extended_patvar_map = constr_under_binders Names.Id.Map.t - end module Namegen : @@ -3185,34 +3178,6 @@ sig type any_glob_constr = | AnyGlobConstr : 'r glob_constr_g -> any_glob_constr - (** A globalised term together with a closure representing the value - of its free variables. Intended for use when these variables are taken - from the Ltac environment. *) - - type closure = { - idents : Names.Id.t Names.Id.Map.t; - typed : Pattern.constr_under_binders Names.Id.Map.t ; - untyped: closed_glob_constr Names.Id.Map.t } - and closed_glob_constr = { - closure: closure; - term: glob_constr } - - (** Ltac variable maps *) - type var_map = Pattern.constr_under_binders Names.Id.Map.t - type uconstr_var_map = closed_glob_constr Names.Id.Map.t - type unbound_ltac_var_map = Geninterp.Val.t Names.Id.Map.t - - type ltac_var_map = { - ltac_constrs : var_map; - (** Ltac variables bound to constrs *) - ltac_uconstrs : uconstr_var_map; - (** Ltac variables bound to untyped constrs *) - ltac_idents: Names.Id.t Names.Id.Map.t; - (** Ltac variables bound to identifiers *) - ltac_genargs : unbound_ltac_var_map; - (** Ltac variables bound to other kinds of arguments *) - } - end module Notation_term : @@ -3276,6 +3241,79 @@ end (* Modules from pretyping/ *) (************************************************************************) +module Ltac_pretype : +sig +open Names +open Glob_term + +(** {5 Maps of pattern variables} *) + +(** Type [constr_under_binders] is for representing the term resulting + of a matching. Matching can return terms defined in a some context + of named binders; in the context, variable names are ordered by + (<) and referred to by index in the term Thanks to the canonical + ordering, a matching problem like + + [match ... with [(fun x y => ?p,fun y x => ?p)] => [forall x y => p]] + + will be accepted. Thanks to the reference by index, a matching + problem like + + [match ... with [(fun x => ?p)] => [forall x => p]] + + will work even if [x] is also the name of an existing goal + variable. + + Note: we do not keep types in the signature. Besides simplicity, + the main reason is that it would force to close the signature over + binders that occur only in the types of effective binders but not + in the term itself (e.g. for a term [f x] with [f:A -> True] and + [x:A]). + + On the opposite side, by not keeping the types, we loose + opportunity to propagate type informations which otherwise would + not be inferable, as e.g. when matching [forall x, x = 0] with + pattern [forall x, ?h = 0] and using the solution "x|-h:=x" in + expression [forall x, h = x] where nothing tells how the type of x + could be inferred. We also loose the ability of typing ltac + variables before calling the right-hand-side of ltac matching clauses. *) + +type constr_under_binders = Id.t list * EConstr.constr + +(** Types of substitutions with or w/o bound variables *) + +type patvar_map = EConstr.constr Id.Map.t +type extended_patvar_map = constr_under_binders Id.Map.t + +(** A globalised term together with a closure representing the value + of its free variables. Intended for use when these variables are taken + from the Ltac environment. *) +type closure = { + idents:Id.t Id.Map.t; + typed: constr_under_binders Id.Map.t ; + untyped:closed_glob_constr Id.Map.t } +and closed_glob_constr = { + closure: closure; + term: glob_constr } + +(** Ltac variable maps *) +type var_map = constr_under_binders Id.Map.t +type uconstr_var_map = closed_glob_constr Id.Map.t +type unbound_ltac_var_map = Geninterp.Val.t Id.Map.t + +type ltac_var_map = { + ltac_constrs : var_map; + (** Ltac variables bound to constrs *) + ltac_uconstrs : uconstr_var_map; + (** Ltac variables bound to untyped constrs *) + ltac_idents: Id.t Id.Map.t; + (** Ltac variables bound to identifiers *) + ltac_genargs : unbound_ltac_var_map; + (** Ltac variables bound to other kinds of arguments *) +} + +end + module Locusops : sig val clause_with_generic_occurrences : 'a Locus.clause_expr -> bool @@ -3513,7 +3551,7 @@ sig val map_glob_constr : (Glob_term.glob_constr -> Glob_term.glob_constr) -> Glob_term.glob_constr -> Glob_term.glob_constr - val empty_lvar : Glob_term.ltac_var_map + val empty_lvar : Ltac_pretype.ltac_var_map end @@ -3529,7 +3567,7 @@ sig val subst_pattern : Mod_subst.substitution -> Pattern.constr_pattern -> Pattern.constr_pattern val pattern_of_constr : Environ.env -> Evd.evar_map -> Constr.t -> Pattern.constr_pattern val instantiate_pattern : Environ.env -> - Evd.evar_map -> Pattern.extended_patvar_map -> + Evd.evar_map -> Ltac_pretype.extended_patvar_map -> Pattern.constr_pattern -> Pattern.constr_pattern end @@ -3542,16 +3580,16 @@ sig val is_matching : Environ.env -> Evd.evar_map -> Pattern.constr_pattern -> EConstr.constr -> bool val extended_matches : Environ.env -> Evd.evar_map -> binding_bound_vars * Pattern.constr_pattern -> - EConstr.constr -> bound_ident_map * Pattern.extended_patvar_map + EConstr.constr -> bound_ident_map * Ltac_pretype.extended_patvar_map exception PatternMatchingFailure type matching_result = - { m_sub : bound_ident_map * Pattern.patvar_map; + { m_sub : bound_ident_map * Ltac_pretype.patvar_map; m_ctx : EConstr.constr } val match_subterm_gen : Environ.env -> Evd.evar_map -> bool -> binding_bound_vars * Pattern.constr_pattern -> EConstr.constr -> matching_result IStream.t - val matches : Environ.env -> Evd.evar_map -> Pattern.constr_pattern -> EConstr.constr -> Pattern.patvar_map + val matches : Environ.env -> Evd.evar_map -> Pattern.constr_pattern -> EConstr.constr -> Ltac_pretype.patvar_map end module Tacred : @@ -4082,7 +4120,7 @@ sig } val understand_ltac : inference_flags -> - Environ.env -> Evd.evar_map -> Glob_term.ltac_var_map -> + Environ.env -> Evd.evar_map -> Ltac_pretype.ltac_var_map -> typing_constraint -> Glob_term.glob_constr -> Evd.evar_map * EConstr.t val understand_tcc : ?flags:inference_flags -> Environ.env -> Evd.evar_map -> ?expected_type:typing_constraint -> Glob_term.glob_constr -> Evd.evar_map * EConstr.constr @@ -4091,11 +4129,11 @@ sig val check_evars : Environ.env -> Evd.evar_map -> Evd.evar_map -> EConstr.constr -> unit val register_constr_interp0 : ('r, 'g, 't) Genarg.genarg_type -> - (Glob_term.unbound_ltac_var_map -> Environ.env -> Evd.evar_map -> EConstr.types -> 'g -> EConstr.constr * Evd.evar_map) -> unit + (Ltac_pretype.unbound_ltac_var_map -> Environ.env -> Evd.evar_map -> EConstr.types -> 'g -> EConstr.constr * Evd.evar_map) -> unit val all_and_fail_flags : inference_flags val ise_pretype_gen : inference_flags -> Environ.env -> Evd.evar_map -> - Glob_term.ltac_var_map -> typing_constraint -> Glob_term.glob_constr -> Evd.evar_map * EConstr.constr + Ltac_pretype.ltac_var_map -> typing_constraint -> Glob_term.glob_constr -> Evd.evar_map * EConstr.constr end module Unification : @@ -4203,7 +4241,7 @@ sig val wit_int_or_var : (int Misctypes.or_var, int Misctypes.or_var, int) Genarg.genarg_type val wit_ref : (Libnames.reference, Globnames.global_reference Loc.located Misctypes.or_var, Globnames.global_reference) Genarg.genarg_type val wit_clause_dft_concl : (Names.Id.t Loc.located Locus.clause_expr,Names.Id.t Loc.located Locus.clause_expr,Names.Id.t Locus.clause_expr) Genarg.genarg_type - val wit_uconstr : (Constrexpr.constr_expr , Tactypes.glob_constr_and_expr, Glob_term.closed_glob_constr) Genarg.genarg_type + val wit_uconstr : (Constrexpr.constr_expr , Tactypes.glob_constr_and_expr, Ltac_pretype.closed_glob_constr) Genarg.genarg_type val wit_red_expr : ((Constrexpr.constr_expr,Libnames.reference Misctypes.or_by_notation,Constrexpr.constr_expr) Genredexpr.red_expr_gen, (Tactypes.glob_constr_and_expr,Names.evaluable_global_reference Misctypes.and_short_name Misctypes.or_var,Tactypes.glob_constr_pattern_and_expr) Genredexpr.red_expr_gen, @@ -4456,7 +4494,7 @@ end module Evar_refiner : sig - type glob_constr_ltac_closure = Glob_term.ltac_var_map * Glob_term.glob_constr + type glob_constr_ltac_closure = Ltac_pretype.ltac_var_map * Glob_term.glob_constr val w_refine : Evar.t * Evd.evar_info -> glob_constr_ltac_closure -> Evd.evar_map -> Evd.evar_map @@ -4935,10 +4973,23 @@ end module Genprint : sig + type printer_with_level = + { default_already_surrounded : Notation_term.tolerability; + default_ensure_surrounded : Notation_term.tolerability; + printer : Environ.env -> Evd.evar_map -> Notation_term.tolerability -> Pp.t } + type printer_result = + | PrinterBasic of (unit -> Pp.t) + | PrinterNeedsContext of (Environ.env -> Evd.evar_map -> Pp.t) + | PrinterNeedsContextAndLevel of printer_with_level type 'a printer = 'a -> Pp.t - val generic_top_print : Genarg.tlevel Genarg.generic_argument printer + type 'a top_printer = 'a -> printer_result val register_print0 : ('raw, 'glb, 'top) Genarg.genarg_type -> - 'raw printer -> 'glb printer -> 'top printer -> unit + 'raw printer -> 'glb printer -> 'top top_printer -> unit + val register_vernac_print0 : ('raw, 'glb, 'top) Genarg.genarg_type -> + 'raw printer -> unit + val register_val_print0 : 'top Geninterp.Val.typ -> 'top top_printer -> unit + val generic_top_print : Genarg.tlevel Genarg.generic_argument top_printer + val generic_val_print : Geninterp.Val.t top_printer end module Pputils : @@ -4959,6 +5010,8 @@ sig val pr_name : Names.Name.t -> Pp.t [@@ocaml.deprecated "alias of API.Names.Name.print"] + val lsimpleconstr : Notation_term.tolerability + val ltop : Notation_term.tolerability val pr_id : Names.Id.t -> Pp.t val pr_or_var : ('a -> Pp.t) -> 'a Misctypes.or_var -> Pp.t val pr_with_comments : ?loc:Loc.t -> Pp.t -> Pp.t @@ -4991,19 +5044,21 @@ sig val pr_constr_pattern : Pattern.constr_pattern -> Pp.t val pr_glob_constr_env : Environ.env -> Glob_term.glob_constr -> Pp.t val pr_lglob_constr_env : Environ.env -> Glob_term.glob_constr -> Pp.t + val pr_econstr_n_env : Environ.env -> Evd.evar_map -> Notation_term.tolerability -> EConstr.constr -> Pp.t val pr_econstr_env : Environ.env -> Evd.evar_map -> EConstr.constr -> Pp.t val pr_constr_pattern_env : Environ.env -> Evd.evar_map -> Pattern.constr_pattern -> Pp.t val pr_lconstr_pattern_env : Environ.env -> Evd.evar_map -> Pattern.constr_pattern -> Pp.t - val pr_closed_glob : Glob_term.closed_glob_constr -> Pp.t + val pr_closed_glob : Ltac_pretype.closed_glob_constr -> Pp.t val pr_lglob_constr : Glob_term.glob_constr -> Pp.t val pr_leconstr_env : Environ.env -> Evd.evar_map -> EConstr.constr -> Pp.t val pr_leconstr : EConstr.constr -> Pp.t val pr_global : Globnames.global_reference -> Pp.t - val pr_lconstr_under_binders : Pattern.constr_under_binders -> Pp.t - val pr_lconstr_under_binders_env : Environ.env -> Evd.evar_map -> Pattern.constr_under_binders -> Pp.t + val pr_lconstr_under_binders : Ltac_pretype.constr_under_binders -> Pp.t + val pr_lconstr_under_binders_env : Environ.env -> Evd.evar_map -> Ltac_pretype.constr_under_binders -> Pp.t - val pr_constr_under_binders_env : Environ.env -> Evd.evar_map -> Pattern.constr_under_binders -> Pp.t - val pr_closed_glob_env : Environ.env -> Evd.evar_map -> Glob_term.closed_glob_constr -> Pp.t + val pr_constr_under_binders_env : Environ.env -> Evd.evar_map -> Ltac_pretype.constr_under_binders -> Pp.t + val pr_closed_glob_n_env : Environ.env -> Evd.evar_map -> Notation_term.tolerability -> Ltac_pretype.closed_glob_constr -> Pp.t + val pr_closed_glob_env : Environ.env -> Evd.evar_map -> Ltac_pretype.closed_glob_constr -> Pp.t val pr_rel_context_of : Environ.env -> Evd.evar_map -> Pp.t val pr_named_context_of : Environ.env -> Evd.evar_map -> Pp.t val pr_ltype : Term.types -> Pp.t @@ -5158,7 +5213,7 @@ module Tactics : sig open Proofview - type change_arg = Pattern.patvar_map -> Evd.evar_map -> Evd.evar_map * EConstr.constr + type change_arg = Ltac_pretype.patvar_map -> Evd.evar_map -> Evd.evar_map * EConstr.constr type tactic_reduction = Environ.env -> Evd.evar_map -> EConstr.constr -> EConstr.constr type elim_scheme = @@ -5337,6 +5392,11 @@ sig | Naive | FirstSolved | AllMatches + type inj_flags = { + keep_proof_equalities : bool; (* One may want it or not *) + injection_in_context : bool; (* For regularity; one may want it from ML code but not interactively *) + injection_pattern_l2r_order : bool; (* Compatibility option: no reason not to want it *) + } val build_selector : Environ.env -> Evd.evar_map -> int -> EConstr.constr -> EConstr.types -> @@ -5345,20 +5405,20 @@ sig val general_rewrite : orientation -> Locus.occurrences -> freeze_evars_flag -> dep_proof_flag -> ?tac:(unit Proofview.tactic * conditions) -> EConstr.constr -> unit Proofview.tactic - val inj : Tactypes.intro_patterns option -> Misctypes.evars_flag -> + val inj : inj_flags option -> Tactypes.intro_patterns option -> Misctypes.evars_flag -> Misctypes.clear_flag -> EConstr.constr Misctypes.with_bindings -> unit Proofview.tactic val general_multi_rewrite : Misctypes.evars_flag -> (bool * Misctypes.multi * Misctypes.clear_flag * Tactypes.delayed_open_constr_with_bindings) list -> Locus.clause -> (unit Proofview.tactic * conditions) option -> unit Proofview.tactic val replace_in_clause_maybe_by : EConstr.constr -> EConstr.constr -> Locus.clause -> unit Proofview.tactic option -> unit Proofview.tactic val replace_term : bool option -> EConstr.constr -> Locus.clause -> unit Proofview.tactic - val dEq : Misctypes.evars_flag -> EConstr.constr Misctypes.with_bindings Misctypes.destruction_arg option -> unit Proofview.tactic + val dEq : keep_proofs:bool option -> Misctypes.evars_flag -> EConstr.constr Misctypes.with_bindings Misctypes.destruction_arg option -> unit Proofview.tactic val discr_tac : Misctypes.evars_flag -> EConstr.constr Misctypes.with_bindings Misctypes.destruction_arg option -> unit Proofview.tactic - val injClause : Tactypes.intro_patterns option -> Misctypes.evars_flag -> + val injClause : inj_flags option -> Tactypes.intro_patterns option -> Misctypes.evars_flag -> EConstr.constr Misctypes.with_bindings Misctypes.destruction_arg option -> unit Proofview.tactic - val simpleInjClause : Misctypes.evars_flag -> + val simpleInjClause : inj_flags option -> Misctypes.evars_flag -> EConstr.constr Misctypes.with_bindings Misctypes.destruction_arg option -> unit Proofview.tactic val rewriteInConcl : bool -> EConstr.constr -> unit Proofview.tactic @@ -5392,8 +5452,8 @@ sig ?tac:(unit Proofview.tactic * conditions) -> EConstr.constr Misctypes.with_bindings -> Misctypes.evars_flag -> unit Proofview.tactic val discriminable : Environ.env -> Evd.evar_map -> EConstr.constr -> EConstr.constr -> bool val discrHyp : Names.Id.t -> unit Proofview.tactic - val injectable : Environ.env -> Evd.evar_map -> EConstr.constr -> EConstr.constr -> bool - val injHyp : Misctypes.clear_flag -> Names.Id.t -> unit Proofview.tactic + val injectable : Environ.env -> Evd.evar_map -> keep_proofs:(bool option) -> EConstr.constr -> EConstr.constr -> bool + val injHyp : inj_flags option -> Misctypes.clear_flag -> Names.Id.t -> unit Proofview.tactic val subst_gen : bool -> Names.Id.t list -> unit Proofview.tactic end @@ -5771,7 +5831,7 @@ module Vernacinterp : sig type deprecation = bool - type vernac_command = Genarg.raw_generic_argument list -> unit -> unit + type vernac_command = Genarg.raw_generic_argument list -> Loc.t option -> unit val vinterp_add : deprecation -> Vernacexpr.extend_name -> vernac_command -> unit @@ -18,6 +18,8 @@ Tactics such as "x := 5 : Z" (see BZ#148). This could be disabled via Unset Omega UseLocalDefs. - The tactic "romega" is also aware now of the bodies of context variables. +- Tactic "decide equality" now able to manage constructors which + contain proofs. Changes from 8.7+beta2 to 8.7.0 =============================== diff --git a/dev/base_include b/dev/base_include index 79ecd73e0d..f2912e1127 100644 --- a/dev/base_include +++ b/dev/base_include @@ -233,8 +233,7 @@ let _ = Flags.in_toplevel := true let _ = Constrextern.set_extern_reference (fun ?loc _ r -> Libnames.Qualid (loc,Nametab.shortest_qualid_of_global Idset.empty r));; -open Coqloop -let go = loop +let go () = Coqloop.loop Option.(get !Coqtop.drop_last_doc) let _ = print_string diff --git a/dev/bugzilla2github_stripped.csv b/dev/bugzilla2github_stripped.csv new file mode 100644 index 0000000000..3f5cbfd71d --- /dev/null +++ b/dev/bugzilla2github_stripped.csv @@ -0,0 +1,501 @@ +2, 1156 +3, 1157 +4, 1158 +7, 1160 +8, 1161 +10, 1163 +12, 1164 +13, 1165 +14, 1169 +16, 1171 +17, 1184 +18, 1190 +19, 1191 +20, 1193 +21, 1200 +23, 1201 +24, 1203 +25, 1208 +26, 1210 +27, 1212 +28, 1216 +30, 1217 +31, 1223 +34, 1227 +35, 1232 +36, 1235 +38, 1238 +39, 1244 +40, 1245 +41, 1246 +42, 1247 +44, 1248 +45, 1249 +46, 1250 +47, 1252 +48, 1253 +49, 1254 +50, 1256 +52, 1262 +54, 1263 +55, 1264 +56, 1265 +59, 1266 +60, 1267 +61, 1268 +63, 1270 +64, 1272 +65, 1274 +66, 1275 +69, 1276 +70, 1279 +71, 1283 +72, 1284 +73, 1285 +74, 1286 +75, 1287 +78, 1288 +79, 1291 +80, 1292 +82, 1293 +83, 1295 +84, 1296 +85, 1297 +86, 1299 +88, 1301 +89, 1303 +90, 1304 +91, 1305 +92, 1307 +93, 1308 +94, 1310 +95, 1312 +96, 1313 +97, 1314 +98, 1316 +99, 1318 +100, 1319 +101, 1320 +102, 1321 +103, 1323 +105, 1324 +106, 1327 +107, 1328 +108, 1330 +109, 1334 +112, 1335 +115, 1336 +119, 1337 +121, 1341 +123, 1342 +124, 1343 +125, 1344 +126, 1345 +127, 1346 +128, 1348 +129, 1349 +134, 1350 +135, 1351 +136, 1352 +137, 1353 +138, 1354 +139, 1355 +140, 1356 +142, 1357 +143, 1358 +144, 1359 +145, 1360 +147, 1361 +148, 1362 +149, 1363 +150, 1365 +152, 1366 +154, 1368 +155, 1369 +160, 1370 +161, 1371 +162, 1372 +164, 1373 +165, 1374 +166, 1376 +167, 1377 +169, 1378 +170, 1380 +178, 1382 +179, 1383 +180, 1384 +181, 1385 +182, 1386 +183, 1387 +184, 1390 +185, 1391 +186, 1392 +187, 1393 +189, 1394 +190, 1398 +191, 1401 +192, 1402 +194, 1403 +195, 1404 +196, 1405 +197, 1407 +198, 1409 +199, 1410 +202, 1412 +204, 1413 +205, 1421 +207, 1422 +209, 1423 +210, 1426 +212, 1427 +213, 1428 +214, 1429 +215, 1433 +216, 1435 +219, 1436 +220, 1437 +221, 1440 +222, 1444 +224, 1445 +225, 1450 +228, 1452 +229, 1453 +235, 1457 +236, 1458 +238, 1459 +239, 1460 +240, 1462 +242, 1465 +243, 1466 +244, 1470 +245, 1471 +248, 1472 +250, 1473 +253, 1474 +254, 1475 +259, 1476 +261, 1478 +262, 1479 +263, 1480 +264, 1481 +265, 1484 +266, 1485 +267, 1486 +268, 1488 +269, 1489 +270, 1490 +271, 1492 +272, 1493 +273, 1494 +274, 1498 +275, 1500 +277, 1503 +278, 1504 +279, 1505 +282, 1506 +283, 1511 +289, 1513 +290, 1514 +291, 1516 +292, 1517 +294, 1520 +295, 1521 +299, 1523 +301, 1524 +302, 1525 +303, 1527 +305, 1529 +311, 1530 +315, 1531 +316, 1532 +317, 1534 +320, 1535 +322, 1539 +324, 1541 +328, 1542 +329, 1543 +330, 1544 +331, 1545 +333, 1546 +335, 1547 +336, 1548 +338, 1549 +343, 1550 +348, 1551 +350, 1552 +351, 1553 +352, 1554 +353, 1555 +356, 1556 +363, 1557 +368, 1558 +371, 1559 +372, 1560 +413, 1561 +418, 1562 +420, 1563 +426, 1564 +431, 1565 +444, 1566 +447, 1567 +452, 1569 +459, 1570 +462, 1571 +463, 1573 +468, 1574 +472, 1575 +473, 1577 +509, 1578 +519, 1579 +529, 1580 +540, 1581 +541, 1583 +545, 1584 +546, 1585 +547, 1589 +550, 1590 +552, 1591 +553, 1592 +554, 1593 +574, 1594 +592, 1595 +602, 1597 +603, 1598 +606, 1599 +607, 1600 +667, 1601 +668, 1602 +686, 1603 +690, 1605 +699, 1606 +705, 1607 +708, 1609 +711, 1610 +728, 1611 +739, 1612 +742, 1613 +743, 1615 +774, 1617 +775, 1619 +776, 1623 +777, 1624 +778, 1625 +779, 1627 +780, 1628 +781, 1629 +782, 1630 +783, 1631 +784, 1632 +785, 1633 +786, 1636 +787, 1637 +788, 1638 +789, 1639 +790, 1640 +793, 1641 +794, 1642 +795, 1644 +797, 1645 +798, 1646 +803, 1647 +804, 1649 +805, 1650 +808, 1652 +813, 1653 +815, 1655 +816, 1656 +818, 1657 +820, 1658 +821, 1659 +822, 1660 +823, 1661 +826, 1662 +828, 1663 +829, 1664 +830, 1665 +831, 1666 +832, 1667 +834, 1668 +835, 1669 +836, 1670 +837, 5689 +839, 5791 +840, 5792 +841, 5793 +842, 5794 +843, 5795 +844, 5796 +846, 5797 +849, 5798 +850, 5799 +854, 5800 +855, 5801 +856, 5802 +857, 5803 +860, 5804 +861, 5805 +862, 5806 +863, 5807 +864, 5808 +865, 5809 +867, 5810 +868, 5811 +869, 5812 +870, 5813 +871, 5814 +872, 5815 +874, 5816 +875, 5817 +878, 5818 +879, 5819 +881, 5820 +883, 5821 +884, 5822 +885, 5823 +886, 5824 +888, 5825 +889, 5826 +890, 5827 +891, 5828 +892, 5829 +893, 5830 +894, 5831 +896, 5832 +898, 5833 +901, 5834 +903, 5835 +905, 5836 +906, 5837 +909, 5838 +914, 5839 +915, 5840 +922, 5841 +923, 5842 +925, 5843 +927, 5844 +931, 5845 +932, 5846 +934, 5847 +935, 5848 +936, 5849 +937, 5850 +938, 5851 +939, 5852 +940, 5853 +941, 5854 +945, 5855 +946, 5856 +947, 5857 +949, 5858 +950, 5859 +951, 5860 +952, 5861 +953, 5862 +954, 5863 +957, 5864 +960, 5865 +963, 5866 +965, 5867 +967, 5868 +968, 5869 +969, 5870 +972, 5871 +973, 5872 +974, 5873 +975, 5874 +976, 5875 +977, 5876 +979, 5877 +983, 5878 +984, 5879 +985, 5880 +986, 5881 +987, 5882 +988, 5883 +990, 5884 +991, 5885 +993, 5886 +996, 5887 +997, 5888 +1000, 5889 +1001, 5890 +1002, 5891 +1003, 5892 +1004, 5893 +1005, 5894 +1006, 5895 +1007, 5896 +1010, 5897 +1012, 5898 +1013, 5899 +1014, 5900 +1015, 5901 +1016, 5902 +1017, 5903 +1018, 5904 +1025, 5905 +1028, 5906 +1029, 5907 +1030, 5908 +1031, 5909 +1033, 5910 +1035, 5911 +1036, 5912 +1037, 5913 +1039, 5914 +1041, 5915 +1042, 5916 +1044, 5917 +1045, 5918 +1052, 5919 +1053, 5920 +1054, 5921 +1055, 5922 +1056, 5923 +1060, 5924 +1064, 5925 +1067, 5926 +1070, 5927 +1072, 5928 +1075, 5929 +1076, 5930 +1085, 5931 +1086, 5932 +1087, 5933 +1089, 5934 +1091, 5935 +1096, 5936 +1097, 5937 +1098, 5938 +1099, 5939 +1100, 5940 +1101, 5941 +1102, 5942 +1104, 5943 +1107, 5944 +1108, 5945 +1111, 5946 +1113, 5947 +1114, 5948 +1115, 5949 +1116, 5950 +1118, 5951 +1119, 5952 +1120, 5953 +1122, 5954 +1123, 5955 +1124, 5956 +1128, 5957 +1129, 5958 +1132, 5959 +1136, 5960 +1137, 5961 +1138, 5962 +1140, 5963 +1141, 5964 +1142, 5965 +1144, 5966 +1145, 5967 +1149, 5968 +1151, 5969 +1153, 5970 diff --git a/dev/build/windows/MakeCoq_regtest_noproxy.bat b/dev/build/windows/MakeCoq_regtest_noproxy.bat index 7b17e721b3..7140a7c619 100644 --- a/dev/build/windows/MakeCoq_regtest_noproxy.bat +++ b/dev/build/windows/MakeCoq_regtest_noproxy.bat @@ -25,5 +25,5 @@ call MakeCoq_MinGW.bat ^ -cygquiet=Y ^
-destcyg %ROOTPATH%\cygwin_coq64_85pl2_abs ^
-destcoq %ROOTPATH%\coq64_85pl2_abs
- -pause
\ No newline at end of file +
+pause
diff --git a/dev/build/windows/configure_profile.sh b/dev/build/windows/configure_profile.sh index 0b61a31e7f..16c972e80c 100644 --- a/dev/build/windows/configure_profile.sh +++ b/dev/build/windows/configure_profile.sh @@ -40,4 +40,4 @@ if [ ! -f $donefile ] ; then echo unset OCAMLLIB >> $rcfile touch $donefile -fi
\ No newline at end of file +fi diff --git a/dev/build/windows/patches_coq/ln.c b/dev/build/windows/patches_coq/ln.c index 5e02c72bb7..41f64f98b2 100644 --- a/dev/build/windows/patches_coq/ln.c +++ b/dev/build/windows/patches_coq/ln.c @@ -134,4 +134,4 @@ int WINAPI WinMain( HINSTANCE hInstance, HINSTANCE hPrevInstance, LPSTR lpCmdLin // Everything is fine return 0; -}
\ No newline at end of file +} diff --git a/dev/doc/changes.md b/dev/doc/changes.md index 8a2a2fffc6..5be8257e87 100644 --- a/dev/doc/changes.md +++ b/dev/doc/changes.md @@ -1,5 +1,17 @@ ## Changes between Coq 8.7 and Coq 8.8 +### Bug tracker + +As of 18/10/2017, Coq uses [GitHub issues](https://github.com/coq/coq/issues) +as bug tracker. +Old bug reports were migrated from Bugzilla to GitHub issues using +[this migration script](https://gist.github.com/Zimmi48/d923e52f64fe17c72852d9c148bfcdc6#file-bugzilla2github) +as detailed in [this blog post](https://www.theozimmermann.net/2017/10/bugzilla-to-github/). + +All the bugs with a number below 1154 had to be renumbered, you can find +a correspondence table [here](/dev/bugzilla2github_stripped.csv). +All the other bugs kept their number. + ### Plugin API Coq 8.8 offers a new module overlay containing a proposed plugin API @@ -32,6 +44,19 @@ We renamed the following datatypes: - `Pp.std_ppcmds` -> `Pp.t` +Some tactics and related functions now support static configurability, e.g.: + +- injectable, dEq, etc. takes an argument ~keep_proofs which, + - if None, tells to behave as told with the flag Keep Proof Equalities + - if Some b, tells to keep proof equalities iff b is true + +Declaration of printers for arguments used only in vernac command + +- It should now use "declare_extra_vernac_genarg_pprule" rather than + "declare_extra_genarg_pprule", otherwise, a failure at runtime might + happen. An alternative is to register the corresponding argument as + a value, using "Geninterp.register_val0 wit None". + ## Changes between Coq 8.6 and Coq 8.7 ### Ocaml diff --git a/dev/doc/versions-history.tex b/dev/doc/versions-history.tex index 492e75a7bb..3867d4af90 100644 --- a/dev/doc/versions-history.tex +++ b/dev/doc/versions-history.tex @@ -376,9 +376,27 @@ Coq V8.5 beta1 & released 21 January 2015 & \feature{computation via compilation && \feature{new proof engine deployed} [2-11-2013]\\ && \feature{universe polymorphism} [6-5-2014]\\ && \feature{primitive projections} [6-5-2014]\\ +&& \feature{miscellaneous optimizations}\\ Coq V8.5 beta2 & released 22 April 2015 & \feature{MMaps library} [4-3-2015]\\ +Coq V8.5 & released 22 January 2016 & \\ + +Coq V8.6 beta 1 & released 19 November 2016 & \feature{irrefutable patterns} [15-2-2016]\\ +&& \feature{Ltac profiling} [14-6-2016]\\ +&& \feature{warning system} [29-6-2016]\\ +&& \feature{miscellaneous optimizations}\\ + +Coq V8.6 & released 14 December 2016 & \\ + +Coq V8.7 beta 1 & released 6 September 2017 & \feature{bundled with Ssreflect plugin} [6-6-2017]\\ +&& \feature{cumulative polymorphic inductive types} [19-6-2017]\\ +&& \feature{further optimizations}\\ + +Coq V8.7 beta 2 & released 6 October 2017 & \\ + +Coq V8.7 & released 18 October 2016 & \\ + \end{tabular} \medskip diff --git a/dev/lint-commits.sh b/dev/lint-commits.sh new file mode 100755 index 0000000000..eb12bc2273 --- /dev/null +++ b/dev/lint-commits.sh @@ -0,0 +1,32 @@ +#!/usr/bin/env bash + +# A script to check prettyness for a range of commits + +CALLNAME="$0" + +function usage +{ + >&2 echo "usage: $CALLNAME <commit> <commit>" + >&2 echo "The order of commits is as given to 'git diff'" +} + +if [ "$#" != 2 ]; +then + usage + exit 1 +fi + +BASE_COMMIT="$1" +HEAD_COMMIT="$2" + +# git diff --check +# uses .gitattributes to know what to check +if git diff --check "$BASE_COMMIT" "$HEAD_COMMIT"; +then + : +else + >&2 echo "Whitespace errors!" + >&2 echo "Running 'git diff --check $BASE_COMMIT $HEAD_COMMIT'." + >&2 echo "If you use emacs, you can prevent this kind of error from reocurring by installing ws-butler and enabling ws-butler-convert-leading-tabs-or-spaces." + exit 1 +fi diff --git a/dev/lint-repository.sh b/dev/lint-repository.sh new file mode 100755 index 0000000000..ecf7880e20 --- /dev/null +++ b/dev/lint-repository.sh @@ -0,0 +1,28 @@ +#!/usr/bin/env bash + +# A script to check prettyness over the repository. + +# lint-commits.sh seeks to prevent the worsening of already present +# problems, such as tab indentation in ml files. lint-repository.sh +# seeks to prevent the (re-)introduction of solved problems, such as +# newlines at the end of .v files. + +CODE=0 + +if [ "(" "-n" "${TRAVIS_PULL_REQUEST}" ")" "-a" "(" "${TRAVIS_PULL_REQUEST}" "!=" "false" ")" ]; +then + # Some problems are too widespread to fix in one commit, but we + # can still check that they don't worsen. + CUR_HEAD=${TRAVIS_COMMIT_RANGE%%...*} + PR_HEAD=${TRAVIS_COMMIT_RANGE##*...} + MERGE_BASE=$(git merge-base $CUR_HEAD $PR_HEAD) + dev/lint-commits.sh $MERGE_BASE $PR_HEAD || CODE=1 +fi + +# Check that the files with 'whitespace' gitattribute end in a newline. +# xargs exit status is 123 if any file failed the test +find . "(" -path ./.git -prune ")" -type f \ +-o "(" -exec dev/tools/should-check-whitespace.sh '{}' ';' ")" \ +-print0 | xargs -0 -L 1 dev/tools/check-eof-newline.sh || CODE=1 + +exit $CODE diff --git a/dev/nsis/FileAssociation.nsh b/dev/nsis/FileAssociation.nsh index b8c1e5ee78..71a9162efc 100644 --- a/dev/nsis/FileAssociation.nsh +++ b/dev/nsis/FileAssociation.nsh @@ -187,4 +187,4 @@ NoOwn: !verbose pop !macroend -!endif # !FileAssociation_INCLUDED
\ No newline at end of file +!endif # !FileAssociation_INCLUDED diff --git a/dev/tools/check-eof-newline.sh b/dev/tools/check-eof-newline.sh new file mode 100755 index 0000000000..1c578c05ce --- /dev/null +++ b/dev/tools/check-eof-newline.sh @@ -0,0 +1,9 @@ +#!/usr/bin/env bash + +if [ -z "$(tail -c 1 "$1")" ] +then + exit 0 +else + echo "No newline at end of file $1!" + exit 1 +fi diff --git a/dev/tools/should-check-whitespace.sh b/dev/tools/should-check-whitespace.sh new file mode 100755 index 0000000000..8159506b41 --- /dev/null +++ b/dev/tools/should-check-whitespace.sh @@ -0,0 +1,5 @@ +#!/usr/bin/env bash + +# determine if a file has whitespace checking enabled in .gitattributes + +git check-attr whitespace -- "$1" | grep -q -v 'unspecified$' diff --git a/dev/top_printers.ml b/dev/top_printers.ml index ffa8fffdf5..35956477df 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -108,8 +108,7 @@ let ppconstrunderbindersidmap l = pp (prconstrunderbindersidmap l) let ppunbound_ltac_var_map l = ppidmap (fun _ arg -> str"<genarg:" ++ pr_argument_type(genarg_tag arg) ++ str">") -open Glob_term - +open Ltac_pretype let rec pr_closure {idents=idents;typed=typed;untyped=untyped} = hov 1 (str"{idents=" ++ prididmap idents ++ str";" ++ spc() ++ str"typed=" ++ prconstrunderbindersidmap typed ++ str";" ++ spc() ++ @@ -504,7 +503,7 @@ let _ = (function [c] when genarg_tag c = unquote (topwit wit_constr) && true -> let c = out_gen (rawwit wit_constr) c in - (fun () -> in_current_context constr_display c) + (fun _ -> in_current_context constr_display c) | _ -> failwith "Vernac extension: cannot occur") with e -> pp (CErrors.print e) @@ -520,7 +519,7 @@ let _ = (function [c] when genarg_tag c = unquote (topwit wit_constr) && true -> let c = out_gen (rawwit wit_constr) c in - (fun () -> in_current_context print_pure_constr c) + (fun _ -> in_current_context print_pure_constr c) | _ -> failwith "Vernac extension: cannot occur") with e -> pp (CErrors.print e) diff --git a/doc/common/styles/html/simple/style.css b/doc/common/styles/html/simple/style.css index 0b1e640b38..d1b2ce1112 100644 --- a/doc/common/styles/html/simple/style.css +++ b/doc/common/styles/html/simple/style.css @@ -10,4 +10,4 @@ margin: 0pt; padding: .5ex 1em; list-style: none -}
\ No newline at end of file +} diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 0dbfe05d48..2695c5eee4 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -883,56 +883,60 @@ the type $V$ satisfies the nested positivity condition for $X$ \settowidth\framecharacterwidth{\hh} \newcommand\ws{\hbox{}\hskip\the\framecharacterwidth} \newcommand\ruleref[1]{\hskip.25em\dots\hskip.2em{\em (bullet #1)}} +\newcommand{\NatTree}{\mbox{\textsf{nattree}}} +\newcommand{\NatTreeA}{\mbox{\textsf{nattree}}~\ensuremath{A}} +\newcommand{\cnode}{\mbox{\textsf{node}}} +\newcommand{\cleaf}{\mbox{\textsf{leaf}}} -\noindent For instance, if one considers the type +\noindent For instance, if one considers the following variant of a tree type branching over the natural numbers \begin{verbatim} -Inductive tree (A:Type) : Type := - | leaf : list A - | node : A -> (nat -> tree A) -> tree A +Inductive nattree (A:Type) : Type := + | leaf : nattree A + | node : A -> (nat -> nattree A) -> nattree A \end{verbatim} \begin{latexonly} -\noindent Then every instantiated constructor of $\ListA$ satisfies the nested positivity condition for $\List$\\ +\noindent Then every instantiated constructor of $\NatTreeA$ satisfies the nested positivity condition for $\NatTree$\\ \noindent \ws\ws\vv\\ -\ws\ws\vh\hh\ws concerning type $\ListA$ of constructor $\Nil$:\\ -\ws\ws\vv\ws\ws\ws\ws Type $\ListA$ of constructor $\Nil$ satisfies the positivity condition for $\List$\\ -\ws\ws\vv\ws\ws\ws\ws because $\List$ does not appear in any (real) arguments of the type of that constructor\\ -\ws\ws\vv\ws\ws\ws\ws (primarily because $\List$ does not have any (real) arguments)\ruleref1\\ +\ws\ws\vh\hh\ws concerning type $\NatTreeA$ of constructor $\cleaf$:\\ +\ws\ws\vv\ws\ws\ws\ws Type $\NatTreeA$ of constructor $\cleaf$ satisfies the positivity condition for $\NatTree$\\ +\ws\ws\vv\ws\ws\ws\ws because $\NatTree$ does not appear in any (real) arguments of the type of that constructor\\ +\ws\ws\vv\ws\ws\ws\ws (primarily because $\NatTree$ does not have any (real) arguments)\ruleref1\\ \ws\ws\vv\\ -\ws\ws\hv\hh\ws concerning type $\forall~A\ra\ListA\ra\ListA$ of constructor $\cons$:\\ -\ws\ws\ws\ws\ws\ws\ws Type $\forall~A:\Type,A\ra\ListA\ra\ListA$ of constructor $\cons$\\ -\ws\ws\ws\ws\ws\ws\ws satisfies the positivity condition for $\List$ because:\\ +\ws\ws\hv\hh\ws concerning type $\forall~A\ra(\NN\ra\NatTreeA)\ra\NatTreeA$ of constructor $\cnode$:\\ + \ws\ws\ws\ws\ws\ws\ws Type $\forall~A:\Type,A\ra(\NN\ra\NatTreeA)\ra\NatTreeA$ of constructor $\cnode$\\ +\ws\ws\ws\ws\ws\ws\ws satisfies the positivity condition for $\NatTree$ because:\\ \ws\ws\ws\ws\ws\ws\ws\vv\\ -\ws\ws\ws\ws\ws\ws\ws\vh\hh\ws $\List$ occurs only strictly positively in $\Type$\ruleref3\\ +\ws\ws\ws\ws\ws\ws\ws\vh\hh\ws $\NatTree$ occurs only strictly positively in $\Type$\ruleref1\\ \ws\ws\ws\ws\ws\ws\ws\vv\\ -\ws\ws\ws\ws\ws\ws\ws\vh\hh\ws $\List$ occurs only strictly positively in $A$\ruleref3\\ +\ws\ws\ws\ws\ws\ws\ws\vh\hh\ws $\NatTree$ occurs only strictly positively in $A$\ruleref1\\ \ws\ws\ws\ws\ws\ws\ws\vv\\ -\ws\ws\ws\ws\ws\ws\ws\vh\hh\ws $\List$ occurs only strictly positively in $\ListA$\ruleref4\\ + \ws\ws\ws\ws\ws\ws\ws\vh\hh\ws $\NatTree$ occurs only strictly positively in $\NN\ra\NatTreeA$\ruleref{3+2}\\ \ws\ws\ws\ws\ws\ws\ws\vv\\ -\ws\ws\ws\ws\ws\ws\ws\hv\hh\ws $\List$ satisfies the positivity condition for $\ListA$\ruleref1 +\ws\ws\ws\ws\ws\ws\ws\hv\hh\ws $\NatTree$ satisfies the positivity condition for $\NatTreeA$\ruleref1 \end{latexonly} \begin{rawhtml} <pre> -<span style="font-family:serif">Then every instantiated constructor of <span style="font-family:monospace">list A</span> satisfies the nested positivity condition for <span style="font-family:monospace">list</span></span> +<span style="font-family:serif">Then every instantiated constructor of <span style="font-family:monospace">nattree A</span> satisfies the nested positivity condition for <span style="font-family:monospace">nattree</span></span> │ - ├─ <span style="font-family:serif">concerning type <span style="font-family:monospace">list A</span> of constructor <span style="font-family:monospace">nil</span>:</span> - │ <span style="font-family:serif">Type <span style="font-family:monospace">list A</span> of constructor <span style="font-family:monospace">nil</span> satisfies the positivity condition for <span style="font-family:monospace">list</span></span> - │ <span style="font-family:serif">because <span style="font-family:monospace">list</span> does not appear in any (real) arguments of the type of that constructor</span> - │ <span style="font-family:serif">(primarily because list does not have any (real) arguments) ... <span style="font-style:italic">(bullet 1)</span></span> + ├─ <span style="font-family:serif">concerning type <span style="font-family:monospace">nattree A</span> of constructor <span style="font-family:monospace">nil</span>:</span> + │ <span style="font-family:serif">Type <span style="font-family:monospace">nattree A</span> of constructor <span style="font-family:monospace">nil</span> satisfies the positivity condition for <span style="font-family:monospace">nattree</span></span> + │ <span style="font-family:serif">because <span style="font-family:monospace">nattree</span> does not appear in any (real) arguments of the type of that constructor</span> + │ <span style="font-family:serif">(primarily because nattree does not have any (real) arguments) ... <span style="font-style:italic">(bullet 1)</span></span> │ - ╰─ <span style="font-family:serif">concerning type <span style="font-family:monospace">∀ A → list A → list A</span> of constructor <span style="font-family:monospace">cons</span>:</span> - <span style="font-family:serif">Type <span style="font-family:monospace">∀ A : Type, A → list A → list A</span> of constructor <span style="font-family:monospace">cons</span></span> - <span style="font-family:serif">satisfies the positivity condition for <span style="font-family:monospace">list</span> because:</span> + ╰─ <span style="font-family:serif">concerning type <span style="font-family:monospace">∀ A → (nat → nattree A) → nattree A</span> of constructor <span style="font-family:monospace">cons</span>:</span> + <span style="font-family:serif">Type <span style="font-family:monospace">∀ A : Type, A → (nat → nattree A) → nattree A</span> of constructor <span style="font-family:monospace">cons</span></span> + <span style="font-family:serif">satisfies the positivity condition for <span style="font-family:monospace">nattree</span> because:</span> │ - ├─ <span style="font-family:serif"><span style="font-family:monospace">list</span> occurs only strictly positively in <span style="font-family:monospace">Type</span> ... <span style="font-style:italic">(bullet 3)</span></span> + ├─ <span style="font-family:serif"><span style="font-family:monospace">nattree</span> occurs only strictly positively in <span style="font-family:monospace">Type</span> ... <span style="font-style:italic">(bullet 1)</span></span> │ - ├─ <span style="font-family:serif"><span style="font-family:monospace">list</span> occurs only strictly positively in <span style="font-family:monospace">A</span> ... <span style="font-style:italic">(bullet 3)</span></span> + ├─ <span style="font-family:serif"><span style="font-family:monospace">nattree</span> occurs only strictly positively in <span style="font-family:monospace">A</span> ... <span style="font-style:italic">(bullet 1)</span></span> │ - ├─ <span style="font-family:serif"><span style="font-family:monospace">list</span> occurs only strictly positively in <span style="font-family:monospace">list A</span> ... <span style="font-style:italic">(bullet 4)</span></span> + ├─ <span style="font-family:serif"><span style="font-family:monospace">nattree</span> occurs only strictly positively in <span style="font-family:monospace">nat → nattree A</span> ... <span style="font-style:italic">(bullet 3+2)</span></span> │ - ╰─ <span style="font-family:serif"><span style="font-family:monospace">list</span> satisfies the positivity condition for <span style="font-family:monospace">list A</span> ... <span style="font-style:italic">(bullet 1)</span></span> + ╰─ <span style="font-family:serif"><span style="font-family:monospace">nattree</span> satisfies the positivity condition for <span style="font-family:monospace">nattree A</span> ... <span style="font-style:italic">(bullet 1)</span></span> </pre> \end{rawhtml} diff --git a/doc/refman/RefMan-ext.tex b/doc/refman/RefMan-ext.tex index b27a4dc943..5c519e46e3 100644 --- a/doc/refman/RefMan-ext.tex +++ b/doc/refman/RefMan-ext.tex @@ -1840,6 +1840,9 @@ This is useful for declaring the implicit type of a single variable. \subsection{Implicit generalization \label{implicit-generalization} \comindex{Generalizable Variables}} +% \textquoteleft since \` doesn't do what we want +\index{0genimpl@{\textquoteleft\{\ldots\}}} +\index{0genexpl@{\textquoteleft(\ldots)}} Implicit generalization is an automatic elaboration of a statement with free variables into a closed statement where these variables are diff --git a/doc/refman/RefMan-gal.tex b/doc/refman/RefMan-gal.tex index df0cd2b825..41ea0a5dcd 100644 --- a/doc/refman/RefMan-gal.tex +++ b/doc/refman/RefMan-gal.tex @@ -434,6 +434,7 @@ be shortened in {\tt fun~x~y~z~:~A~=>~t}). \subsection{Abstractions \label{abstractions} \index{abstractions}} +\index{fun@{{\tt fun \ldots => \ldots}}} The expression ``{\tt fun} {\ident} {\tt :} {\type} {\tt =>}~{\term}'' defines the {\em abstraction} of the variable {\ident}, of type @@ -455,6 +456,7 @@ occurs in the list of binders, it is expanded to a let-in definition \subsection{Products \label{products} \index{products}} +\index{forall@{{\tt forall \ldots, \ldots}}} The expression ``{\tt forall}~{\ident}~{\tt :}~{\type}{\tt ,}~{\term}'' denotes the {\em product} of the variable {\ident} of @@ -495,6 +497,7 @@ arguments is used for making explicit the value of implicit arguments \subsection{Type cast \label{typecast} \index{Cast}} +\index{cast@{{\tt(\ldots: \ldots)}}} The expression ``{\term}~{\tt :}~{\type}'' is a type cast expression. It enforces the type of {\term} to be {\type}. @@ -514,6 +517,7 @@ symbol ``\_'' and {\Coq} will guess the missing piece of information. \label{let-in} \index{Let-in definitions} \index{let-in}} +\index{let@{{\tt let \ldots := \ldots in \ldots}}} {\tt let}~{\ident}~{\tt :=}~{\term$_1$}~{\tt in}~{\term$_2$} denotes diff --git a/doc/refman/RefMan-tac.tex b/doc/refman/RefMan-tac.tex index a2d45046b0..675c2bf174 100644 --- a/doc/refman/RefMan-tac.tex +++ b/doc/refman/RefMan-tac.tex @@ -3523,8 +3523,13 @@ with its $\beta\iota$-normal form. \end{ErrMsgs} \begin{Variants} +\item {\tt unfold {\qualid} in {\ident}} + \tacindex{unfold \dots in} + + Replaces {\qualid} in hypothesis {\ident} with its definition + and replaces the hypothesis with its $\beta\iota$ normal form. + \item {\tt unfold {\qualid}$_1$, \dots, \qualid$_n$} - \tacindex{unfold \dots\ in} Replaces {\em simultaneously} {\qualid}$_1$, \dots, {\qualid}$_n$ with their definitions and replaces the current goal with its @@ -3836,6 +3841,26 @@ this tactic. % En attente d'un moyen de valoriser les fichiers de demos %\SeeAlso file \texttt{contrib/Rocq/DEMOS/Demo\_AutoRewrite.v} +\subsection{\tt easy} +\tacindex{easy} +\label{easy} + +This tactic tries to solve the current goal by a number of standard closing steps. +In particular, it tries to close the current goal using the closing tactics +{\tt trivial}, reflexivity, symmetry, contradiction and inversion of hypothesis. +If this fails, it tries introducing variables and splitting and-hypotheses, +using the closing tactics afterwards, and splitting the goal using {\tt split} and recursing. + +This tactic solves goals that belong to many common classes; in particular, many cases of +unsatisfiable hypotheses, and simple equality goals are usually solved by this tactic. + +\begin{Variant} +\item {\tt now \tac} + \tacindex{now} + + Run \tac\/ followed by easy. This is a notation for {\tt \tac; easy}. +\end{Variant} + \section{Controlling automation} \subsection{The hints databases for {\tt auto} and {\tt eauto}} diff --git a/doc/refman/index.html b/doc/refman/index.html index 9b5250abcb..b937350e6e 100644 --- a/doc/refman/index.html +++ b/doc/refman/index.html @@ -11,4 +11,4 @@ <FRAME SRC="menu.html"> </FRAMESET> -</HTML>
\ No newline at end of file +</HTML> diff --git a/engine/evarutil.ml b/engine/evarutil.ml index eabfb7b398..38efcca050 100644 --- a/engine/evarutil.ml +++ b/engine/evarutil.ml @@ -306,7 +306,7 @@ let push_rel_decl_to_named_context sigma decl (subst, vsubst, avoid, nc) = in let extract_if_neq id = function | Anonymous -> None - | Name id' when id_ord id id' = 0 -> None + | Name id' when Id.compare id id' = 0 -> None | Name id' -> Some id' in let na = RelDecl.get_name decl in diff --git a/engine/evarutil.mli b/engine/evarutil.mli index ee0fae3d46..2f85bc7335 100644 --- a/engine/evarutil.mli +++ b/engine/evarutil.mli @@ -223,7 +223,7 @@ val push_rel_decl_to_named_context : evar_map -> rel_declaration -> ext_named_context -> ext_named_context val push_rel_context_to_named_context : Environ.env -> evar_map -> types -> - named_context_val * types * constr list * csubst * (identifier*constr) list + named_context_val * types * constr list * csubst * (Id.t*constr) list val generalize_evar_over_rels : evar_map -> existential -> types * constr list diff --git a/engine/evd.ml b/engine/evd.ml index 324f883e8e..86ab2263f5 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -124,8 +124,7 @@ end (* The type of mappings for existential variables *) -module Dummy = struct end -module Store = Store.Make(Dummy) +module Store = Store.Make () type evar = Term.existential_key @@ -371,17 +370,17 @@ val key : Id.t -> t -> Evar.t end = struct -type t = Id.t EvMap.t * existential_key Idmap.t +type t = Id.t EvMap.t * existential_key Id.Map.t -let empty = (EvMap.empty, Idmap.empty) +let empty = (EvMap.empty, Id.Map.empty) let add_name_newly_undefined id evk evi (evtoid, idtoev as names) = match id with | None -> names | Some id -> - if Idmap.mem id idtoev then + if Id.Map.mem id idtoev then user_err (str "Already an existential evar of name " ++ pr_id id); - (EvMap.add evk id evtoid, Idmap.add id evk idtoev) + (EvMap.add evk id evtoid, Id.Map.add id evk idtoev) let add_name_undefined naming evk evi (evtoid,idtoev as evar_names) = if EvMap.mem evk evtoid then @@ -393,15 +392,15 @@ let remove_name_defined evk (evtoid, idtoev as names) = let id = try Some (EvMap.find evk evtoid) with Not_found -> None in match id with | None -> names - | Some id -> (EvMap.remove evk evtoid, Idmap.remove id idtoev) + | Some id -> (EvMap.remove evk evtoid, Id.Map.remove id idtoev) let rename evk id (evtoid, idtoev) = let id' = try Some (EvMap.find evk evtoid) with Not_found -> None in match id' with - | None -> (EvMap.add evk id evtoid, Idmap.add id evk idtoev) + | None -> (EvMap.add evk id evtoid, Id.Map.add id evk idtoev) | Some id' -> - if Idmap.mem id idtoev then anomaly (str "Evar name already in use."); - (EvMap.update evk id evtoid (* overwrite old name *), Idmap.add id evk (Idmap.remove id' idtoev)) + if Id.Map.mem id idtoev then anomaly (str "Evar name already in use."); + (EvMap.update evk id evtoid (* overwrite old name *), Id.Map.add id evk (Id.Map.remove id' idtoev)) let reassign_name_defined evk evk' (evtoid, idtoev as names) = let id = try Some (EvMap.find evk evtoid) with Not_found -> None in @@ -409,13 +408,13 @@ let reassign_name_defined evk evk' (evtoid, idtoev as names) = | None -> names (** evk' must not be defined *) | Some id -> (EvMap.add evk' id (EvMap.remove evk evtoid), - Idmap.add id evk' (Idmap.remove id idtoev)) + Id.Map.add id evk' (Id.Map.remove id idtoev)) let ident evk (evtoid, _) = try Some (EvMap.find evk evtoid) with Not_found -> None let key id (_, idtoev) = - Idmap.find id idtoev + Id.Map.find id idtoev end diff --git a/engine/geninterp.ml b/engine/geninterp.ml index e79e258fbc..768ef3cfd9 100644 --- a/engine/geninterp.ml +++ b/engine/geninterp.ml @@ -9,11 +9,11 @@ open Names open Genarg -module TacStore = Store.Make(struct end) +module TacStore = Store.Make () (** Dynamic toplevel values *) -module ValT = Dyn.Make(struct end) +module ValT = Dyn.Make () module Val = struct @@ -47,6 +47,8 @@ struct end +module ValTMap = ValT.Map + module ValReprObj = struct type ('raw, 'glb, 'top) obj = 'top Val.tag diff --git a/engine/geninterp.mli b/engine/geninterp.mli index 492e372adb..ae0b26e594 100644 --- a/engine/geninterp.mli +++ b/engine/geninterp.mli @@ -39,6 +39,10 @@ sig val inject : 'a tag -> 'a -> t end + +module ValTMap (M : Dyn.TParam) : + Dyn.MapS with type 'a obj = 'a M.t with type 'a key = 'a Val.typ + (** Dynamic types for toplevel values. While the generic types permit to relate objects at various levels of interpretation, toplevel values are wearing their own type regardless of where they came from. This allows to use the diff --git a/engine/namegen.ml b/engine/namegen.ml index 2e62b89011..c548fc4ac9 100644 --- a/engine/namegen.ml +++ b/engine/namegen.ml @@ -132,8 +132,8 @@ let hdchar env sigma c = | Cast (c,_,_) | App (c,_) -> hdrec k c | Proj (kn,_) -> lowercase_first_char (Label.to_id (con_label (Projection.constant kn))) | Const (kn,_) -> lowercase_first_char (Label.to_id (con_label kn)) - | Ind (x,_) -> lowercase_first_char (basename_of_global (IndRef x)) - | Construct (x,_) -> lowercase_first_char (basename_of_global (ConstructRef x)) + | Ind (x,_) -> (try lowercase_first_char (basename_of_global (IndRef x)) with Not_found when !Flags.in_debugger -> "zz") + | Construct (x,_) -> (try lowercase_first_char (basename_of_global (ConstructRef x)) with Not_found when !Flags.in_debugger -> "zz") | Var id -> lowercase_first_char id | Sort s -> sort_hdchar (ESorts.kind sigma s) | Rel n -> @@ -376,15 +376,22 @@ let next_name_for_display sigma flags = | RenamingElsewhereFor env_t -> next_name_away_for_default_printing sigma env_t (* Remark: Anonymous var may be dependent in Evar's contexts *) -let compute_displayed_name_in sigma flags avoid na c = +let compute_displayed_name_in_gen_poly noccurn_fun sigma flags avoid na c = match na with - | Anonymous when noccurn sigma 1 c -> + | Anonymous when noccurn_fun sigma 1 c -> (Anonymous,avoid) | _ -> let fresh_id = next_name_for_display sigma flags na avoid in - let idopt = if noccurn sigma 1 c then Anonymous else Name fresh_id in + let idopt = if noccurn_fun sigma 1 c then Anonymous else Name fresh_id in (idopt, Id.Set.add fresh_id avoid) +let compute_displayed_name_in = compute_displayed_name_in_gen_poly noccurn + +let compute_displayed_name_in_gen f sigma = + (* only flag which does not need a constr, maybe to be refined *) + let flag = RenamingForGoal in + compute_displayed_name_in_gen_poly f sigma flag + let compute_and_force_displayed_name_in sigma flags avoid na c = match na with | Anonymous when noccurn sigma 1 c -> diff --git a/engine/namegen.mli b/engine/namegen.mli index 6fde90a39c..d29b69259f 100644 --- a/engine/namegen.mli +++ b/engine/namegen.mli @@ -106,10 +106,15 @@ val compute_displayed_name_in : val compute_and_force_displayed_name_in : evar_map -> renaming_flags -> Id.Set.t -> Name.t -> constr -> Name.t * Id.Set.t val compute_displayed_let_name_in : - evar_map -> renaming_flags -> Id.Set.t -> Name.t -> constr -> Name.t * Id.Set.t + evar_map -> renaming_flags -> Id.Set.t -> Name.t -> 'a -> Name.t * Id.Set.t val rename_bound_vars_as_displayed : evar_map -> Id.Set.t -> Name.t list -> types -> types +(* Generic function expecting a "not occurn" function *) +val compute_displayed_name_in_gen : + (evar_map -> int -> 'a -> bool) -> + evar_map -> Id.Set.t -> Name.t -> 'a -> Name.t * Id.Set.t + (**********************************************************************) (* Naming strategy for arguments in Prop when eliminating inductive types *) diff --git a/engine/termops.ml b/engine/termops.ml index b7fa2dc4a4..76f707f945 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -327,11 +327,11 @@ let pr_evar_constraints sigma pbs = Namegen.make_all_name_different env sigma in print_env_short env ++ spc () ++ str "|-" ++ spc () ++ - print_constr_env env sigma (EConstr.of_constr t1) ++ spc () ++ + protect (print_constr_env env sigma) (EConstr.of_constr t1) ++ spc () ++ str (match pbty with | Reduction.CONV -> "==" | Reduction.CUMUL -> "<=") ++ - spc () ++ print_constr_env env Evd.empty (EConstr.of_constr t2) + spc () ++ protect (print_constr_env env Evd.empty) (EConstr.of_constr t2) in prlist_with_sep fnl pr_evconstr pbs @@ -358,37 +358,37 @@ let pr_evar_list sigma l = h 0 (str (string_of_existential ev) ++ str "==" ++ pr_evar_info evi ++ (if evi.evar_body == Evar_empty - then str " {" ++ pr_existential_key sigma ev ++ str "}" + then str " {" ++ pr_existential_key sigma ev ++ str "}" else mt ())) in h 0 (prlist_with_sep fnl pr l) -let pr_evar_by_depth depth sigma = match depth with -| None -> - (* Print all evars *) - let to_list d = - let open Evd in - (* Workaround for change in Map.fold behavior in ocaml 3.08.4 *) - let l = ref [] in - let fold_def evk evi () = match evi.evar_body with +let to_list d = + let open Evd in + (* Workaround for change in Map.fold behavior in ocaml 3.08.4 *) + let l = ref [] in + let fold_def evk evi () = match evi.evar_body with | Evar_defined _ -> l := (evk, evi) :: !l | Evar_empty -> () - in - let fold_undef evk evi () = match evi.evar_body with + in + let fold_undef evk evi () = match evi.evar_body with | Evar_empty -> l := (evk, evi) :: !l | Evar_defined _ -> () - in - Evd.fold fold_def d (); - Evd.fold fold_undef d (); - !l in - str"EVARS:"++brk(0,1)++pr_evar_list sigma (to_list sigma)++fnl() -| Some n -> + Evd.fold fold_def d (); + Evd.fold fold_undef d (); + !l + +let pr_evar_by_depth depth sigma = match depth with +| None -> (* Print all evars *) + str"EVARS:" ++ brk(0,1) ++ pr_evar_list sigma (to_list sigma) ++ fnl() +| Some n -> + (* Print closure of undefined evars *) str"UNDEFINED EVARS:"++ (if Int.equal n 0 then mt() else str" (+level "++int n++str" closure):")++ brk(0,1)++ - pr_evar_list sigma (evar_dependency_closure n sigma)++fnl() + pr_evar_list sigma (evar_dependency_closure n sigma) ++ fnl() let pr_evar_by_filter filter sigma = let open Evd in diff --git a/grammar/argextend.mlp b/grammar/argextend.mlp index 12b7b171b7..9742a002d7 100644 --- a/grammar/argextend.mlp +++ b/grammar/argextend.mlp @@ -186,12 +186,7 @@ let declare_vernac_argument loc s pr cl = value ($lid:"wit_"^s$ : Genarg.genarg_type 'a unit unit) = Genarg.create_arg $se$ >>; make_extend loc s cl wit; - <:str_item< do { - Pptactic.declare_extra_genarg_pprule $wit$ - $pr_rules$ - (fun _ _ _ _ -> CErrors.anomaly (Pp.str "vernac argument needs not globwit printer.")) - (fun _ _ _ _ -> CErrors.anomaly (Pp.str "vernac argument needs not wit printer.")) } - >> ] + <:str_item< Pptactic.declare_extra_vernac_genarg_pprule $wit$ $pr_rules$ >> ] open Pcaml diff --git a/grammar/q_util.mlp b/grammar/q_util.mlp index 536ee7ca56..c2d767396a 100644 --- a/grammar/q_util.mlp +++ b/grammar/q_util.mlp @@ -94,10 +94,14 @@ let coincide s pat off = done; !break +let check_separator sep = + if sep <> "" then failwith "Separator is only for arguments with suffix _list_sep." + let rec parse_user_entry s sep = let l = String.length s in if l > 8 && coincide s "ne_" 0 && coincide s "_list" (l - 5) then let entry = parse_user_entry (String.sub s 3 (l-8)) "" in + check_separator sep; Ulist1 entry else if l > 12 && coincide s "ne_" 0 && coincide s "_list_sep" (l-9) then @@ -105,16 +109,20 @@ let rec parse_user_entry s sep = Ulist1sep (entry, sep) else if l > 5 && coincide s "_list" (l-5) then let entry = parse_user_entry (String.sub s 0 (l-5)) "" in + check_separator sep; Ulist0 entry else if l > 9 && coincide s "_list_sep" (l-9) then let entry = parse_user_entry (String.sub s 0 (l-9)) "" in Ulist0sep (entry, sep) else if l > 4 && coincide s "_opt" (l-4) then let entry = parse_user_entry (String.sub s 0 (l-4)) "" in + check_separator sep; Uopt entry else if l = 7 && coincide s "tactic" 0 && '5' >= s.[6] && s.[6] >= '0' then let n = Char.code s.[6] - 48 in + check_separator sep; Uentryl ("tactic", n) else let s = match s with "hyp" -> "var" | _ -> s in + check_separator sep; Uentry s diff --git a/grammar/vernacextend.mlp b/grammar/vernacextend.mlp index a529185dd6..874712124c 100644 --- a/grammar/vernacextend.mlp +++ b/grammar/vernacextend.mlp @@ -59,7 +59,7 @@ let make_clause_classifier cg s { r_patt = pt; r_class = c; } = | None, Some cg -> (make_patt pt, ploc_vala None, - <:expr< fun () -> $cg$ $str:s$ >>) + <:expr< fun loc -> $cg$ $str:s$ >>) | None, None -> prerr_endline (("Vernac entry \""^s^"\" misses a classifier. "^ "A classifier is a function that returns an expression "^ @@ -82,7 +82,7 @@ let make_clause_classifier cg s { r_patt = pt; r_class = c; } = "classifiers. Only one classifier is called.") ^ "\n"); (make_patt pt, ploc_vala None, - <:expr< fun () -> (Vernacexpr.VtUnknown, Vernacexpr.VtNow) >>) + <:expr< fun loc -> (Vernacexpr.VtUnknown, Vernacexpr.VtNow) >>) let make_fun_clauses loc s l = let map c = @@ -165,16 +165,16 @@ EXTEND [ [ "["; s = STRING; l = LIST0 args; "]"; d = OPT deprecation; c = OPT classifier; "->"; "["; e = Pcaml.expr; "]" -> let () = if s = "" then failwith "Command name is empty." in - let b = <:expr< fun () -> $e$ >> in + let b = <:expr< fun loc -> $e$ >> in { r_head = Some s; r_patt = l; r_class = c; r_branch = b; r_depr = d; } | "[" ; "-" ; l = LIST1 args ; "]" ; d = OPT deprecation; c = OPT classifier; "->"; "["; e = Pcaml.expr; "]" -> - let b = <:expr< fun () -> $e$ >> in + let b = <:expr< fun loc -> $e$ >> in { r_head = None; r_patt = l; r_class = c; r_branch = b; r_depr = d; } ] ] ; classifier: - [ [ "=>"; "["; c = Pcaml.expr; "]" -> <:expr< fun () -> $c$>> ] ] + [ [ "=>"; "["; c = Pcaml.expr; "]" -> <:expr< fun loc -> $c$>> ] ] ; args: [ [ e = LIDENT; "("; s = LIDENT; ")" -> diff --git a/ide/tags.ml b/ide/tags.ml index 08ca47a842..4020271798 100644 --- a/ide/tags.ml +++ b/ide/tags.ml @@ -15,33 +15,22 @@ let make_tag (tt:GText.tag_table) ~name prop = module Script = struct + (* More recently defined tags have highest priority in case of overlapping *) let table = GText.tag_table () - let comment = make_tag table ~name:"comment" [] - let error = make_tag table ~name:"error" [`UNDERLINE `SINGLE] let warning = make_tag table ~name:"warning" [`UNDERLINE `SINGLE; `FOREGROUND "blue"] + let error = make_tag table ~name:"error" [`UNDERLINE `SINGLE] let error_bg = make_tag table ~name:"error_bg" [] let to_process = make_tag table ~name:"to_process" [] let processed = make_tag table ~name:"processed" [] - let incomplete = make_tag table ~name:"incomplete" [ - `BACKGROUND_STIPPLE_SET true; - ] + let incomplete = make_tag table ~name:"incomplete" [`BACKGROUND_STIPPLE_SET true] let unjustified = make_tag table ~name:"unjustified" [`BACKGROUND "gold"] - let found = make_tag table ~name:"found" [`BACKGROUND "blue"; `FOREGROUND "white"] - let sentence = make_tag table ~name:"sentence" [] let tooltip = make_tag table ~name:"tooltip" [] (* debug:`BACKGROUND "blue" *) - let ephemere = [error; warning; error_bg; tooltip; processed; to_process; incomplete; unjustified] - - let all = - comment :: found :: sentence :: ephemere - - let edit_zone = - let t = make_tag table ~name:"edit_zone" [`UNDERLINE `SINGLE] in - t#set_priority (List.length all); - t - let all = edit_zone :: all - + let comment = make_tag table ~name:"comment" [] + let sentence = make_tag table ~name:"sentence" [] + let edit_zone = make_tag table ~name:"edit_zone" [`UNDERLINE `SINGLE] (* for debugging *) + let all = edit_zone :: comment :: sentence :: ephemere end module Proof = struct diff --git a/ide/tags.mli b/ide/tags.mli index 265dfe46e3..15a35185df 100644 --- a/ide/tags.mli +++ b/ide/tags.mli @@ -17,7 +17,6 @@ sig val processed : GText.tag val incomplete : GText.tag val unjustified : GText.tag - val found : GText.tag val sentence : GText.tag val tooltip : GText.tag val edit_zone : GText.tag (* for debugging *) diff --git a/interp/constrextern.ml b/interp/constrextern.ml index f1bee65ef8..bd6aa09111 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -1120,7 +1120,11 @@ let any_any_branch = (* | _ => _ *) Loc.tag ([],[DAst.make @@ PatVar Anonymous], DAst.make @@ GHole (Evar_kinds.InternalHole,Misctypes.IntroAnonymous,None)) -let rec glob_of_pat env sigma pat = DAst.make @@ match pat with +let compute_displayed_name_in_pattern sigma avoid na c = + let open Namegen in + compute_displayed_name_in_gen (fun _ -> Patternops.noccurn_pattern) sigma avoid na c + +let rec glob_of_pat avoid env sigma pat = DAst.make @@ match pat with | PRef ref -> GRef (ref,None) | PVar id -> GVar id | PEvar (evk,l) -> @@ -1130,7 +1134,7 @@ let rec glob_of_pat env sigma pat = DAst.make @@ match pat with | None -> Id.of_string "__" | Some id -> id in - GEvar (id,List.map (on_snd (glob_of_pat env sigma)) l) + GEvar (id,List.map (on_snd (glob_of_pat avoid env sigma)) l) | PRel n -> let id = try match lookup_name_of_rel n env with | Name id -> id @@ -1141,30 +1145,36 @@ let rec glob_of_pat env sigma pat = DAst.make @@ match pat with | PMeta None -> GHole (Evar_kinds.InternalHole, Misctypes.IntroAnonymous,None) | PMeta (Some n) -> GPatVar (Evar_kinds.FirstOrderPatVar n) | PProj (p,c) -> GApp (DAst.make @@ GRef (ConstRef (Projection.constant p),None), - [glob_of_pat env sigma c]) + [glob_of_pat avoid env sigma c]) | PApp (f,args) -> - GApp (glob_of_pat env sigma f,Array.map_to_list (glob_of_pat env sigma) args) + GApp (glob_of_pat avoid env sigma f,Array.map_to_list (glob_of_pat avoid env sigma) args) | PSoApp (n,args) -> GApp (DAst.make @@ GPatVar (Evar_kinds.SecondOrderPatVar n), - List.map (glob_of_pat env sigma) args) + List.map (glob_of_pat avoid env sigma) args) | PProd (na,t,c) -> - GProd (na,Explicit,glob_of_pat env sigma t,glob_of_pat (na::env) sigma c) + let na',avoid' = compute_displayed_name_in_pattern sigma avoid na c in + let env' = Termops.add_name na' env in + GProd (na',Explicit,glob_of_pat avoid env sigma t,glob_of_pat avoid' env' sigma c) | PLetIn (na,b,t,c) -> - GLetIn (na,glob_of_pat env sigma b, Option.map (glob_of_pat env sigma) t, - glob_of_pat (na::env) sigma c) + let na',avoid' = Namegen.compute_displayed_let_name_in sigma Namegen.RenamingForGoal avoid na c in + let env' = Termops.add_name na' env in + GLetIn (na',glob_of_pat avoid env sigma b, Option.map (glob_of_pat avoid env sigma) t, + glob_of_pat avoid' env' sigma c) | PLambda (na,t,c) -> - GLambda (na,Explicit,glob_of_pat env sigma t, glob_of_pat (na::env) sigma c) + let na',avoid' = compute_displayed_name_in_pattern sigma avoid na c in + let env' = Termops.add_name na' env in + GLambda (na',Explicit,glob_of_pat avoid env sigma t, glob_of_pat avoid' env' sigma c) | PIf (c,b1,b2) -> - GIf (glob_of_pat env sigma c, (Anonymous,None), - glob_of_pat env sigma b1, glob_of_pat env sigma b2) + GIf (glob_of_pat avoid env sigma c, (Anonymous,None), + glob_of_pat avoid env sigma b1, glob_of_pat avoid env sigma b2) | PCase ({cip_style=LetStyle; cip_ind_tags=None},PMeta None,tm,[(0,n,b)]) -> - let nal,b = it_destRLambda_or_LetIn_names n (glob_of_pat env sigma b) in - GLetTuple (nal,(Anonymous,None),glob_of_pat env sigma tm,b) + let nal,b = it_destRLambda_or_LetIn_names n (glob_of_pat avoid env sigma b) in + GLetTuple (nal,(Anonymous,None),glob_of_pat avoid env sigma tm,b) | PCase (info,p,tm,bl) -> let mat = match bl, info.cip_ind with | [], _ -> [] | _, Some ind -> - let bl' = List.map (fun (i,n,c) -> (i,n,glob_of_pat env sigma c)) bl in + let bl' = List.map (fun (i,n,c) -> (i,n,glob_of_pat avoid env sigma c)) bl in simple_cases_matrix_of_branches ind bl' | _, None -> anomaly (Pp.str "PCase with some branches but unknown inductive.") in @@ -1173,16 +1183,16 @@ let rec glob_of_pat env sigma pat = DAst.make @@ match pat with let indnames,rtn = match p, info.cip_ind, info.cip_ind_tags with | PMeta None, _, _ -> (Anonymous,None),None | _, Some ind, Some nargs -> - return_type_of_predicate ind nargs (glob_of_pat env sigma p) + return_type_of_predicate ind nargs (glob_of_pat avoid env sigma p) | _ -> anomaly (Pp.str "PCase with non-trivial predicate but unknown inductive.") in - GCases (RegularStyle,rtn,[glob_of_pat env sigma tm,indnames],mat) - | PFix f -> DAst.get (Detyping.detype_names false Id.Set.empty env (Global.env()) sigma (EConstr.of_constr (mkFix f))) (** FIXME bad env *) - | PCoFix c -> DAst.get (Detyping.detype_names false Id.Set.empty env (Global.env()) sigma (EConstr.of_constr (mkCoFix c))) + GCases (RegularStyle,rtn,[glob_of_pat avoid env sigma tm,indnames],mat) + | PFix f -> DAst.get (Detyping.detype_names false avoid env (Global.env()) sigma (EConstr.of_constr (mkFix f))) (** FIXME bad env *) + | PCoFix c -> DAst.get (Detyping.detype_names false avoid env (Global.env()) sigma (EConstr.of_constr (mkCoFix c))) | PSort s -> GSort s let extern_constr_pattern env sigma pat = - extern true (None,[]) Id.Set.empty (glob_of_pat env sigma pat) + extern true (None,[]) Id.Set.empty (glob_of_pat Id.Set.empty env sigma pat) let extern_rel_context where env sigma sign = let a = detype_rel_context Detyping.Later where Id.Set.empty (names_of_rel_context env,env) sigma sign in diff --git a/interp/constrextern.mli b/interp/constrextern.mli index 593580fb7e..b2df449c59 100644 --- a/interp/constrextern.mli +++ b/interp/constrextern.mli @@ -19,6 +19,7 @@ open Constrexpr open Notation_term open Notation open Misctypes +open Ltac_pretype (** Translation of pattern, cases pattern, glob_constr and term into syntax trees for printing *) diff --git a/interp/declare.ml b/interp/declare.ml index 7fcb38296f..bd8f3db507 100644 --- a/interp/declare.ml +++ b/interp/declare.ml @@ -464,7 +464,7 @@ let cache_universes (p, l) = let glob = Global.global_universe_names () in let glob', ctx = List.fold_left (fun ((idl,lid),ctx) (id, lev) -> - ((Idmap.add id (p, lev) idl, + ((Id.Map.add id (p, lev) idl, Univ.LMap.add lev id lid), Univ.ContextSet.add_universe lev ctx)) (glob, Univ.ContextSet.empty) l @@ -525,7 +525,7 @@ let do_constraint poly l = (str "Cannot declare constraints on anonymous universes") | GType (Some (loc, Name id)) -> let names, _ = Global.global_universe_names () in - try loc, Idmap.find id names + try loc, Id.Map.find id names with Not_found -> user_err ?loc ~hdr:"Constraint" (str "Undeclared universe " ++ pr_id id) in diff --git a/interp/genintern.ml b/interp/genintern.ml index f4996c997f..2f2edab30c 100644 --- a/interp/genintern.ml +++ b/interp/genintern.ml @@ -10,7 +10,7 @@ open Names open Mod_subst open Genarg -module Store = Store.Make(struct end) +module Store = Store.Make () type glob_sign = { ltacvars : Id.Set.t; diff --git a/interp/stdarg.ml b/interp/stdarg.ml index 45dec5112b..65c55a584a 100644 --- a/interp/stdarg.ml +++ b/interp/stdarg.ml @@ -28,7 +28,7 @@ let wit_string : string uniform_genarg_type = make0 "string" let wit_pre_ident : string uniform_genarg_type = - make0 ~dyn:(val_tag (topwit wit_string)) "preident" + make0 "preident" let loc_of_or_by_notation f = function | AN c -> f c diff --git a/interp/stdarg.mli b/interp/stdarg.mli index dffbd6659f..ed00fe2967 100644 --- a/interp/stdarg.mli +++ b/interp/stdarg.mli @@ -51,7 +51,7 @@ val wit_sort_family : (Sorts.family, unit, unit) genarg_type val wit_constr : (constr_expr, glob_constr_and_expr, constr) genarg_type -val wit_uconstr : (constr_expr , glob_constr_and_expr, Glob_term.closed_glob_constr) genarg_type +val wit_uconstr : (constr_expr , glob_constr_and_expr, Ltac_pretype.closed_glob_constr) genarg_type val wit_open_constr : (constr_expr, glob_constr_and_expr, constr) genarg_type diff --git a/intf/glob_term.ml b/intf/glob_term.ml index 757ba57868..508990a580 100644 --- a/intf/glob_term.ml +++ b/intf/glob_term.ml @@ -100,30 +100,3 @@ type 'a extended_glob_local_binder_r = and 'a extended_glob_local_binder_g = ('a extended_glob_local_binder_r, 'a) DAst.t type extended_glob_local_binder = [ `any ] extended_glob_local_binder_g - -(** A globalised term together with a closure representing the value - of its free variables. Intended for use when these variables are taken - from the Ltac environment. *) -type closure = { - idents:Id.t Id.Map.t; - typed: Pattern.constr_under_binders Id.Map.t ; - untyped:closed_glob_constr Id.Map.t } -and closed_glob_constr = { - closure: closure; - term: glob_constr } - -(** Ltac variable maps *) -type var_map = Pattern.constr_under_binders Id.Map.t -type uconstr_var_map = closed_glob_constr Id.Map.t -type unbound_ltac_var_map = Geninterp.Val.t Id.Map.t - -type ltac_var_map = { - ltac_constrs : var_map; - (** Ltac variables bound to constrs *) - ltac_uconstrs : uconstr_var_map; - (** Ltac variables bound to untyped constrs *) - ltac_idents: Id.t Id.Map.t; - (** Ltac variables bound to identifiers *) - ltac_genargs : unbound_ltac_var_map; - (** Ltac variables bound to other kinds of arguments *) -} diff --git a/intf/pattern.ml b/intf/pattern.ml index 2ab526984a..16c4807355 100644 --- a/intf/pattern.ml +++ b/intf/pattern.ml @@ -11,45 +11,6 @@ open Globnames open Term open Misctypes -(** {5 Maps of pattern variables} *) - -(** Type [constr_under_binders] is for representing the term resulting - of a matching. Matching can return terms defined in a some context - of named binders; in the context, variable names are ordered by - (<) and referred to by index in the term Thanks to the canonical - ordering, a matching problem like - - [match ... with [(fun x y => ?p,fun y x => ?p)] => [forall x y => p]] - - will be accepted. Thanks to the reference by index, a matching - problem like - - [match ... with [(fun x => ?p)] => [forall x => p]] - - will work even if [x] is also the name of an existing goal - variable. - - Note: we do not keep types in the signature. Besides simplicity, - the main reason is that it would force to close the signature over - binders that occur only in the types of effective binders but not - in the term itself (e.g. for a term [f x] with [f:A -> True] and - [x:A]). - - On the opposite side, by not keeping the types, we loose - opportunity to propagate type informations which otherwise would - not be inferable, as e.g. when matching [forall x, x = 0] with - pattern [forall x, ?h = 0] and using the solution "x|-h:=x" in - expression [forall x, h = x] where nothing tells how the type of x - could be inferred. We also loose the ability of typing ltac - variables before calling the right-hand-side of ltac matching clauses. *) - -type constr_under_binders = Id.t list * EConstr.constr - -(** Types of substitutions with or w/o bound variables *) - -type patvar_map = EConstr.constr Id.Map.t -type extended_patvar_map = constr_under_binders Id.Map.t - (** {5 Patterns} *) type case_info_pattern = diff --git a/intf/vernacexpr.ml b/intf/vernacexpr.ml index ea412a7d6a..9aef4b1312 100644 --- a/intf/vernacexpr.ml +++ b/intf/vernacexpr.ml @@ -39,7 +39,6 @@ type goal_reference = | OpenSubgoals | NthGoal of int | GoalId of Id.t - | GoalUid of goal_identifier type printable = | PrintTables diff --git a/kernel/names.mli b/kernel/names.mli index d111dd3c06..d97fd2b3aa 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -546,28 +546,28 @@ val eq_ind_chk : inductive -> inductive -> bool (** {5 Identifiers} *) type identifier = Id.t -(** @deprecated Alias for [Id.t] *) +[@@ocaml.deprecated "Alias for [Id.t]"] -val string_of_id : identifier -> string -(** @deprecated Same as [Id.to_string]. *) +val string_of_id : Id.t -> string +[@@ocaml.deprecated "Same as [Id.to_string]."] -val id_of_string : string -> identifier -(** @deprecated Same as [Id.of_string]. *) +val id_of_string : string -> Id.t +[@@ocaml.deprecated "Same as [Id.of_string]."] -val id_ord : identifier -> identifier -> int -(** @deprecated Same as [Id.compare]. *) +val id_ord : Id.t -> Id.t -> int +[@@ocaml.deprecated "Same as [Id.compare]."] -val id_eq : identifier -> identifier -> bool -(** @deprecated Same as [Id.equal]. *) +val id_eq : Id.t -> Id.t -> bool +[@@ocaml.deprecated "Same as [Id.equal]."] -module Idset : Set.S with type elt = identifier and type t = Id.Set.t -(** @deprecated Same as [Id.Set]. *) +module Idset : Set.S with type elt = Id.t and type t = Id.Set.t +[@@ocaml.deprecated "Same as [Id.Set]."] -module Idpred : Predicate.S with type elt = identifier and type t = Id.Pred.t -(** @deprecated Same as [Id.Pred]. *) +module Idpred : Predicate.S with type elt = Id.t and type t = Id.Pred.t +[@@ocaml.deprecated "Same as [Id.Pred]."] module Idmap : module type of Id.Map -(** @deprecated Same as [Id.Map]. *) +[@@ocaml.deprecated "Same as [Id.Map]."] (** {5 Directory paths} *) diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml index e08d913bc6..6e9991ac54 100644 --- a/kernel/nativecode.ml +++ b/kernel/nativecode.ml @@ -59,7 +59,7 @@ type gname = | Gnormtbl of label option * int | Ginternal of string | Grel of int - | Gnamed of identifier + | Gnamed of Id.t let eq_gname gn1 gn2 = match gn1, gn2 with @@ -266,7 +266,7 @@ type primitive = | Mk_fix of rec_pos * int | Mk_cofix of int | Mk_rel of int - | Mk_var of identifier + | Mk_var of Id.t | Mk_proj | Is_accu | Is_int @@ -625,7 +625,7 @@ let decompose_MLlam c = (*s Global declaration *) type global = -(* | Gtblname of gname * identifier array *) +(* | Gtblname of gname * Id.t array *) | Gtblnorm of gname * lname array * mllambda array | Gtblfixtype of gname * lname array * mllambda array | Glet of gname * mllambda @@ -732,7 +732,7 @@ type env = env_bound : int; (* length of env_rel *) (* free variables *) env_urel : (int * mllambda) list ref; (* list of unbound rel *) - env_named : (identifier * mllambda) list ref; + env_named : (Id.t * mllambda) list ref; env_univ : lname option} let empty_env univ () = @@ -1955,8 +1955,8 @@ let is_code_loaded ~interactive name = if is_loaded_native_file s then true else (name := NotLinked; false) -let param_name = Name (id_of_string "params") -let arg_name = Name (id_of_string "arg") +let param_name = Name (Id.of_string "params") +let arg_name = Name (Id.of_string "arg") let compile_mind prefix ~interactive mb mind stack = let u = Declareops.inductive_polymorphic_context mb in diff --git a/kernel/nativeinstr.mli b/kernel/nativeinstr.mli index 2353470f01..73f18f7a7b 100644 --- a/kernel/nativeinstr.mli +++ b/kernel/nativeinstr.mli @@ -21,7 +21,7 @@ type uint = and lambda = | Lrel of name * int - | Lvar of identifier + | Lvar of Id.t | Lmeta of metavariable * lambda (* type *) | Levar of existential * lambda (* type *) | Lprod of lambda * lambda diff --git a/kernel/nativevalues.ml b/kernel/nativevalues.ml index 7463a30feb..1c9996d894 100644 --- a/kernel/nativevalues.ml +++ b/kernel/nativevalues.ml @@ -52,7 +52,7 @@ type atom = | Aconstant of pconstant | Aind of pinductive | Asort of sorts - | Avar of identifier + | Avar of Id.t | Acase of annot_sw * accumulator * t * (t -> t) | Afix of t array * t array * rec_pos * int (* types, bodies, rec_pos, pos *) diff --git a/kernel/nativevalues.mli b/kernel/nativevalues.mli index 49b1e122d5..0e2db8486f 100644 --- a/kernel/nativevalues.mli +++ b/kernel/nativevalues.mli @@ -44,7 +44,7 @@ type atom = | Aconstant of pconstant | Aind of pinductive | Asort of sorts - | Avar of identifier + | Avar of Id.t | Acase of annot_sw * accumulator * t * (t -> t) | Afix of t array * t array * rec_pos * int | Acofix of t array * t array * int * t @@ -62,7 +62,7 @@ val mk_rels_accu : int -> int -> t array val mk_constant_accu : constant -> Univ.Level.t array -> t val mk_ind_accu : inductive -> Univ.Level.t array -> t val mk_sort_accu : sorts -> Univ.Level.t array -> t -val mk_var_accu : identifier -> t +val mk_var_accu : Id.t -> t val mk_sw_accu : annot_sw -> accumulator -> t -> (t -> t) val mk_prod_accu : name -> t -> t -> t val mk_fix_accu : rec_pos -> int -> t array -> t array -> t diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index f93b24b3ee..e28c8e8267 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -385,10 +385,10 @@ let build_constant_declaration kn env result = let mk_set l = List.fold_right Id.Set.add (List.map NamedDecl.get_id l) Id.Set.empty in let inferred_set, declared_set = mk_set inferred, mk_set declared in if not (Id.Set.subset inferred_set declared_set) then - let l = Id.Set.elements (Idset.diff inferred_set declared_set) in + let l = Id.Set.elements (Id.Set.diff inferred_set declared_set) in let n = List.length l in - let declared_vars = Pp.pr_sequence Id.print (Idset.elements declared_set) in - let inferred_vars = Pp.pr_sequence Id.print (Idset.elements inferred_set) in + let declared_vars = Pp.pr_sequence Id.print (Id.Set.elements declared_set) in + let inferred_vars = Pp.pr_sequence Id.print (Id.Set.elements inferred_set) in let missing_vars = Pp.pr_sequence Id.print (List.rev l) in user_err Pp.(prlist str ["The following section "; (String.plural n "variable"); " "; @@ -414,7 +414,7 @@ let build_constant_declaration kn env result = we must look at the body NOW, if any *) let ids_typ = global_vars_set env typ in let ids_def = match def with - | Undef _ -> Idset.empty + | Undef _ -> Id.Set.empty | Def cs -> global_vars_set env (Mod_subst.force_constr cs) | OpaqueDef lc -> let vars = @@ -425,7 +425,7 @@ let build_constant_declaration kn env result = if !Flags.record_aux_file then record_aux env ids_typ vars; vars in - keep_hyps env (Idset.union ids_typ ids_def), def + keep_hyps env (Id.Set.union ids_typ ids_def), def | None -> if !Flags.record_aux_file then record_aux env Id.Set.empty Id.Set.empty; @@ -438,14 +438,14 @@ let build_constant_declaration kn env result = | Def cs as x -> let ids_typ = global_vars_set env typ in let ids_def = global_vars_set env (Mod_subst.force_constr cs) in - let inferred = keep_hyps env (Idset.union ids_typ ids_def) in + let inferred = keep_hyps env (Id.Set.union ids_typ ids_def) in check declared inferred; x | OpaqueDef lc -> (* In this case we can postpone the check *) OpaqueDef (Opaqueproof.iter_direct_opaque (fun c -> let ids_typ = global_vars_set env typ in let ids_def = global_vars_set env c in - let inferred = keep_hyps env (Idset.union ids_typ ids_def) in + let inferred = keep_hyps env (Id.Set.union ids_typ ids_def) in check declared inferred) lc) in let univs = result.cook_universes in let tps = diff --git a/kernel/type_errors.ml b/kernel/type_errors.ml index bbaf569d39..9813fc566e 100644 --- a/kernel/type_errors.ml +++ b/kernel/type_errors.ml @@ -44,7 +44,7 @@ type ('constr, 'types) ptype_error = | UnboundVar of variable | NotAType of ('constr, 'types) punsafe_judgment | BadAssumption of ('constr, 'types) punsafe_judgment - | ReferenceVariables of identifier * 'constr + | ReferenceVariables of Id.t * 'constr | ElimArity of pinductive * sorts_family list * 'constr * ('constr, 'types) punsafe_judgment * (sorts_family * sorts_family * arity_error) option | CaseNotInductive of ('constr, 'types) punsafe_judgment diff --git a/kernel/type_errors.mli b/kernel/type_errors.mli index 1b2ccf8f82..95a963da23 100644 --- a/kernel/type_errors.mli +++ b/kernel/type_errors.mli @@ -45,7 +45,7 @@ type ('constr, 'types) ptype_error = | UnboundVar of variable | NotAType of ('constr, 'types) punsafe_judgment | BadAssumption of ('constr, 'types) punsafe_judgment - | ReferenceVariables of identifier * 'constr + | ReferenceVariables of Id.t * 'constr | ElimArity of pinductive * sorts_family list * 'constr * ('constr, 'types) punsafe_judgment * (sorts_family * sorts_family * arity_error) option | CaseNotInductive of ('constr, 'types) punsafe_judgment @@ -74,7 +74,7 @@ val error_not_type : env -> unsafe_judgment -> 'a val error_assumption : env -> unsafe_judgment -> 'a -val error_reference_variables : env -> identifier -> constr -> 'a +val error_reference_variables : env -> Id.t -> constr -> 'a val error_elim_arity : env -> pinductive -> sorts_family list -> constr -> unsafe_judgment -> diff --git a/lib/cSig.mli b/lib/cSig.mli index 151cfbdca5..6910cbbf03 100644 --- a/lib/cSig.mli +++ b/lib/cSig.mli @@ -48,8 +48,6 @@ end (** Redeclaration of OCaml set signature, to preserve compatibility. See OCaml documentation for more information. *) -module type EmptyS = sig end - module type MapS = sig type key diff --git a/lib/dyn.ml b/lib/dyn.ml index 6bd43455f6..83e673d2c0 100644 --- a/lib/dyn.ml +++ b/lib/dyn.ml @@ -11,6 +11,26 @@ sig type 'a t end +module type MapS = +sig + type t + type 'a obj + type 'a key + val empty : t + val add : 'a key -> 'a obj -> t -> t + val remove : 'a key -> t -> t + val find : 'a key -> t -> 'a obj + val mem : 'a key -> t -> bool + + type any = Any : 'a key * 'a obj -> any + + type map = { map : 'a. 'a key -> 'a obj -> 'a obj } + val map : map -> t -> t + + val iter : (any -> unit) -> t -> unit + val fold : (any -> 'r -> 'r) -> t -> 'r -> 'r +end + module type PreS = sig type 'a tag @@ -24,24 +44,7 @@ type any = Any : 'a tag -> any val name : string -> any option -module Map(M : TParam) : -sig - type t - val empty : t - val add : 'a tag -> 'a M.t -> t -> t - val remove : 'a tag -> t -> t - val find : 'a tag -> t -> 'a M.t - val mem : 'a tag -> t -> bool - - type any = Any : 'a tag * 'a M.t -> any - - type map = { map : 'a. 'a tag -> 'a M.t -> 'a M.t } - val map : map -> t -> t - - val iter : (any -> unit) -> t -> unit - val fold : (any -> 'r -> 'r) -> t -> 'r -> 'r - -end +module Map(M : TParam) : MapS with type 'a obj = 'a M.t with type 'a key = 'a tag val dump : unit -> (int * string) list @@ -59,7 +62,7 @@ sig end -module Make(M : CSig.EmptyS) = struct +module Make () = struct module Self : PreS = struct (* Dynamics, programmed with DANGER !!! *) @@ -104,6 +107,8 @@ let dump () = Int.Map.bindings !dyntab module Map(M : TParam) = struct type t = Obj.t M.t Int.Map.t +type 'a obj = 'a M.t +type 'a key = 'a tag let cast : 'a M.t -> 'b M.t = Obj.magic let empty = Int.Map.empty let add tag v m = Int.Map.add tag (cast v) m diff --git a/lib/dyn.mli b/lib/dyn.mli index e43c8a9bcf..e0e1a9d140 100644 --- a/lib/dyn.mli +++ b/lib/dyn.mli @@ -13,6 +13,26 @@ sig type 'a t end +module type MapS = +sig + type t + type 'a obj + type 'a key + val empty : t + val add : 'a key -> 'a obj -> t -> t + val remove : 'a key -> t -> t + val find : 'a key -> t -> 'a obj + val mem : 'a key -> t -> bool + + type any = Any : 'a key * 'a obj -> any + + type map = { map : 'a. 'a key -> 'a obj -> 'a obj } + val map : map -> t -> t + + val iter : (any -> unit) -> t -> unit + val fold : (any -> 'r -> 'r) -> t -> 'r -> 'r +end + module type S = sig type 'a tag @@ -26,24 +46,7 @@ type any = Any : 'a tag -> any val name : string -> any option -module Map(M : TParam) : -sig - type t - val empty : t - val add : 'a tag -> 'a M.t -> t -> t - val remove : 'a tag -> t -> t - val find : 'a tag -> t -> 'a M.t - val mem : 'a tag -> t -> bool - - type any = Any : 'a tag * 'a M.t -> any - - type map = { map : 'a. 'a tag -> 'a M.t -> 'a M.t } - val map : map -> t -> t - - val iter : (any -> unit) -> t -> unit - val fold : (any -> 'r -> 'r) -> t -> 'r -> 'r - -end +module Map(M : TParam) : MapS with type 'a obj = 'a M.t with type 'a key = 'a tag val dump : unit -> (int * string) list @@ -59,5 +62,4 @@ end end -(** FIXME: use OCaml 4.02 generative functors when available *) -module Make(M : CSig.EmptyS) : S +module Make () : S diff --git a/lib/exninfo.ml b/lib/exninfo.ml index d049dc6cff..167d3d6dc8 100644 --- a/lib/exninfo.ml +++ b/lib/exninfo.ml @@ -10,7 +10,7 @@ containing a pair composed of the distinguishing [token] and the backtrace information. We discriminate the token by pointer equality. *) -module Store = Store.Make(struct end) +module Store = Store.Make () type 'a t = 'a Store.field diff --git a/lib/genarg.ml b/lib/genarg.ml index b78fe40373..a3bfb405c8 100644 --- a/lib/genarg.ml +++ b/lib/genarg.ml @@ -11,7 +11,7 @@ open Util module ArgT = struct - module DYN = Dyn.Make(struct end) + module DYN = Dyn.Make () module Map = DYN.Map type ('a, 'b, 'c) tag = ('a * 'b * 'c) DYN.tag type any = Any : ('a, 'b, 'c) tag -> any diff --git a/lib/spawn.ml b/lib/spawn.ml index 0cf163e737..de31d87d0e 100644 --- a/lib/spawn.ml +++ b/lib/spawn.ml @@ -28,8 +28,6 @@ module type Control = sig end -module type Empty = sig end - module type MainLoopModel = sig type async_chan type condition @@ -216,7 +214,7 @@ let rec wait p = end -module Sync(T : Empty) = struct +module Sync () = struct type process = { cin : in_channel; diff --git a/lib/spawn.mli b/lib/spawn.mli index a131715e9d..fd2b92ae3e 100644 --- a/lib/spawn.mli +++ b/lib/spawn.mli @@ -34,8 +34,6 @@ module type Control = sig end (* Abstraction to work with both threads and main loop models *) -module type Empty = sig end - module type MainLoopModel = sig type async_chan type condition @@ -64,7 +62,7 @@ module Async(ML : MainLoopModel) : sig end (* spawn a process and read its output synchronously *) -module Sync(T : Empty) : sig +module Sync () : sig type process val spawn : diff --git a/lib/store.ml b/lib/store.ml index a1788f7da9..97a8fea085 100644 --- a/lib/store.ml +++ b/lib/store.ml @@ -14,10 +14,6 @@ stores, we might want something static to avoid troubles with plugins order. *) -module type T = -sig -end - module type S = sig type t @@ -30,7 +26,7 @@ sig val field : unit -> 'a field end -module Make (M : T) : S = +module Make () : S = struct let next = diff --git a/lib/store.mli b/lib/store.mli index 8eab314ed7..5cc5bb8593 100644 --- a/lib/store.mli +++ b/lib/store.mli @@ -9,11 +9,6 @@ (*** This module implements an "untyped store", in this particular case we see it as an extensible record whose fields are left unspecified. ***) -module type T = -sig -(** FIXME: Waiting for first-class modules... *) -end - module type S = sig type t @@ -42,5 +37,5 @@ sig end -module Make (M : T) : S +module Make () : S (** Create a new store type. *) diff --git a/library/global.ml b/library/global.ml index 963c977417..28b9e66f86 100644 --- a/library/global.ml +++ b/library/global.ml @@ -233,11 +233,11 @@ let universes_of_global gr = (** Global universe names *) type universe_names = - (polymorphic * Univ.universe_level) Idmap.t * Id.t Univ.LMap.t + (polymorphic * Univ.universe_level) Id.Map.t * Id.t Univ.LMap.t let global_universes = Summary.ref ~name:"Global universe names" - ((Idmap.empty, Univ.LMap.empty) : universe_names) + ((Id.Map.empty, Univ.LMap.empty) : universe_names) let global_universe_names () = !global_universes let set_global_universe_names s = global_universes := s diff --git a/library/global.mli b/library/global.mli index c777691d11..15bf58f82e 100644 --- a/library/global.mli +++ b/library/global.mli @@ -104,7 +104,7 @@ val body_of_constant_body : Declarations.constant_body -> (Term.constr * Univ.AU (** Global universe name <-> level mapping *) type universe_names = - (Decl_kinds.polymorphic * Univ.universe_level) Idmap.t * Id.t Univ.LMap.t + (Decl_kinds.polymorphic * Univ.universe_level) Id.Map.t * Id.t Univ.LMap.t val global_universe_names : unit -> universe_names val set_global_universe_names : universe_names -> unit diff --git a/library/globnames.ml b/library/globnames.ml index dc9541a0d5..5c75994dd5 100644 --- a/library/globnames.ml +++ b/library/globnames.ml @@ -84,7 +84,7 @@ let is_global c t = | ConstRef c, Const (c', _) -> eq_constant c c' | IndRef i, Ind (i', _) -> eq_ind i i' | ConstructRef i, Construct (i', _) -> eq_constructor i i' - | VarRef id, Var id' -> id_eq id id' + | VarRef id, Var id' -> Id.equal id id' | _ -> false let printable_constr_of_global = function diff --git a/library/lib.ml b/library/lib.ml index 5418003ebc..e95bb47f27 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -505,7 +505,7 @@ let variable_section_segment_of_reference = function let section_instance = function | VarRef id -> let eq = function - | Variable (id',_,_,_) -> Names.id_eq id id' + | Variable (id',_,_,_) -> Names.Id.equal id id' | Context _ -> false in if List.exists eq (pi1 (List.hd !sectab)) diff --git a/library/libobject.ml b/library/libobject.ml index 013c6fa0a5..0c11be9abb 100644 --- a/library/libobject.ml +++ b/library/libobject.ml @@ -9,7 +9,7 @@ open Libnames open Pp -module Dyn = Dyn.Make(struct end) +module Dyn = Dyn.Make () type 'a substitutivity = Dispose | Substitute of 'a | Keep of 'a | Anticipate of 'a diff --git a/library/summary.ml b/library/summary.ml index 69eff830da..9f49d1f839 100644 --- a/library/summary.ml +++ b/library/summary.ml @@ -10,7 +10,7 @@ open Pp open CErrors open Util -module Dyn = Dyn.Make(struct end) +module Dyn = Dyn.Make () type marshallable = [ `Yes | `No | `Shallow ] type 'a summary_declaration = { diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 3d00b220b8..d34da159ee 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -543,11 +543,11 @@ let epsilon_value f e = (** Synchronized grammar extensions *) -module GramState = Store.Make(struct end) +module GramState = Store.Make () type 'a grammar_extension = 'a -> GramState.t -> extend_rule list * GramState.t -module GrammarCommand = Dyn.Make(struct end) +module GrammarCommand = Dyn.Make () module GrammarInterp = struct type 'a t = 'a grammar_extension end module GrammarInterpMap = GrammarCommand.Map(GrammarInterp) diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4 index 62ecaa552b..829556a71e 100644 --- a/plugins/funind/g_indfun.ml4 +++ b/plugins/funind/g_indfun.ml4 @@ -144,8 +144,7 @@ END let () = let raw_printer _ _ _ (loc,body) = Ppvernac.pr_rec_definition body in - let printer _ _ _ _ = str "<Unavailable printer for rec_definition>" in - Pptactic.declare_extra_genarg_pprule wit_function_rec_definition_loc raw_printer printer printer + Pptactic.declare_extra_vernac_genarg_pprule wit_function_rec_definition_loc raw_printer (* TASSI: n'importe quoi ! *) VERNAC COMMAND EXTEND Function diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index 9cb2a0a3f5..93317fce1b 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -570,6 +570,11 @@ let rec reflexivity_with_destruct_cases g = with e when CErrors.noncritical e -> Proofview.V82.of_tactic reflexivity in let eq_ind = make_eq () in + let my_inj_flags = Some { + Equality.keep_proof_equalities = false; + injection_in_context = false; (* for compatibility, necessary *) + injection_pattern_l2r_order = false; (* probably does not matter; except maybe with dependent hyps *) + } in let discr_inject = Tacticals.onAllHypsAndConcl ( fun sc g -> @@ -580,8 +585,8 @@ let rec reflexivity_with_destruct_cases g = | App(eq,[|_;t1;t2|]) when EConstr.eq_constr (project g) eq eq_ind -> if Equality.discriminable (pf_env g) (project g) t1 t2 then Proofview.V82.of_tactic (Equality.discrHyp id) g - else if Equality.injectable (pf_env g) (project g) t1 t2 - then tclTHENLIST [Proofview.V82.of_tactic (Equality.injHyp None id);thin [id];intros_with_rewrite] g + else if Equality.injectable (pf_env g) (project g) ~keep_proofs:None t1 t2 + then tclTHENLIST [Proofview.V82.of_tactic (Equality.injHyp my_inj_flags None id);thin [id];intros_with_rewrite] g else tclIDTAC g | _ -> tclIDTAC g ) diff --git a/plugins/ltac/evar_tactics.ml b/plugins/ltac/evar_tactics.ml index d9150a7bbd..1f628803a3 100644 --- a/plugins/ltac/evar_tactics.ml +++ b/plugins/ltac/evar_tactics.ml @@ -17,6 +17,7 @@ open Refiner open Evd open Locus open Context.Named.Declaration +open Ltac_pretype module NamedDecl = Context.Named.Declaration @@ -27,7 +28,7 @@ let instantiate_evar evk (ist,rawc) sigma = let filtered = Evd.evar_filtered_env evi in let constrvars = Tacinterp.extract_ltac_constr_values ist filtered in let lvar = { - Glob_term.ltac_constrs = constrvars; + ltac_constrs = constrvars; ltac_uconstrs = Names.Id.Map.empty; ltac_idents = Names.Id.Map.empty; ltac_genargs = ist.Geninterp.lfun; diff --git a/plugins/ltac/extratactics.ml4 b/plugins/ltac/extratactics.ml4 index a7aebf9e15..65c186a419 100644 --- a/plugins/ltac/extratactics.ml4 +++ b/plugins/ltac/extratactics.ml4 @@ -91,12 +91,12 @@ let elimOnConstrWithHoles tac with_evars c = (fun c -> tac with_evars (Some (None,ElimOnConstr c))) TACTIC EXTEND simplify_eq - [ "simplify_eq" ] -> [ dEq false None ] -| [ "simplify_eq" destruction_arg(c) ] -> [ mytclWithHoles dEq false c ] + [ "simplify_eq" ] -> [ dEq ~keep_proofs:None false None ] +| [ "simplify_eq" destruction_arg(c) ] -> [ mytclWithHoles (dEq ~keep_proofs:None) false c ] END TACTIC EXTEND esimplify_eq -| [ "esimplify_eq" ] -> [ dEq true None ] -| [ "esimplify_eq" destruction_arg(c) ] -> [ mytclWithHoles dEq true c ] +| [ "esimplify_eq" ] -> [ dEq ~keep_proofs:None true None ] +| [ "esimplify_eq" destruction_arg(c) ] -> [ mytclWithHoles (dEq ~keep_proofs:None) true c ] END let discr_main c = elimOnConstrWithHoles discr_tac false c @@ -117,31 +117,31 @@ let discrHyp id = discr_main (fun env sigma -> (sigma, (EConstr.mkVar id, NoBindings))) let injection_main with_evars c = - elimOnConstrWithHoles (injClause None) with_evars c + elimOnConstrWithHoles (injClause None None) with_evars c TACTIC EXTEND injection -| [ "injection" ] -> [ injClause None false None ] -| [ "injection" destruction_arg(c) ] -> [ mytclWithHoles (injClause None) false c ] +| [ "injection" ] -> [ injClause None None false None ] +| [ "injection" destruction_arg(c) ] -> [ mytclWithHoles (injClause None None) false c ] END TACTIC EXTEND einjection -| [ "einjection" ] -> [ injClause None true None ] -| [ "einjection" destruction_arg(c) ] -> [ mytclWithHoles (injClause None) true c ] +| [ "einjection" ] -> [ injClause None None true None ] +| [ "einjection" destruction_arg(c) ] -> [ mytclWithHoles (injClause None None) true c ] END TACTIC EXTEND injection_as | [ "injection" "as" intropattern_list(ipat)] -> - [ injClause (Some ipat) false None ] + [ injClause None (Some ipat) false None ] | [ "injection" destruction_arg(c) "as" intropattern_list(ipat)] -> - [ mytclWithHoles (injClause (Some ipat)) false c ] + [ mytclWithHoles (injClause None (Some ipat)) false c ] END TACTIC EXTEND einjection_as | [ "einjection" "as" intropattern_list(ipat)] -> - [ injClause (Some ipat) true None ] + [ injClause None (Some ipat) true None ] | [ "einjection" destruction_arg(c) "as" intropattern_list(ipat)] -> - [ mytclWithHoles (injClause (Some ipat)) true c ] + [ mytclWithHoles (injClause None (Some ipat)) true c ] END TACTIC EXTEND simple_injection -| [ "simple" "injection" ] -> [ simpleInjClause false None ] -| [ "simple" "injection" destruction_arg(c) ] -> [ mytclWithHoles simpleInjClause false c ] +| [ "simple" "injection" ] -> [ simpleInjClause None false None ] +| [ "simple" "injection" destruction_arg(c) ] -> [ mytclWithHoles (simpleInjClause None) false c ] END let injHyp id = diff --git a/plugins/ltac/g_obligations.ml4 b/plugins/ltac/g_obligations.ml4 index 1a2d895868..fea9e837b1 100644 --- a/plugins/ltac/g_obligations.ml4 +++ b/plugins/ltac/g_obligations.ml4 @@ -155,6 +155,4 @@ let () = | None -> mt () | Some tac -> str "with" ++ spc () ++ Pptactic.pr_raw_tactic tac in - (* should not happen *) - let dummy _ _ _ expr = assert false in - Pptactic.declare_extra_genarg_pprule wit_withtac printer dummy dummy + Pptactic.declare_extra_vernac_genarg_pprule wit_withtac printer diff --git a/plugins/ltac/g_rewrite.ml4 b/plugins/ltac/g_rewrite.ml4 index c22e683235..b148d962ed 100644 --- a/plugins/ltac/g_rewrite.ml4 +++ b/plugins/ltac/g_rewrite.ml4 @@ -195,8 +195,7 @@ let binders = Pcoq.create_generic_entry Pcoq.utactic "binders" (Genarg.rawwit wi let () = let raw_printer _ _ _ l = Pp.pr_non_empty_arg Ppconstr.pr_binders l in - let printer _ _ _ _ = Pp.str "<Unavailable printer for binders>" in - Pptactic.declare_extra_genarg_pprule wit_binders raw_printer printer printer + Pptactic.declare_extra_vernac_genarg_pprule wit_binders raw_printer open Pcoq diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index d588c888c4..e467d3e2ca 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -116,7 +116,13 @@ type 'a extra_genarg_printer = | Val.Base t -> begin match Val.eq t tag with | None -> default - | Some Refl -> Genprint.generic_top_print (in_gen (Topwit wit) x) + | Some Refl -> + let open Genprint in + match generic_top_print (in_gen (Topwit wit) x) with + | PrinterBasic pr -> pr () + | PrinterNeedsContext pr -> pr (Global.env()) Evd.empty + | PrinterNeedsContextAndLevel { default_ensure_surrounded; printer } -> + printer (Global.env()) Evd.empty default_ensure_surrounded end | _ -> default @@ -432,12 +438,13 @@ type 'a extra_genarg_printer = let pr_occs = pr_with_occurrences (fun () -> str" |- *") (occs,()) in (prlist_with_sep (fun () -> str", ") (pr_hyp_location pr_id) l ++ pr_occs) - let pr_clauses default_is_concl pr_id = function + (* Some true = default is concl; Some false = default is all; None = no default *) + let pr_clauses has_default pr_id = function | { onhyps=Some []; concl_occs=occs } - when (match default_is_concl with Some true -> true | _ -> false) -> + when (match has_default with Some true -> true | _ -> false) -> pr_with_occurrences mt (occs,()) | { onhyps=None; concl_occs=AllOccurrences } - when (match default_is_concl with Some false -> true | _ -> false) -> mt () + when (match has_default with Some false -> true | _ -> false) -> mt () | { onhyps=None; concl_occs=NoOccurrences } -> pr_in (str " * |-") | { onhyps=None; concl_occs=occs } -> @@ -1174,83 +1181,122 @@ let declare_extra_genarg_pprule wit g (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env)) (pr_glob_tactic_level env) x in let h x = - let env = Global.env () in - h (pr_econstr_env env Evd.empty) (pr_leconstr_env env Evd.empty) (fun _ _ -> str "<tactic>") x + Genprint.PrinterNeedsContext (fun env sigma -> + h (pr_econstr_env env sigma) (pr_leconstr_env env sigma) (fun _ _ -> str "<tactic>") x) in Genprint.register_print0 wit f g h +let declare_extra_vernac_genarg_pprule wit f = + let f x = f pr_constr_expr pr_lconstr_expr pr_raw_tactic_level x in + Genprint.register_vernac_print0 wit f + (** Registering *) -let run_delayed c = c (Global.env ()) Evd.empty +let pr_intro_pattern_env p = Genprint.PrinterNeedsContext (fun env sigma -> + let print_constr c = let (sigma, c) = c env sigma in pr_econstr_env env sigma c in + Miscprint.pr_intro_pattern print_constr p) + +let pr_red_expr_env r = Genprint.PrinterNeedsContext (fun env sigma -> + pr_red_expr (pr_econstr_env env sigma, pr_leconstr_env env sigma, + pr_evaluable_reference_env env, pr_constr_pattern_env env sigma) r) + +let pr_bindings_env bl = Genprint.PrinterNeedsContext (fun env sigma -> + let sigma, bl = bl env sigma in + Miscprint.pr_bindings + (pr_econstr_env env sigma) (pr_leconstr_env env sigma) bl) + +let pr_with_bindings_env bl = Genprint.PrinterNeedsContext (fun env sigma -> + let sigma, bl = bl env sigma in + pr_with_bindings + (pr_econstr_env env sigma) (pr_leconstr_env env sigma) bl) + +let pr_destruction_arg_env c = Genprint.PrinterNeedsContext (fun env sigma -> + let sigma, c = match c with + | clear_flag,ElimOnConstr g -> let sigma,c = g env sigma in sigma,(clear_flag,ElimOnConstr c) + | clear_flag,ElimOnAnonHyp n as x -> sigma, x + | clear_flag,ElimOnIdent id as x -> sigma, x in + pr_destruction_arg + (pr_econstr_env env sigma) (pr_leconstr_env env sigma) c) + +let make_constr_printer f c = + Genprint.PrinterNeedsContextAndLevel { + Genprint.default_already_surrounded = Ppconstr.ltop; + Genprint.default_ensure_surrounded = Ppconstr.lsimpleconstr; + Genprint.printer = (fun env sigma n -> f env sigma n c)} -let run_delayed_destruction_arg = function (* HH: Using Evd.empty looks suspicious *) - | clear_flag,ElimOnConstr g -> clear_flag,ElimOnConstr (snd (run_delayed g)) - | clear_flag,ElimOnAnonHyp n as x -> x - | clear_flag,ElimOnIdent id as x -> x +let lift f a = Genprint.PrinterBasic (fun () -> f a) let () = let pr_bool b = if b then str "true" else str "false" in let pr_unit _ = str "()" in - let pr_string s = str "\"" ++ str s ++ str "\"" in Genprint.register_print0 wit_int_or_var - (pr_or_var int) (pr_or_var int) int; + (pr_or_var int) (pr_or_var int) (lift int); Genprint.register_print0 wit_ref - pr_reference (pr_or_var (pr_located pr_global)) pr_global; + pr_reference (pr_or_var (pr_located pr_global)) (lift pr_global); Genprint.register_print0 wit_ident - pr_id pr_id pr_id; + pr_id pr_id (lift pr_id); Genprint.register_print0 wit_var - (pr_located pr_id) (pr_located pr_id) pr_id; + (pr_located pr_id) (pr_located pr_id) (lift pr_id); Genprint.register_print0 wit_intro_pattern (Miscprint.pr_intro_pattern pr_constr_expr) (Miscprint.pr_intro_pattern (fun (c,_) -> pr_glob_constr c)) - (Miscprint.pr_intro_pattern (fun c -> pr_econstr (snd (run_delayed c)))); + pr_intro_pattern_env; Genprint.register_print0 wit_clause_dft_concl (pr_clauses (Some true) pr_lident) (pr_clauses (Some true) pr_lident) - (pr_clauses (Some true) (fun id -> pr_lident (Loc.tag id))) + (fun c -> Genprint.PrinterBasic (fun () -> pr_clauses (Some true) (fun id -> pr_lident (Loc.tag id)) c)) ; Genprint.register_print0 wit_constr Ppconstr.pr_constr_expr (fun (c, _) -> Printer.pr_glob_constr c) - Printer.pr_econstr + (make_constr_printer Printer.pr_econstr_n_env) ; Genprint.register_print0 wit_uconstr Ppconstr.pr_constr_expr (fun (c,_) -> Printer.pr_glob_constr c) - Printer.pr_closed_glob + (make_constr_printer Printer.pr_closed_glob_n_env) ; Genprint.register_print0 wit_open_constr Ppconstr.pr_constr_expr (fun (c, _) -> Printer.pr_glob_constr c) - Printer.pr_econstr + (make_constr_printer Printer.pr_econstr_n_env) ; Genprint.register_print0 wit_red_expr (pr_red_expr (pr_constr_expr, pr_lconstr_expr, pr_or_by_notation pr_reference, pr_constr_pattern_expr)) (pr_red_expr (pr_and_constr_expr pr_glob_constr, pr_and_constr_expr pr_lglob_constr, pr_or_var (pr_and_short_name pr_evaluable_reference), pr_pat_and_constr_expr pr_glob_constr)) - (pr_red_expr (pr_econstr, pr_leconstr, pr_evaluable_reference, pr_constr_pattern)); - Genprint.register_print0 wit_quant_hyp pr_quantified_hypothesis pr_quantified_hypothesis pr_quantified_hypothesis; + pr_red_expr_env + ; + Genprint.register_print0 wit_quant_hyp pr_quantified_hypothesis pr_quantified_hypothesis (lift pr_quantified_hypothesis); Genprint.register_print0 wit_bindings (Miscprint.pr_bindings_no_with pr_constr_expr pr_lconstr_expr) (Miscprint.pr_bindings_no_with (pr_and_constr_expr pr_glob_constr) (pr_and_constr_expr pr_lglob_constr)) - (fun it -> Miscprint.pr_bindings_no_with pr_econstr pr_leconstr (snd (run_delayed it))); + pr_bindings_env + ; Genprint.register_print0 wit_constr_with_bindings (pr_with_bindings pr_constr_expr pr_lconstr_expr) (pr_with_bindings (pr_and_constr_expr pr_glob_constr) (pr_and_constr_expr pr_lglob_constr)) - (fun it -> pr_with_bindings pr_econstr pr_leconstr (snd (run_delayed it))); + pr_with_bindings_env + ; + Genprint.register_print0 wit_open_constr_with_bindings + (pr_with_bindings pr_constr_expr pr_lconstr_expr) + (pr_with_bindings (pr_and_constr_expr pr_glob_constr) (pr_and_constr_expr pr_lglob_constr)) + pr_with_bindings_env + ; Genprint.register_print0 Tacarg.wit_destruction_arg (pr_destruction_arg pr_constr_expr pr_lconstr_expr) (pr_destruction_arg (pr_and_constr_expr pr_glob_constr) (pr_and_constr_expr pr_lglob_constr)) - (fun it -> pr_destruction_arg pr_econstr pr_leconstr (run_delayed_destruction_arg it)); - Genprint.register_print0 Stdarg.wit_int int int int; - Genprint.register_print0 Stdarg.wit_bool pr_bool pr_bool pr_bool; - Genprint.register_print0 Stdarg.wit_unit pr_unit pr_unit pr_unit; - Genprint.register_print0 Stdarg.wit_pre_ident str str str; - Genprint.register_print0 Stdarg.wit_string pr_string pr_string pr_string + pr_destruction_arg_env + ; + Genprint.register_print0 Stdarg.wit_int int int (lift int); + Genprint.register_print0 Stdarg.wit_bool pr_bool pr_bool (lift pr_bool); + Genprint.register_print0 Stdarg.wit_unit pr_unit pr_unit (lift pr_unit); + Genprint.register_print0 Stdarg.wit_pre_ident str str (lift str); + Genprint.register_print0 Stdarg.wit_string qstring qstring (lift qstring) let () = let printer _ _ prtac = prtac (0, E) in diff --git a/plugins/ltac/pptactic.mli b/plugins/ltac/pptactic.mli index d9da954fe6..5ecfaf590c 100644 --- a/plugins/ltac/pptactic.mli +++ b/plugins/ltac/pptactic.mli @@ -46,6 +46,10 @@ val declare_extra_genarg_pprule : 'b glob_extra_genarg_printer -> 'c extra_genarg_printer -> unit +val declare_extra_vernac_genarg_pprule : + ('a, 'b, 'c) genarg_type -> + 'a raw_extra_genarg_printer -> unit + type grammar_terminals = Genarg.ArgT.any Extend.user_symbol grammar_tactic_prod_item_expr list type pp_tactic = { @@ -69,11 +73,16 @@ val pr_may_eval : val pr_and_short_name : ('a -> Pp.t) -> 'a and_short_name -> Pp.t val pr_or_by_notation : ('a -> Pp.t) -> 'a or_by_notation -> Pp.t +val pr_evaluable_reference_env : env -> evaluable_global_reference -> Pp.t + +val pr_quantified_hypothesis : quantified_hypothesis -> Pp.t + val pr_in_clause : ('a -> Pp.t) -> 'a Locus.clause_expr -> Pp.t -val pr_clauses : bool option -> +val pr_clauses : (* default: *) bool option -> ('a -> Pp.t) -> 'a Locus.clause_expr -> Pp.t + (* Some true = default is concl; Some false = default is all; None = no default *) val pr_raw_generic : env -> rlevel generic_argument -> Pp.t @@ -116,3 +125,6 @@ val pr_value : tolerability -> Val.t -> Pp.t val ltop : tolerability + +val make_constr_printer : (env -> Evd.evar_map -> Notation_term.tolerability -> 'a -> Pp.t) -> + 'a Genprint.top_printer diff --git a/plugins/ltac/taccoerce.ml b/plugins/ltac/taccoerce.ml index 9e3a54cc86..4d171ecbc2 100644 --- a/plugins/ltac/taccoerce.ml +++ b/plugins/ltac/taccoerce.ml @@ -10,7 +10,6 @@ open Util open Names open Term open EConstr -open Pattern open Misctypes open Genarg open Stdarg @@ -18,15 +17,23 @@ open Geninterp exception CannotCoerceTo of string +let base_val_typ wit = + match val_tag (topwit wit) with Val.Base t -> t | _ -> CErrors.anomaly (Pp.str "Not a base val.") + let (wit_constr_context : (Empty.t, Empty.t, EConstr.constr) Genarg.genarg_type) = let wit = Genarg.create_arg "constr_context" in let () = register_val0 wit None in + let () = Genprint.register_val_print0 (base_val_typ wit) + (Pptactic.make_constr_printer Printer.pr_econstr_n_env) in wit (* includes idents known to be bound and references *) -let (wit_constr_under_binders : (Empty.t, Empty.t, constr_under_binders) Genarg.genarg_type) = +let (wit_constr_under_binders : (Empty.t, Empty.t, Ltac_pretype.constr_under_binders) Genarg.genarg_type) = let wit = Genarg.create_arg "constr_under_binders" in let () = register_val0 wit None in + let () = Genprint.register_val_print0 (base_val_typ wit) + (fun c -> + Genprint.PrinterNeedsContext (fun env sigma -> Printer.pr_constr_under_binders_env env sigma c)) in wit (** All the types considered here are base types *) diff --git a/plugins/ltac/taccoerce.mli b/plugins/ltac/taccoerce.mli index 1a67f6f888..d7b253a687 100644 --- a/plugins/ltac/taccoerce.mli +++ b/plugins/ltac/taccoerce.mli @@ -10,7 +10,6 @@ open Util open Names open EConstr open Misctypes -open Pattern open Genarg open Geninterp @@ -37,8 +36,8 @@ sig val of_constr : constr -> t val to_constr : t -> constr option - val of_uconstr : Glob_term.closed_glob_constr -> t - val to_uconstr : t -> Glob_term.closed_glob_constr option + val of_uconstr : Ltac_pretype.closed_glob_constr -> t + val to_uconstr : t -> Ltac_pretype.closed_glob_constr option val of_int : int -> t val to_int : t -> int option val to_list : t -> t list option @@ -63,9 +62,9 @@ val coerce_to_hint_base : Value.t -> string val coerce_to_int : Value.t -> int -val coerce_to_constr : Environ.env -> Value.t -> constr_under_binders +val coerce_to_constr : Environ.env -> Value.t -> Ltac_pretype.constr_under_binders -val coerce_to_uconstr : Environ.env -> Value.t -> Glob_term.closed_glob_constr +val coerce_to_uconstr : Environ.env -> Value.t -> Ltac_pretype.closed_glob_constr val coerce_to_closed_constr : Environ.env -> Value.t -> constr @@ -93,4 +92,4 @@ val coerce_to_int_or_var_list : Value.t -> int or_var list val wit_constr_context : (Empty.t, Empty.t, EConstr.constr) genarg_type -val wit_constr_under_binders : (Empty.t, Empty.t, constr_under_binders) genarg_type +val wit_constr_under_binders : (Empty.t, Empty.t, Ltac_pretype.constr_under_binders) genarg_type diff --git a/plugins/ltac/tacentries.ml b/plugins/ltac/tacentries.ml index 0bf6e3d155..ee84be5414 100644 --- a/plugins/ltac/tacentries.ml +++ b/plugins/ltac/tacentries.ml @@ -63,28 +63,37 @@ let get_separator = function | None -> user_err Pp.(str "Missing separator.") | Some sep -> sep -let rec parse_user_entry s sep = +let check_separator ?loc = function +| None -> () +| Some _ -> user_err ?loc (str "Separator is only for arguments with suffix _list_sep.") + +let rec parse_user_entry ?loc s sep = let l = String.length s in if l > 8 && coincide s "ne_" 0 && coincide s "_list" (l - 5) then - let entry = parse_user_entry (String.sub s 3 (l-8)) None in + let entry = parse_user_entry ?loc (String.sub s 3 (l-8)) None in + check_separator ?loc sep; Ulist1 entry else if l > 12 && coincide s "ne_" 0 && coincide s "_list_sep" (l-9) then - let entry = parse_user_entry (String.sub s 3 (l-12)) None in + let entry = parse_user_entry ?loc (String.sub s 3 (l-12)) None in Ulist1sep (entry, get_separator sep) else if l > 5 && coincide s "_list" (l-5) then - let entry = parse_user_entry (String.sub s 0 (l-5)) None in + let entry = parse_user_entry ?loc (String.sub s 0 (l-5)) None in + check_separator ?loc sep; Ulist0 entry else if l > 9 && coincide s "_list_sep" (l-9) then - let entry = parse_user_entry (String.sub s 0 (l-9)) None in + let entry = parse_user_entry ?loc (String.sub s 0 (l-9)) None in Ulist0sep (entry, get_separator sep) else if l > 4 && coincide s "_opt" (l-4) then - let entry = parse_user_entry (String.sub s 0 (l-4)) None in + let entry = parse_user_entry ?loc (String.sub s 0 (l-4)) None in + check_separator ?loc sep; Uopt entry else if Int.equal l 7 && coincide s "tactic" 0 && '5' >= s.[6] && s.[6] >= '0' then let n = Char.code s.[6] - 48 in + check_separator ?loc sep; Uentryl ("tactic", n) else + let _ = check_separator ?loc sep in Uentry s let interp_entry_name interp symb = @@ -203,7 +212,7 @@ let register_tactic_notation_entry name entry = let interp_prod_item = function | TacTerm s -> TacTerm s | TacNonTerm (loc, ((nt, sep), ido)) -> - let symbol = parse_user_entry nt sep in + let symbol = parse_user_entry ?loc nt sep in let interp s = function | None -> if String.Map.mem s !entry_names then String.Map.find s !entry_names diff --git a/plugins/ltac/tacexpr.mli b/plugins/ltac/tacexpr.mli index 2c36faeff4..1639736883 100644 --- a/plugins/ltac/tacexpr.mli +++ b/plugins/ltac/tacexpr.mli @@ -386,7 +386,7 @@ type ltac_call_kind = | LtacNameCall of ltac_constant | LtacAtomCall of glob_atomic_tactic_expr | LtacVarCall of Id.t * glob_tactic_expr - | LtacConstrInterp of Glob_term.glob_constr * Glob_term.ltac_var_map + | LtacConstrInterp of Glob_term.glob_constr * Ltac_pretype.ltac_var_map type ltac_trace = ltac_call_kind Loc.located list diff --git a/plugins/ltac/tacintern.ml b/plugins/ltac/tacintern.ml index 99d7684d36..f171fd07d7 100644 --- a/plugins/ltac/tacintern.ml +++ b/plugins/ltac/tacintern.ml @@ -322,13 +322,23 @@ let intern_constr_pattern ist ~as_type ~ltacvars pc = let dummy_pat = PRel 0 -let intern_typed_pattern ist p = +let intern_typed_pattern ist ~as_type ~ltacvars p = (* we cannot ensure in non strict mode that the pattern is closed *) (* keeping a constr_expr copy is too complicated and we want anyway to *) (* type it, so we remember the pattern as a glob_constr only *) + let metas,pat = + if !strict_check then + let ltacvars = { + Constrintern.ltac_vars = ltacvars; + ltac_bound = Id.Set.empty; + ltac_extra = ist.extra; + } in + Constrintern.intern_constr_pattern ist.genv ~as_type ~ltacvars p + else + [], dummy_pat in let (glob,_ as c) = intern_constr_gen true false ist p in let bound_names = Glob_ops.bound_glob_vars glob in - (bound_names,c,dummy_pat) + metas,(bound_names,c,pat) let intern_typed_pattern_or_ref_with_occurrences ist (l,p) = let interp_ref r = @@ -364,7 +374,7 @@ let intern_typed_pattern_or_ref_with_occurrences ist (l,p) = (* We interpret similarly @ref and ref *) interp_ref (AN r) | Inr c -> - Inr (intern_typed_pattern ist c)) + Inr (snd (intern_typed_pattern ist ~as_type:false ~ltacvars:ist.ltacvars c))) (* This seems fairly hacky, but it's the first way I've found to get proper globalization of [unfold]. --adamc *) @@ -529,7 +539,12 @@ let rec intern_atomic lf ist x = then intern_type ist c else intern_constr ist c), clause_app (intern_hyp_location ist) cl) | TacChange (Some p,c,cl) -> - TacChange (Some (intern_typed_pattern ist p),intern_constr ist c, + let { ltacvars } = ist in + let metas,pat = intern_typed_pattern ist ~as_type:false ~ltacvars p in + let fold accu x = Id.Set.add x accu in + let ltacvars = List.fold_left fold ltacvars metas in + let ist' = { ist with ltacvars } in + TacChange (Some pat,intern_constr ist' c, clause_app (intern_hyp_location ist) cl) (* Equality and inversion *) diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index 20f117ff4f..fd75862c6f 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -38,6 +38,7 @@ open Tacintern open Taccoerce open Proofview.Notations open Context.Named.Declaration +open Ltac_pretype let ltac_trace_info = Tactic_debug.ltac_trace_info @@ -75,6 +76,9 @@ let out_gen wit v = let val_tag wit = val_tag (topwit wit) +let base_val_typ wit = + match val_tag wit with Val.Base t -> t | _ -> anomaly (str "Not a base val.") + let pr_argument_type arg = let Val.Dyn (tag, _) = arg in Val.pr tag @@ -123,6 +127,8 @@ type tacvalue = let (wit_tacvalue : (Empty.t, tacvalue, tacvalue) Genarg.genarg_type) = let wit = Genarg.create_arg "tacvalue" in let () = register_val0 wit None in + let () = Genprint.register_val_print0 (base_val_typ wit) + (fun _ -> Genprint.PrinterBasic (fun () -> str "<tactic closure>")) in wit let of_tacvalue v = in_gen (topwit wit_tacvalue) v @@ -230,24 +236,16 @@ let curr_debug ist = match TacStore.get ist.extra f_debug with (* Displays a value *) let pr_value env v = let v = Value.normalize v in - if has_type v (topwit wit_tacvalue) then str "a tactic" - else if has_type v (topwit wit_constr_context) then - let c = out_gen (topwit wit_constr_context) v in - match env with - | Some (env,sigma) -> pr_leconstr_env env sigma c - | _ -> str "a term" - else if has_type v (topwit wit_constr) then - let c = out_gen (topwit wit_constr) v in + let pr_with_env pr = match env with - | Some (env,sigma) -> pr_leconstr_env env sigma c - | _ -> str "a term" - else if has_type v (topwit wit_constr_under_binders) then - let c = out_gen (topwit wit_constr_under_binders) v in - match env with - | Some (env,sigma) -> pr_lconstr_under_binders_env env sigma c - | _ -> str "a term" - else - str "a value of type" ++ spc () ++ pr_argument_type v + | Some (env,sigma) -> pr env sigma + | None -> str "a value of type" ++ spc () ++ pr_argument_type v in + let open Genprint in + match generic_val_print v with + | PrinterBasic pr -> pr () + | PrinterNeedsContext pr -> pr_with_env pr + | PrinterNeedsContextAndLevel { default_already_surrounded; printer } -> + pr_with_env (fun env sigma -> printer env sigma default_already_surrounded) let pr_closure env ist body = let pp_body = Pptactic.pr_glob_tactic env body in @@ -551,7 +549,6 @@ let interp_fresh_id ist env sigma l = (* Extract the uconstr list from lfun *) let extract_ltac_constr_context ist env sigma = - let open Glob_term in let add_uconstr id v map = try Id.Map.add id (coerce_to_uconstr env v) map with CannotCoerceTo _ -> map @@ -602,10 +599,10 @@ let interp_gen kind ist pattern_mode flags env sigma c = let { closure = constrvars ; term } = interp_glob_closure ist env sigma ~kind:kind_for_intern ~pattern_mode c in let vars = { - Glob_term.ltac_constrs = constrvars.typed; - Glob_term.ltac_uconstrs = constrvars.untyped; - Glob_term.ltac_idents = constrvars.idents; - Glob_term.ltac_genargs = ist.lfun; + ltac_constrs = constrvars.typed; + ltac_uconstrs = constrvars.untyped; + ltac_idents = constrvars.idents; + ltac_genargs = ist.lfun; } in (* Jason Gross: To avoid unnecessary modifications to tacinterp, as suggested by Arnaud Spiwack, we run push_trace immediately. We do @@ -818,51 +815,16 @@ let interp_constr_may_eval ist env sigma c = end (** TODO: should use dedicated printers *) -let rec message_of_value v = +let message_of_value v = let v = Value.normalize v in - let open Ftactic in - if has_type v (topwit wit_tacvalue) then - Ftactic.return (str "<tactic>") - else if has_type v (topwit wit_constr) then - let v = out_gen (topwit wit_constr) v in - Ftactic.enter begin fun gl -> Ftactic.return (pr_econstr_env (pf_env gl) (project gl) v) end - else if has_type v (topwit wit_constr_under_binders) then - let c = out_gen (topwit wit_constr_under_binders) v in - Ftactic.enter begin fun gl -> - Ftactic.return (pr_constr_under_binders_env (pf_env gl) (project gl) c) - end - else if has_type v (topwit wit_unit) then - Ftactic.return (str "()") - else if has_type v (topwit wit_int) then - Ftactic.return (int (out_gen (topwit wit_int) v)) - else if has_type v (topwit wit_intro_pattern) then - let p = out_gen (topwit wit_intro_pattern) v in - let print env sigma c = - let (sigma, c) = c env sigma in - pr_econstr_env env sigma c - in - Ftactic.enter begin fun gl -> - Ftactic.return (Miscprint.pr_intro_pattern (fun c -> print (pf_env gl) (project gl) c) p) - end - else if has_type v (topwit wit_constr_context) then - let c = out_gen (topwit wit_constr_context) v in - Ftactic.enter begin fun gl -> Ftactic.return (pr_econstr_env (pf_env gl) (project gl) c) end - else if has_type v (topwit wit_uconstr) then - let c = out_gen (topwit wit_uconstr) v in - Ftactic.enter begin fun gl -> - Ftactic.return (pr_closed_glob_env (pf_env gl) - (project gl) c) - end - else if has_type v (topwit wit_var) then - let id = out_gen (topwit wit_var) v in - Ftactic.enter begin fun gl -> Ftactic.return (Id.print id) end - else match Value.to_list v with - | Some l -> - Ftactic.List.map message_of_value l >>= fun l -> - Ftactic.return (prlist_with_sep spc (fun x -> x) l) - | None -> - let tag = pr_argument_type v in - Ftactic.return (str "<" ++ tag ++ str ">") (** TODO *) + let pr_with_env pr = + Ftactic.enter begin fun gl -> Ftactic.return (pr (pf_env gl) (project gl)) end in + let open Genprint in + match generic_val_print v with + | PrinterBasic pr -> Ftactic.return (pr ()) + | PrinterNeedsContext pr -> pr_with_env pr + | PrinterNeedsContextAndLevel { default_ensure_surrounded; printer } -> + pr_with_env (fun env sigma -> printer env sigma default_ensure_surrounded) let interp_message_token ist = function | MsgString s -> Ftactic.return (str s) @@ -946,13 +908,13 @@ let interp_in_hyp_as ist env sigma (id,ipat) = let sigma, ipat = interp_intro_pattern_option ist env sigma ipat in sigma,(interp_hyp ist env sigma id,ipat) -let interp_binding_name ist sigma = function +let interp_binding_name ist env sigma = function | AnonHyp n -> AnonHyp n | NamedHyp id -> (* If a name is bound, it has to be a quantified hypothesis *) (* user has to use other names for variables if these ones clash with *) (* a name intented to be used as a (non-variable) identifier *) - try try_interp_ltac_var (coerce_to_quantified_hypothesis sigma) ist None(Loc.tag id) + try try_interp_ltac_var (coerce_to_quantified_hypothesis sigma) ist (Some (env,sigma)) (Loc.tag id) with Not_found -> NamedHyp id let interp_declared_or_quantified_hypothesis ist env sigma = function @@ -964,7 +926,7 @@ let interp_declared_or_quantified_hypothesis ist env sigma = function let interp_binding ist env sigma (loc,(b,c)) = let sigma, c = interp_open_constr ist env sigma c in - sigma, (loc,(interp_binding_name ist sigma b,c)) + sigma, (loc,(interp_binding_name ist env sigma b,c)) let interp_bindings ist env sigma = function | NoBindings -> @@ -1386,10 +1348,14 @@ and interp_app loc ist fv largs : Val.t Ftactic.t = end >>= fun v -> (* No errors happened, we propagate the trace *) let v = append_trace trace v in - Proofview.tclLIFT begin - debugging_step ist - (fun () -> - str"evaluation returns"++fnl()++pr_value None v) + let call_debug env = + Proofview.tclLIFT (debugging_step ist (fun () -> str"evaluation returns"++fnl()++pr_value env v)) in + begin + let open Genprint in + match generic_val_print v with + | PrinterBasic _ -> call_debug None + | PrinterNeedsContext _ | PrinterNeedsContextAndLevel _ -> + Proofview.Goal.enter (fun gl -> call_debug (Some (pf_env gl,project gl))) end <*> if List.is_empty lval then Ftactic.return v else interp_app loc ist v lval else diff --git a/plugins/ltac/tacinterp.mli b/plugins/ltac/tacinterp.mli index d0a0a81d4c..5f2723a1e3 100644 --- a/plugins/ltac/tacinterp.mli +++ b/plugins/ltac/tacinterp.mli @@ -44,7 +44,7 @@ val f_avoid_ids : Id.Set.t TacStore.field val f_debug : debug_info TacStore.field val extract_ltac_constr_values : interp_sign -> Environ.env -> - Pattern.constr_under_binders Id.Map.t + Ltac_pretype.constr_under_binders Id.Map.t (** Given an interpretation signature, extract all values which are coercible to a [constr]. *) @@ -57,7 +57,7 @@ val get_debug : unit -> debug_info val type_uconstr : ?flags:Pretyping.inference_flags -> ?expected_type:Pretyping.typing_constraint -> - Geninterp.interp_sign -> Glob_term.closed_glob_constr -> constr Tactypes.delayed_open + Geninterp.interp_sign -> Ltac_pretype.closed_glob_constr -> constr Tactypes.delayed_open (** Adds an interpretation function for extra generic arguments *) @@ -79,10 +79,10 @@ val interp_hyp : interp_sign -> Environ.env -> Evd.evar_map -> val interp_glob_closure : interp_sign -> Environ.env -> Evd.evar_map -> ?kind:Pretyping.typing_constraint -> ?pattern_mode:bool -> glob_constr_and_expr -> - Glob_term.closed_glob_constr + Ltac_pretype.closed_glob_constr val interp_uconstr : interp_sign -> Environ.env -> Evd.evar_map -> - glob_constr_and_expr -> Glob_term.closed_glob_constr + glob_constr_and_expr -> Ltac_pretype.closed_glob_constr val interp_constr_gen : Pretyping.typing_constraint -> interp_sign -> Environ.env -> Evd.evar_map -> glob_constr_and_expr -> Evd.evar_map * constr diff --git a/plugins/ltac/tactic_debug.ml b/plugins/ltac/tactic_debug.ml index 5394b1e116..a669692fc9 100644 --- a/plugins/ltac/tactic_debug.ml +++ b/plugins/ltac/tactic_debug.ml @@ -363,7 +363,7 @@ let explain_ltac_call_trace last trace loc = | Tacexpr.LtacAtomCall te -> quote (Pptactic.pr_glob_tactic (Global.env()) (Tacexpr.TacAtom (Loc.tag te))) - | Tacexpr.LtacConstrInterp (c, { Glob_term.ltac_constrs = vars }) -> + | Tacexpr.LtacConstrInterp (c, { Ltac_pretype.ltac_constrs = vars }) -> quote (Printer.pr_glob_constr_env (Global.env()) c) ++ (if not (Id.Map.is_empty vars) then strbrk " (with " ++ diff --git a/plugins/ltac/tactic_matching.ml b/plugins/ltac/tactic_matching.ml index 18bb7d2dbd..89b78e5907 100644 --- a/plugins/ltac/tactic_matching.ml +++ b/plugins/ltac/tactic_matching.ml @@ -22,7 +22,7 @@ module NamedDecl = Context.Named.Declaration those of {!Matching.matching_result}), and a {!Term.constr} substitution mapping corresponding to matched hypotheses. *) type 'a t = { - subst : Constr_matching.bound_ident_map * Pattern.extended_patvar_map ; + subst : Constr_matching.bound_ident_map * Ltac_pretype.extended_patvar_map ; context : EConstr.constr Id.Map.t; terms : EConstr.constr Id.Map.t; lhs : 'a; @@ -36,8 +36,8 @@ type 'a t = { (** Some of the functions of {!Matching} return the substitution with a [patvar_map] instead of an [extended_patvar_map]. [adjust] coerces substitution of the former type to the latter. *) -let adjust : Constr_matching.bound_ident_map * Pattern.patvar_map -> - Constr_matching.bound_ident_map * Pattern.extended_patvar_map = +let adjust : Constr_matching.bound_ident_map * Ltac_pretype.patvar_map -> + Constr_matching.bound_ident_map * Ltac_pretype.extended_patvar_map = fun (l, lc) -> (l, Id.Map.map (fun c -> [], c) lc) diff --git a/plugins/ltac/tactic_matching.mli b/plugins/ltac/tactic_matching.mli index 01334d36c9..955f8105fb 100644 --- a/plugins/ltac/tactic_matching.mli +++ b/plugins/ltac/tactic_matching.mli @@ -18,7 +18,7 @@ those of {!Matching.matching_result}), and a {!Term.constr} substitution mapping corresponding to matched hypotheses. *) type 'a t = { - subst : Constr_matching.bound_ident_map * Pattern.extended_patvar_map ; + subst : Constr_matching.bound_ident_map * Ltac_pretype.extended_patvar_map ; context : EConstr.constr Names.Id.Map.t; terms : EConstr.constr Names.Id.Map.t; lhs : 'a; diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index d37c676e38..1f2d02093d 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -227,7 +227,7 @@ let isAppInd gl c = let interp_refine ist gl rc = let constrvars = Tacinterp.extract_ltac_constr_values ist (pf_env gl) in let vars = { Glob_ops.empty_lvar with - Glob_term.ltac_constrs = constrvars; ltac_genargs = ist.Tacinterp.lfun + Ltac_pretype.ltac_constrs = constrvars; ltac_genargs = ist.Tacinterp.lfun } in let kind = Pretyping.OfType (pf_concl gl) in let flags = { diff --git a/plugins/ssr/ssrelim.ml b/plugins/ssr/ssrelim.ml index 832044909c..26b5c57675 100644 --- a/plugins/ssr/ssrelim.ml +++ b/plugins/ssr/ssrelim.ml @@ -396,7 +396,7 @@ let revtoptac n0 gl = let equality_inj l b id c gl = let msg = ref "" in - try Proofview.V82.of_tactic (Equality.inj l b None c) gl + try Proofview.V82.of_tactic (Equality.inj None l b None c) gl with | Ploc.Exc(_,CErrors.UserError (_,s)) | CErrors.UserError (_,s) diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 08ce72932a..aefa09dbe6 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -33,6 +33,7 @@ open Evarsolve open Evarconv open Evd open Context.Rel.Declaration +open Ltac_pretype module RelDecl = Context.Rel.Declaration module NamedDecl = Context.Named.Declaration @@ -245,7 +246,7 @@ let push_history_pattern n pci cont = type 'a pattern_matching_problem = { env : env; - lvar : Glob_term.ltac_var_map; + lvar : Ltac_pretype.ltac_var_map; evdref : evar_map ref; pred : constr; tomatch : tomatch_stack; diff --git a/pretyping/cases.mli b/pretyping/cases.mli index 7bdc604b88..cbf5788e48 100644 --- a/pretyping/cases.mli +++ b/pretyping/cases.mli @@ -14,6 +14,7 @@ open EConstr open Inductiveops open Glob_term open Evarutil +open Ltac_pretype (** {5 Compilation of pattern-matching } *) @@ -101,7 +102,7 @@ and pattern_continuation = type 'a pattern_matching_problem = { env : env; - lvar : Glob_term.ltac_var_map; + lvar : Ltac_pretype.ltac_var_map; evdref : evar_map ref; pred : constr; tomatch : tomatch_stack; @@ -119,11 +120,11 @@ val prepare_predicate : ?loc:Loc.t -> Environ.env -> Evd.evar_map ref -> ltac_var_map -> glob_constr -> unsafe_judgment) -> Environ.env -> Evd.evar_map -> - Glob_term.ltac_var_map -> + Ltac_pretype.ltac_var_map -> (types * tomatch_type) list -> (rel_context * rel_context) list -> constr option -> glob_constr option -> (Evd.evar_map * Names.name list * constr) list val make_return_predicate_ltac_lvar : Evd.evar_map -> Names.name -> - Glob_term.glob_constr -> constr -> Glob_term.ltac_var_map -> Glob_term.ltac_var_map + Glob_term.glob_constr -> constr -> Ltac_pretype.ltac_var_map -> ltac_var_map diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml index 0973d73ee0..ddef1cee96 100644 --- a/pretyping/constr_matching.ml +++ b/pretyping/constr_matching.ml @@ -22,6 +22,7 @@ open Pattern open Patternops open Misctypes open Context.Rel.Declaration +open Ltac_pretype (*i*) (* Given a term with second-order variables in it, @@ -212,7 +213,7 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels let open EConstr in let convref ref c = match ref, EConstr.kind sigma c with - | VarRef id, Var id' -> Names.id_eq id id' + | VarRef id, Var id' -> Names.Id.equal id id' | ConstRef c, Const (c',_) -> Names.eq_constant c c' | IndRef i, Ind (i', _) -> Names.eq_ind i i' | ConstructRef c, Construct (c',u) -> Names.eq_constructor c c' diff --git a/pretyping/constr_matching.mli b/pretyping/constr_matching.mli index 1d7019d09f..34c62043ef 100644 --- a/pretyping/constr_matching.mli +++ b/pretyping/constr_matching.mli @@ -13,6 +13,7 @@ open Term open EConstr open Environ open Pattern +open Ltac_pretype type binding_bound_vars = Id.Set.t diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index f3e8e72bb7..c02fc5aafd 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -27,6 +27,7 @@ open Mod_subst open Misctypes open Decl_kinds open Context.Named.Declaration +open Ltac_pretype type _ delay = | Now : 'a delay diff --git a/pretyping/detyping.mli b/pretyping/detyping.mli index b70bfd83c1..f03bde68ec 100644 --- a/pretyping/detyping.mli +++ b/pretyping/detyping.mli @@ -15,6 +15,7 @@ open Termops open Mod_subst open Misctypes open Evd +open Ltac_pretype type _ delay = | Now : 'a delay diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index ad1409f5b1..b906c3b597 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -842,6 +842,25 @@ let rec find_solution_type evarenv = function | (id,ProjectEvar _)::l -> find_solution_type evarenv l | [] -> assert false +let is_preferred_projection_over sign (id,p) (id',p') = + (* We give priority to projection of variables over instantiation of + an evar considering that the latter is a stronger decision which + may even procude an incorrect (ill-typed) solution *) + match p, p' with + | ProjectEvar _, ProjectVar -> false + | ProjectVar, ProjectEvar _ -> true + | _, _ -> + List.index Id.equal id sign < List.index Id.equal id' sign + +let choose_projection evi sols = + let sign = List.map get_id (evar_filtered_context evi) in + match sols with + | y::l -> + List.fold_right (fun (id,p as x) (id',_ as y) -> + if is_preferred_projection_over sign x y then x else y) + l y + | _ -> assert false + (* In case the solution to a projection problem requires the instantiation of * subsidiary evars, [do_projection_effects] performs them; it * also try to instantiate the type of those subsidiary evars if their @@ -1002,7 +1021,7 @@ let closure_of_filter evd evk = function | Some filter -> let evi = Evd.find_undefined evd evk in let vars = collect_vars evd (EConstr.of_constr (evar_concl evi)) in - let test b decl = b || Idset.mem (get_id decl) vars || + let test b decl = b || Id.Set.mem (get_id decl) vars || match decl with | LocalAssum _ -> false @@ -1429,8 +1448,12 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = let c, p = match sols with | [] -> raise Not_found | [id,p] -> (mkVar id, p) - | (id,p)::_::_ -> - if choose then (mkVar id, p) else raise (NotUniqueInType sols) + | _ -> + if choose then + let (id,p) = choose_projection evi sols in + (mkVar id, p) + else + raise (NotUniqueInType sols) in let ty = lazy (Retyping.get_type_of env !evdref (of_alias t)) in let evd = do_projection_effects (evar_define conv_algo ~choose) env ty !evdref p in @@ -1551,19 +1574,19 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = let rhs = whd_beta evd rhs (* heuristic *) in let fast rhs = let filter_ctxt = evar_filtered_context evi in - let names = ref Idset.empty in + let names = ref Id.Set.empty in let rec is_id_subst ctxt s = match ctxt, s with | (decl :: ctxt'), (c :: s') -> let id = get_id decl in - names := Idset.add id !names; + names := Id.Set.add id !names; isVarId evd id c && is_id_subst ctxt' s' | [], [] -> true | _ -> false in is_id_subst filter_ctxt (Array.to_list argsv) && closed0 evd rhs && - Idset.subset (collect_vars evd rhs) !names + Id.Set.subset (collect_vars evd rhs) !names in let body = if fast rhs then EConstr.of_constr (EConstr.to_constr evd rhs) (** FIXME? *) diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml index 7804cc6796..055fd68f6c 100644 --- a/pretyping/glob_ops.ml +++ b/pretyping/glob_ops.ml @@ -13,6 +13,7 @@ open Globnames open Misctypes open Glob_term open Evar_kinds +open Ltac_pretype (* Untyped intermediate terms, after ASTs and before constr. *) diff --git a/pretyping/glob_ops.mli b/pretyping/glob_ops.mli index 49ea9727c6..f27928662e 100644 --- a/pretyping/glob_ops.mli +++ b/pretyping/glob_ops.mli @@ -84,5 +84,5 @@ val glob_constr_of_closed_cases_pattern : 'a cases_pattern_g -> Name.t * 'a glob val add_patterns_for_params_remove_local_defs : constructor -> 'a cases_pattern_g list -> 'a cases_pattern_g list -val ltac_interp_name : Glob_term.ltac_var_map -> Names.name -> Names.name -val empty_lvar : Glob_term.ltac_var_map +val ltac_interp_name : Ltac_pretype.ltac_var_map -> Names.name -> Names.name +val empty_lvar : Ltac_pretype.ltac_var_map diff --git a/pretyping/ltac_pretype.ml b/pretyping/ltac_pretype.ml new file mode 100644 index 0000000000..be8579c2e5 --- /dev/null +++ b/pretyping/ltac_pretype.ml @@ -0,0 +1,68 @@ +open Names +open Glob_term + +(** {5 Maps of pattern variables} *) + +(** Type [constr_under_binders] is for representing the term resulting + of a matching. Matching can return terms defined in a some context + of named binders; in the context, variable names are ordered by + (<) and referred to by index in the term Thanks to the canonical + ordering, a matching problem like + + [match ... with [(fun x y => ?p,fun y x => ?p)] => [forall x y => p]] + + will be accepted. Thanks to the reference by index, a matching + problem like + + [match ... with [(fun x => ?p)] => [forall x => p]] + + will work even if [x] is also the name of an existing goal + variable. + + Note: we do not keep types in the signature. Besides simplicity, + the main reason is that it would force to close the signature over + binders that occur only in the types of effective binders but not + in the term itself (e.g. for a term [f x] with [f:A -> True] and + [x:A]). + + On the opposite side, by not keeping the types, we loose + opportunity to propagate type informations which otherwise would + not be inferable, as e.g. when matching [forall x, x = 0] with + pattern [forall x, ?h = 0] and using the solution "x|-h:=x" in + expression [forall x, h = x] where nothing tells how the type of x + could be inferred. We also loose the ability of typing ltac + variables before calling the right-hand-side of ltac matching clauses. *) + +type constr_under_binders = Id.t list * EConstr.constr + +(** Types of substitutions with or w/o bound variables *) + +type patvar_map = EConstr.constr Id.Map.t +type extended_patvar_map = constr_under_binders Id.Map.t + +(** A globalised term together with a closure representing the value + of its free variables. Intended for use when these variables are taken + from the Ltac environment. *) +type closure = { + idents:Id.t Id.Map.t; + typed: constr_under_binders Id.Map.t ; + untyped:closed_glob_constr Id.Map.t } +and closed_glob_constr = { + closure: closure; + term: glob_constr } + +(** Ltac variable maps *) +type var_map = constr_under_binders Id.Map.t +type uconstr_var_map = closed_glob_constr Id.Map.t +type unbound_ltac_var_map = Geninterp.Val.t Id.Map.t + +type ltac_var_map = { + ltac_constrs : var_map; + (** Ltac variables bound to constrs *) + ltac_uconstrs : uconstr_var_map; + (** Ltac variables bound to untyped constrs *) + ltac_idents: Id.t Id.Map.t; + (** Ltac variables bound to identifiers *) + ltac_genargs : unbound_ltac_var_map; + (** Ltac variables bound to other kinds of arguments *) +} diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index 1038945c18..fe134f5126 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -88,7 +88,7 @@ let invert_tag cst tag reloc_tbl = let decompose_prod env t = let (name,dom,codom as res) = destProd (whd_all env t) in match name with - | Anonymous -> (Name (id_of_string "x"),dom,codom) + | Anonymous -> (Name (Id.of_string "x"),dom,codom) | _ -> res let app_type env c = @@ -321,7 +321,7 @@ and nf_atom_type env sigma atom = mkCase(ci, p, a, branchs), tcase | Afix(tt,ft,rp,s) -> let tt = Array.map (fun t -> nf_type env sigma t) tt in - let name = Array.map (fun _ -> (Name (id_of_string "Ffix"))) tt in + let name = Array.map (fun _ -> (Name (Id.of_string "Ffix"))) tt in let lvl = nb_rel env in let nbfix = Array.length ft in let fargs = mk_rels_accu lvl (Array.length ft) in @@ -334,7 +334,7 @@ and nf_atom_type env sigma atom = mkFix((rp,s),(name,tt,ft)), tt.(s) | Acofix(tt,ft,s,_) | Acofixe(tt,ft,s,_) -> let tt = Array.map (nf_type env sigma) tt in - let name = Array.map (fun _ -> (Name (id_of_string "Fcofix"))) tt in + let name = Array.map (fun _ -> (Name (Id.of_string "Fcofix"))) tt in let lvl = nb_rel env in let fargs = mk_rels_accu lvl (Array.length ft) in let env = push_rec_types (name,tt,[||]) env in @@ -376,7 +376,7 @@ and nf_predicate env sigma ind mip params v pT = | Vfun f, _ -> let k = nb_rel env in let vb = f (mk_rel_accu k) in - let name = Name (id_of_string "c") in + let name = Name (Id.of_string "c") in let n = mip.mind_nrealargs in let rargs = Array.init n (fun i -> mkRel (n-i)) in let params = if Int.equal n 0 then params else Array.map (lift n) params in diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index 3b3ad021e4..aaa9467068 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -96,6 +96,31 @@ let rec occur_meta_pattern = function | PMeta _ | PSoApp _ -> true | PEvar _ | PVar _ | PRef _ | PRel _ | PSort _ | PFix _ | PCoFix _ -> false +let rec occurn_pattern n = function + | PRel p -> Int.equal n p + | PApp (f,args) -> + (occurn_pattern n f) || (Array.exists (occurn_pattern n) args) + | PProj (_,arg) -> occurn_pattern n arg + | PLambda (na,t,c) -> (occurn_pattern n t) || (occurn_pattern (n+1) c) + | PProd (na,t,c) -> (occurn_pattern n t) || (occurn_pattern (n+1) c) + | PLetIn (na,b,t,c) -> + Option.fold_left (fun b t -> b || occurn_pattern n t) (occurn_pattern n b) t || + (occurn_pattern (n+1) c) + | PIf (c,c1,c2) -> + (occurn_pattern n c) || + (occurn_pattern n c1) || (occurn_pattern n c2) + | PCase(_,p,c,br) -> + (occurn_pattern n p) || + (occurn_pattern n c) || + (List.exists (fun (_,_,p) -> occurn_pattern n p) br) + | PMeta _ | PSoApp _ -> true + | PEvar (_,args) -> Array.exists (occurn_pattern n) args + | PVar _ | PRef _ | PSort _ -> false + | PFix fix -> not (noccurn n (mkFix fix)) + | PCoFix cofix -> not (noccurn n (mkCoFix cofix)) + +let noccurn_pattern n c = not (occurn_pattern n c) + exception BoundPattern;; let rec head_pattern_bound t = diff --git a/pretyping/patternops.mli b/pretyping/patternops.mli index 3a1faf1c77..2d1ce1dbc9 100644 --- a/pretyping/patternops.mli +++ b/pretyping/patternops.mli @@ -12,6 +12,7 @@ open Glob_term open Mod_subst open Misctypes open Pattern +open Ltac_pretype (** {5 Functions on patterns} *) @@ -21,6 +22,8 @@ val occur_meta_pattern : constr_pattern -> bool val subst_pattern : substitution -> constr_pattern -> constr_pattern +val noccurn_pattern : int -> constr_pattern -> bool + exception BoundPattern (** [head_pattern_bound t] extracts the head variable/constant of the diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index ea1f2de539..b2b583ba74 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -43,6 +43,7 @@ open Glob_term open Glob_ops open Evarconv open Misctypes +open Ltac_pretype module NamedDecl = Context.Named.Declaration @@ -201,7 +202,7 @@ let interp_universe_level_name ~anon_rigidity evd (loc, s) = with Not_found -> try let id = try Id.of_string s with _ -> raise Not_found in - evd, snd (Idmap.find id names) + evd, snd (Id.Map.find id names) with Not_found -> if not (is_strict_universe_declarations ()) then new_univ_level_variable ?loc ~name:s univ_rigid evd @@ -887,6 +888,9 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre | [], [] -> [] | _ -> assert false in aux 1 1 (List.rev nal) cs.cs_args, true in + let fsign = if Flags.version_strictly_greater Flags.V8_6 || Flags.version_less_or_equal Flags.VOld + then Context.Rel.map (whd_betaiota !evdref) fsign + else fsign (* beta-iota-normalization regression in 8.5 and 8.6 *) in let obj ind p v f = if not record then let nal = List.map (fun na -> ltac_interp_name lvar na) nal in @@ -996,6 +1000,10 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let pi = lift n pred in (* liftn n 2 pred ? *) let pi = beta_applist !evdref (pi, [EConstr.of_constr (build_dependent_constructor cs)]) in let cs_args = List.map (fun d -> map_rel_decl EConstr.of_constr d) cs.cs_args in + let cs_args = + if Flags.version_strictly_greater Flags.V8_6 || Flags.version_less_or_equal Flags.VOld + then Context.Rel.map (whd_betaiota !evdref) cs_args + else cs_args (* beta-iota-normalization regression in 8.5 and 8.6 *) in let csgn = List.map (set_name Anonymous) cs_args in diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index 5822f5add5..6537d1ecf7 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -18,6 +18,7 @@ open Evd open EConstr open Glob_term open Evarutil +open Ltac_pretype (** An auxiliary function for searching for fixpoint guard indexes *) diff --git a/pretyping/pretyping.mllib b/pretyping/pretyping.mllib index d04dcb8e3b..9904b73540 100644 --- a/pretyping/pretyping.mllib +++ b/pretyping/pretyping.mllib @@ -1,3 +1,4 @@ +Ltac_pretype Locusops Pretype_errors Reductionops diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 708788ab87..9451b0f868 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -1051,7 +1051,7 @@ let contextually byhead occs f env sigma t = let match_constr_evaluable_ref sigma c evref = match EConstr.kind sigma c, evref with | Const (c,u), EvalConstRef c' when eq_constant c c' -> Some u - | Var id, EvalVarRef id' when id_eq id id' -> Some EInstance.empty + | Var id, EvalVarRef id' when Id.equal id id' -> Some EInstance.empty | _, _ -> None let substlin env sigma evalref n (nowhere_except_in,locs) c = diff --git a/pretyping/tacred.mli b/pretyping/tacred.mli index 91726e8c6d..a6b8262f7f 100644 --- a/pretyping/tacred.mli +++ b/pretyping/tacred.mli @@ -15,6 +15,7 @@ open Pattern open Globnames open Locus open Univ +open Ltac_pretype type reduction_tactic_error = InvalidAbstraction of env * evar_map * constr * (env * Type_errors.type_error) diff --git a/pretyping/unification.ml b/pretyping/unification.ml index e8f7e2bbaf..86ebc1f01f 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -194,6 +194,10 @@ let pose_all_metas_as_evars env evd t = let {rebus=ty;freemetas=mvs} = Evd.meta_ftype evd mv in let ty = EConstr.of_constr ty in let ty = if Evd.Metaset.is_empty mvs then ty else aux ty in + let ty = + if Flags.version_strictly_greater Flags.V8_6 || Flags.version_less_or_equal Flags.VOld + then nf_betaiota evd ty (* How it was in Coq <= 8.4 (but done in logic.ml at this time) *) + else ty (* some beta-iota-normalization "regression" in 8.5 and 8.6 *) in let src = Evd.evar_source_of_meta mv !evdref in let ev = Evarutil.e_new_evar env evdref ~src ty in evdref := meta_assign mv (EConstr.Unsafe.to_constr ev,(Conv,TypeNotProcessed)) !evdref; diff --git a/printing/genprint.ml b/printing/genprint.ml index 543b05024d..776a212b5c 100644 --- a/printing/genprint.ml +++ b/printing/genprint.ml @@ -8,13 +8,100 @@ open Pp open Genarg +open Geninterp + +(* We register printers at two levels: + - generic arguments for general printers + - generic values for printing ltac values *) + +(* Printing generic values *) + +type printer_with_level = + { default_already_surrounded : Notation_term.tolerability; + default_ensure_surrounded : Notation_term.tolerability; + printer : Environ.env -> Evd.evar_map -> Notation_term.tolerability -> Pp.t } + +type printer_result = +| PrinterBasic of (unit -> Pp.t) +| PrinterNeedsContext of (Environ.env -> Evd.evar_map -> Pp.t) +| PrinterNeedsContextAndLevel of printer_with_level type 'a printer = 'a -> Pp.t +type 'a top_printer = 'a -> printer_result + +module ValMap = ValTMap (struct type 'a t = 'a -> printer_result end) + +let print0_val_map = ref ValMap.empty + +let find_print_val_fun tag = + try ValMap.find tag !print0_val_map + with Not_found -> + let msg s = Pp.(str "print function not found for a value interpreted as " ++ str s ++ str ".") in + CErrors.anomaly (msg (Val.repr tag)) + +let generic_val_print v = + let Val.Dyn (tag,v) = v in + find_print_val_fun tag v + +let register_val_print0 s pr = + print0_val_map := ValMap.add s pr !print0_val_map + +let combine_dont_needs pr_pair pr1 = function + | PrinterBasic pr2 -> + PrinterBasic (fun () -> pr_pair (pr1 ()) (pr2 ())) + | PrinterNeedsContext pr2 -> + PrinterNeedsContext (fun env sigma -> + pr_pair (pr1 ()) (pr2 env sigma)) + | PrinterNeedsContextAndLevel { default_ensure_surrounded; printer } -> + PrinterNeedsContext (fun env sigma -> + pr_pair (pr1 ()) (printer env sigma default_ensure_surrounded)) + +let combine_needs pr_pair pr1 = function + | PrinterBasic pr2 -> + PrinterNeedsContext (fun env sigma -> pr_pair (pr1 env sigma) (pr2 ())) + | PrinterNeedsContext pr2 -> + PrinterNeedsContext (fun env sigma -> + pr_pair (pr1 env sigma) (pr2 env sigma)) + | PrinterNeedsContextAndLevel { default_ensure_surrounded; printer } -> + PrinterNeedsContext (fun env sigma -> + pr_pair (pr1 env sigma) (printer env sigma default_ensure_surrounded)) + +let combine pr_pair pr1 v2 = + match pr1 with + | PrinterBasic pr1 -> + combine_dont_needs pr_pair pr1 (generic_val_print v2) + | PrinterNeedsContext pr1 -> + combine_needs pr_pair pr1 (generic_val_print v2) + | PrinterNeedsContextAndLevel { default_ensure_surrounded; printer } -> + combine_needs pr_pair (fun env sigma -> printer env sigma default_ensure_surrounded) + (generic_val_print v2) + +let _ = + let pr_cons a b = Pp.(a ++ spc () ++ b) in + register_val_print0 Val.typ_list + (function + | [] -> PrinterBasic mt + | a::l -> + List.fold_left (combine pr_cons) (generic_val_print a) l) + +let _ = + register_val_print0 Val.typ_opt + (function + | None -> PrinterBasic Pp.mt + | Some v -> generic_val_print v) + +let _ = + let pr_pair a b = Pp.(a ++ spc () ++ b) in + register_val_print0 Val.typ_pair + (fun (v1,v2) -> combine pr_pair (generic_val_print v1) v2) + +(* Printing generic arguments *) + type ('raw, 'glb, 'top) genprinter = { raw : 'raw printer; glb : 'glb printer; - top : 'top printer; + top : 'top -> printer_result; } module PrintObj = @@ -27,7 +114,7 @@ struct let printer = { raw = (fun _ -> str "<genarg:" ++ str name ++ str ">"); glb = (fun _ -> str "<genarg:" ++ str name ++ str ">"); - top = (fun _ -> str "<genarg:" ++ str name ++ str ">"); + top = (fun _ -> PrinterBasic (fun () -> str "<genarg:" ++ str name ++ str ">")); } in Some printer | _ -> assert false @@ -37,6 +124,18 @@ module Print = Register (PrintObj) let register_print0 wit raw glb top = let printer = { raw; glb; top; } in + Print.register0 wit printer; + match val_tag (Topwit wit), wit with + | Val.Base t, ExtraArg t' when Geninterp.Val.repr t = ArgT.repr t' -> + register_val_print0 t top + | _ -> + (* An alias, thus no primitive printer attached *) + () + +let register_vernac_print0 wit raw = + let glb _ = CErrors.anomaly (Pp.str "vernac argument needs not globwit printer.") in + let top _ = CErrors.anomaly (Pp.str "vernac argument needs not wit printer.") in + let printer = { raw; glb; top; } in Print.register0 wit printer let raw_print wit v = (Print.obj wit).raw v diff --git a/printing/genprint.mli b/printing/genprint.mli index 130a89c929..2da9bbc36b 100644 --- a/printing/genprint.mli +++ b/printing/genprint.mli @@ -10,20 +10,37 @@ open Genarg +type printer_with_level = + { default_already_surrounded : Notation_term.tolerability; + default_ensure_surrounded : Notation_term.tolerability; + printer : Environ.env -> Evd.evar_map -> Notation_term.tolerability -> Pp.t } + +type printer_result = +| PrinterBasic of (unit -> Pp.t) +| PrinterNeedsContext of (Environ.env -> Evd.evar_map -> Pp.t) +| PrinterNeedsContextAndLevel of printer_with_level + type 'a printer = 'a -> Pp.t -val raw_print : ('raw, 'glb, 'top) genarg_type -> 'raw -> Pp.t +type 'a top_printer = 'a -> printer_result + +val raw_print : ('raw, 'glb, 'top) genarg_type -> 'raw printer (** Printer for raw level generic arguments. *) -val glb_print : ('raw, 'glb, 'top) genarg_type -> 'glb -> Pp.t +val glb_print : ('raw, 'glb, 'top) genarg_type -> 'glb printer (** Printer for glob level generic arguments. *) -val top_print : ('raw, 'glb, 'top) genarg_type -> 'top -> Pp.t +val top_print : ('raw, 'glb, 'top) genarg_type -> 'top top_printer (** Printer for top level generic arguments. *) +val register_print0 : ('raw, 'glb, 'top) genarg_type -> + 'raw printer -> 'glb printer -> ('top -> printer_result) -> unit +val register_val_print0 : 'top Geninterp.Val.typ -> + 'top top_printer -> unit +val register_vernac_print0 : ('raw, 'glb, 'top) genarg_type -> + 'raw printer -> unit + val generic_raw_print : rlevel generic_argument printer val generic_glb_print : glevel generic_argument printer -val generic_top_print : tlevel generic_argument printer - -val register_print0 : ('raw, 'glb, 'top) genarg_type -> - 'raw printer -> 'glb printer -> 'top printer -> unit +val generic_top_print : tlevel generic_argument top_printer +val generic_val_print : Geninterp.Val.t top_printer diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index 102c6ef6de..109a40a037 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -738,34 +738,40 @@ let tag_var = tag Tag.variable pr_lconstr_pattern_expr : constr_pattern_expr -> Pp.t } - type precedence = Notation_term.precedence * Notation_term.parenRelation let modular_constr_pr = pr let rec fix rf x = rf (fix rf) x let pr = fix modular_constr_pr mt + let pr prec = function + (* A toplevel printer hack mimicking parsing, incidentally meaning + that we cannot use [pr] correctly anymore in a recursive loop + if the current expr is followed by other exprs which would be + interpreted as arguments *) + | { CAst.v = CAppExpl ((None,f,us),[]) } -> str "@" ++ pr_cref f us + | c -> pr prec c + let transf env c = if !Flags.beautify_file then let r = Constrintern.for_grammar (Constrintern.intern_constr env) c in Constrextern.extern_glob_constr (Termops.vars_of_env env) r else c - let pr prec c = pr prec (transf (Global.env()) c) + let pr_expr prec c = pr prec (transf (Global.env()) c) - let pr_simpleconstr = function - | { CAst.v = CAppExpl ((None,f,us),[]) } -> str "@" ++ pr_cref f us - | c -> pr lsimpleconstr c + let pr_simpleconstr = pr_expr lsimpleconstr let default_term_pr = { pr_constr_expr = pr_simpleconstr; - pr_lconstr_expr = pr ltop; + pr_lconstr_expr = pr_expr ltop; pr_constr_pattern_expr = pr_simpleconstr; - pr_lconstr_pattern_expr = pr ltop + pr_lconstr_pattern_expr = pr_expr ltop } let term_pr = ref default_term_pr let set_term_pr = (:=) term_pr + let pr_constr_expr_n n c = pr_expr n c let pr_constr_expr c = !term_pr.pr_constr_expr c let pr_lconstr_expr c = !term_pr.pr_lconstr_expr c let pr_constr_pattern_expr c = !term_pr.pr_constr_pattern_expr c @@ -775,5 +781,5 @@ let tag_var = tag Tag.variable let pr_record_body = pr_record_body_gen pr - let pr_binders = pr_undelimited_binders spc (pr ltop) + let pr_binders = pr_undelimited_binders spc (pr_expr ltop) diff --git a/printing/ppconstr.mli b/printing/ppconstr.mli index 7546c748d8..be96cfce50 100644 --- a/printing/ppconstr.mli +++ b/printing/ppconstr.mli @@ -60,6 +60,7 @@ val pr_lconstr_pattern_expr : constr_pattern_expr -> Pp.t val pr_constr_expr : constr_expr -> Pp.t val pr_lconstr_expr : constr_expr -> Pp.t val pr_cases_pattern_expr : cases_pattern_expr -> Pp.t +val pr_constr_expr_n : tolerability -> constr_expr -> Pp.t type term_pr = { pr_constr_expr : constr_expr -> Pp.t; @@ -86,9 +87,8 @@ val default_term_pr : term_pr Which has the same type. We can turn a modular printer into a printer by taking its fixpoint. *) -type precedence -val lsimpleconstr : precedence -val ltop : precedence +val lsimpleconstr : tolerability +val ltop : tolerability val modular_constr_pr : - ((unit->Pp.t) -> precedence -> constr_expr -> Pp.t) -> - (unit->Pp.t) -> precedence -> constr_expr -> Pp.t + ((unit->Pp.t) -> tolerability -> constr_expr -> Pp.t) -> + (unit->Pp.t) -> tolerability -> constr_expr -> Pp.t diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml index d1158b3d6f..143f9ddcc5 100644 --- a/printing/ppvernac.ml +++ b/printing/ppvernac.ml @@ -574,7 +574,7 @@ open Decl_kinds | OpenSubgoals -> mt () | NthGoal n -> spc () ++ int n | GoalId id -> spc () ++ pr_id id - | GoalUid n -> spc () ++ str n in + in let pr_showable = function | ShowGoal n -> keyword "Show" ++ pr_goal_reference n | ShowProof -> keyword "Show Proof" diff --git a/printing/printer.ml b/printing/printer.ml index 28b10c7812..70e96722d6 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -79,11 +79,14 @@ let _ = and only names of goal/section variables and rel names that do _not_ occur in the scope of the binder to be printed are avoided. *) +let pr_econstr_n_core goal_concl_style env sigma n t = + pr_constr_expr_n n (extern_constr goal_concl_style env sigma t) let pr_econstr_core goal_concl_style env sigma t = pr_constr_expr (extern_constr goal_concl_style env sigma t) let pr_leconstr_core goal_concl_style env sigma t = pr_lconstr_expr (extern_constr goal_concl_style env sigma t) +let pr_constr_n_env env sigma n c = pr_econstr_n_core false env sigma n (EConstr.of_constr c) let pr_lconstr_env env sigma c = pr_leconstr_core false env sigma (EConstr.of_constr c) let pr_constr_env env sigma c = pr_econstr_core false env sigma (EConstr.of_constr c) let _ = Hook.set Refine.pr_constr pr_constr_env @@ -94,6 +97,7 @@ let pr_constr_goal_style_env env sigma c = pr_econstr_core true env sigma (ECons let pr_open_lconstr_env env sigma (_,c) = pr_lconstr_env env sigma c let pr_open_constr_env env sigma (_,c) = pr_constr_env env sigma c +let pr_econstr_n_env env sigma c = pr_econstr_n_core false env sigma c let pr_leconstr_env env sigma c = pr_leconstr_core false env sigma c let pr_econstr_env env sigma c = pr_econstr_core false env sigma c @@ -166,6 +170,8 @@ let pr_glob_constr c = let (sigma, env) = get_current_context () in pr_glob_constr_env env c +let pr_closed_glob_n_env env sigma n c = + pr_constr_expr_n n (extern_closed_glob false env sigma c) let pr_closed_glob_env env sigma c = pr_constr_expr (extern_closed_glob false env sigma c) let pr_closed_glob c = @@ -832,17 +838,6 @@ let pr_goal_by_id id = pr_selected_subgoal (pr_id id) sigma g) with Not_found -> user_err Pp.(str "No such goal.") -let pr_goal_by_uid uid = - let p = Proof_global.give_me_the_proof () in - let g = Goal.get_by_uid uid in - let pr gs = - v 0 (str "goal / evar " ++ str uid ++ str " is:" ++ cut () - ++ pr_goal gs) - in - try - Proof.in_proof p (fun sigma -> pr {it=g;sigma=sigma;}) - with Not_found -> user_err Pp.(str "Invalid goal identifier.") - (* Elementary tactics *) let pr_prim_rule = function diff --git a/printing/printer.mli b/printing/printer.mli index 2c9a4d70e6..f55206f0df 100644 --- a/printing/printer.mli +++ b/printing/printer.mli @@ -14,6 +14,7 @@ open Pattern open Evd open Proof_type open Glob_term +open Ltac_pretype (** These are the entry points for printing terms, context, tac, ... *) @@ -32,6 +33,8 @@ val pr_constr_env : env -> evar_map -> constr -> Pp.t val pr_constr : constr -> Pp.t val pr_constr_goal_style_env : env -> evar_map -> constr -> Pp.t +val pr_constr_n_env : env -> evar_map -> Notation_term.tolerability -> constr -> Pp.t + (** Same, but resilient to [Nametab] errors. Prints fully-qualified names when [shortest_qualid_of_global] has failed. Prints "??" in case of remaining issues (such as reference not in env). *) @@ -47,6 +50,8 @@ val pr_econstr : EConstr.t -> Pp.t val pr_leconstr_env : env -> evar_map -> EConstr.t -> Pp.t val pr_leconstr : EConstr.t -> Pp.t +val pr_econstr_n_env : env -> evar_map -> Notation_term.tolerability -> EConstr.t -> Pp.t + val pr_etype_env : env -> evar_map -> EConstr.types -> Pp.t val pr_letype_env : env -> evar_map -> EConstr.types -> Pp.t @@ -69,6 +74,7 @@ val pr_ltype : types -> Pp.t val pr_type_env : env -> evar_map -> types -> Pp.t val pr_type : types -> Pp.t +val pr_closed_glob_n_env : env -> evar_map -> Notation_term.tolerability -> closed_glob_constr -> Pp.t val pr_closed_glob_env : env -> evar_map -> closed_glob_constr -> Pp.t val pr_closed_glob : closed_glob_constr -> Pp.t @@ -195,7 +201,6 @@ val pr_assumptionset : env -> Term.types ContextObjectMap.t -> Pp.t val pr_goal_by_id : Id.t -> Pp.t -val pr_goal_by_uid : string -> Pp.t type printer_pr = { pr_subgoals : ?pr_first:bool -> Pp.t option -> evar_map -> evar list -> Goal.goal list -> int list -> goal list -> goal list -> Pp.t; diff --git a/proofs/evar_refiner.ml b/proofs/evar_refiner.ml index 48fa2202ee..d38ff7512f 100644 --- a/proofs/evar_refiner.ml +++ b/proofs/evar_refiner.ml @@ -14,6 +14,7 @@ open Evarutil open Evarsolve open Pp open Glob_term +open Ltac_pretype (******************************************) (* Instantiation of existential variables *) diff --git a/proofs/evar_refiner.mli b/proofs/evar_refiner.mli index 5d69715967..a0e3b718a2 100644 --- a/proofs/evar_refiner.mli +++ b/proofs/evar_refiner.mli @@ -8,6 +8,7 @@ open Evd open Glob_term +open Ltac_pretype (** Refinement of existential variables. *) diff --git a/proofs/goal.ml b/proofs/goal.ml index 7d830146f9..61f3e4a029 100644 --- a/proofs/goal.ml +++ b/proofs/goal.ml @@ -21,7 +21,6 @@ type goal = Evd.evar let pr_goal e = str "GOAL:" ++ Pp.int (Evar.repr e) let uid e = string_of_int (Evar.repr e) -let get_by_uid u = Evar.unsafe_of_int (int_of_string u) (* Layer to implement v8.2 tactic engine ontop of the new architecture. Types are different from what they used to be due to a change of the diff --git a/proofs/goal.mli b/proofs/goal.mli index 6d3ec8bd4e..ad968cdfb3 100644 --- a/proofs/goal.mli +++ b/proofs/goal.mli @@ -15,9 +15,6 @@ type goal = Evar.t (* Gives a unique identifier to each goal. The identifier is guaranteed to contain no space. *) val uid : goal -> string -(* Returns the goal (even if it has been partially solved) - corresponding to a unique identifier obtained by {!uid}. *) -val get_by_uid : string -> goal (* Debugging help *) val pr_goal : goal -> Pp.t diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli index 7e6d83b10f..de9f8e700b 100644 --- a/proofs/tacmach.mli +++ b/proofs/tacmach.mli @@ -15,6 +15,7 @@ open Proof_type open Redexpr open Pattern open Locus +open Ltac_pretype (** Operations for handling terms under a local typing context. *) @@ -96,7 +97,7 @@ val pr_glls : goal list sigma -> Pp.t (* Variants of [Tacmach] functions built with the new proof engine *) module New : sig val pf_apply : (env -> evar_map -> 'a) -> 'b Proofview.Goal.t -> 'a - val pf_global : identifier -> 'a Proofview.Goal.t -> Globnames.global_reference + val pf_global : Id.t -> 'a Proofview.Goal.t -> Globnames.global_reference (** FIXME: encapsulate the level in an existential type. *) val of_old : (Proof_type.goal Evd.sigma -> 'a) -> [ `NF ] Proofview.Goal.t -> 'a @@ -117,13 +118,13 @@ module New : sig val pf_type_of : 'a Proofview.Goal.t -> constr -> evar_map * types val pf_conv_x : 'a Proofview.Goal.t -> t -> t -> bool - val pf_get_new_id : identifier -> 'a Proofview.Goal.t -> identifier - val pf_ids_of_hyps : 'a Proofview.Goal.t -> identifier list + val pf_get_new_id : Id.t -> 'a Proofview.Goal.t -> Id.t + val pf_ids_of_hyps : 'a Proofview.Goal.t -> Id.t list val pf_ids_set_of_hyps : 'a Proofview.Goal.t -> Id.Set.t - val pf_hyps_types : 'a Proofview.Goal.t -> (identifier * types) list + val pf_hyps_types : 'a Proofview.Goal.t -> (Id.t * types) list - val pf_get_hyp : identifier -> 'a Proofview.Goal.t -> named_declaration - val pf_get_hyp_typ : identifier -> 'a Proofview.Goal.t -> types + val pf_get_hyp : Id.t -> 'a Proofview.Goal.t -> named_declaration + val pf_get_hyp_typ : Id.t -> 'a Proofview.Goal.t -> types val pf_last_hyp : 'a Proofview.Goal.t -> named_declaration val pf_nf_concl : [ `LZ ] Proofview.Goal.t -> types diff --git a/stm/asyncTaskQueue.ml b/stm/asyncTaskQueue.ml index 5d9b595d36..a356f32e9d 100644 --- a/stm/asyncTaskQueue.ml +++ b/stm/asyncTaskQueue.ml @@ -49,7 +49,7 @@ end type expiration = bool ref -module Make(T : Task) = struct +module Make(T : Task) () = struct exception Die type response = @@ -107,7 +107,7 @@ module Make(T : Task) = struct let open Feedback in feedback ~id:Stateid.initial (WorkerStatus(id, s)) - module Worker = Spawn.Sync(struct end) + module Worker = Spawn.Sync () module Model = struct @@ -354,5 +354,5 @@ module Make(T : Task) = struct end -module MakeQueue(T : Task) = struct include Make(T) end -module MakeWorker(T : Task) = struct include Make(T) end +module MakeQueue(T : Task) () = struct include Make(T) () end +module MakeWorker(T : Task) () = struct include Make(T) () end diff --git a/stm/asyncTaskQueue.mli b/stm/asyncTaskQueue.mli index a80918e933..1044e668b6 100644 --- a/stm/asyncTaskQueue.mli +++ b/stm/asyncTaskQueue.mli @@ -41,7 +41,7 @@ end type expiration = bool ref -module MakeQueue(T : Task) : sig +module MakeQueue(T : Task) () : sig type queue @@ -76,7 +76,7 @@ module MakeQueue(T : Task) : sig end -module MakeWorker(T : Task) : sig +module MakeWorker(T : Task) () : sig val main_loop : unit -> unit val init_stdout : unit -> unit diff --git a/stm/proofworkertop.ml b/stm/proofworkertop.ml index a27c6d6cd2..10b42f7e91 100644 --- a/stm/proofworkertop.ml +++ b/stm/proofworkertop.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -module W = AsyncTaskQueue.MakeWorker(Stm.ProofTask) +module W = AsyncTaskQueue.MakeWorker(Stm.ProofTask) () let () = Coqtop.toploop_init := WorkerLoop.loop W.init_stdout diff --git a/stm/queryworkertop.ml b/stm/queryworkertop.ml index ac7a270ac6..a1fe50c63e 100644 --- a/stm/queryworkertop.ml +++ b/stm/queryworkertop.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -module W = AsyncTaskQueue.MakeWorker(Stm.QueryTask) +module W = AsyncTaskQueue.MakeWorker(Stm.QueryTask) () let () = Coqtop.toploop_init := WorkerLoop.loop W.init_stdout diff --git a/stm/stm.ml b/stm/stm.ml index 84a4c5cc52..6c22d3771d 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -179,7 +179,7 @@ type 'vcs state_info = { (* TODO: Make this record private to VCS *) let default_info () = { n_reached = 0; n_goals = 0; state = Empty; vcs_backup = None,None } -module DynBlockData : Dyn.S = Dyn.Make(struct end) +module DynBlockData : Dyn.S = Dyn.Make () (* Clusters of nodes implemented as Dag properties. While Dag and Vcs impose * no constraint on properties, here we impose boxes to be non overlapping. @@ -517,8 +517,8 @@ end = struct (* {{{ *) let reachable id = reachable !vcs id let mk_branch_name { expr = x } = Branch.make (let rec aux x = match x with - | VernacDefinition (_,((_,i),_),_) -> Names.string_of_id i - | VernacStartTheoremProof (_,[Some ((_,i),_),_]) -> Names.string_of_id i + | VernacDefinition (_,((_,i),_),_) -> Names.Id.to_string i + | VernacStartTheoremProof (_,[Some ((_,i),_),_]) -> Names.Id.to_string i | VernacTime (_, e) | VernacTimeout (_, e) -> aux e | _ -> "branch" in aux x) @@ -1558,7 +1558,7 @@ and Slaves : sig end = struct (* {{{ *) - module TaskQueue = AsyncTaskQueue.MakeQueue(ProofTask) + module TaskQueue = AsyncTaskQueue.MakeQueue(ProofTask) () let queue = ref None let init () = @@ -1884,7 +1884,7 @@ and Partac : sig end = struct (* {{{ *) - module TaskQueue = AsyncTaskQueue.MakeQueue(TacTask) + module TaskQueue = AsyncTaskQueue.MakeQueue(TacTask) () let vernac_interp ~solve ~abstract cancel nworkers safe_id id { indentation; verbose; loc; expr = e; strlen } @@ -2014,7 +2014,7 @@ and Query : sig end = struct (* {{{ *) - module TaskQueue = AsyncTaskQueue.MakeQueue(QueryTask) + module TaskQueue = AsyncTaskQueue.MakeQueue(QueryTask) () let queue = ref None @@ -3097,7 +3097,7 @@ let current_proof_depth ~doc = let unmangle n = let n = VCS.Branch.to_string n in let idx = String.index n '_' + 1 in - Names.id_of_string (String.sub n idx (String.length n - idx)) + Names.Id.of_string (String.sub n idx (String.length n - idx)) let proofname b = match VCS.get_branch b with | { VCS.kind = (`Proof _| `Edit _) } -> Some b diff --git a/stm/tacworkertop.ml b/stm/tacworkertop.ml index 1716ac0c61..17f90b7b15 100644 --- a/stm/tacworkertop.ml +++ b/stm/tacworkertop.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -module W = AsyncTaskQueue.MakeWorker(Stm.TacTask) +module W = AsyncTaskQueue.MakeWorker(Stm.TacTask) () let () = Coqtop.toploop_init := WorkerLoop.loop W.init_stdout diff --git a/stm/vio_checking.ml b/stm/vio_checking.ml index 9507e90ba7..da6a095ab7 100644 --- a/stm/vio_checking.ml +++ b/stm/vio_checking.ml @@ -14,7 +14,7 @@ let check_vio (ts,f) = Stm.set_compilation_hints long_f_dot_v; List.fold_left (fun acc ids -> Stm.check_task f tasks ids && acc) true ts -module Worker = Spawn.Sync(struct end) +module Worker = Spawn.Sync () module IntOT = struct type t = int diff --git a/tactics/eauto.ml b/tactics/eauto.ml index 2b5bbfcd1b..9097aebd01 100644 --- a/tactics/eauto.ml +++ b/tactics/eauto.ml @@ -439,7 +439,7 @@ let autounfolds db occs cls gl = in let (ids, csts) = Hint_db.unfolds db in let hyps = pf_ids_of_hyps gl in - let ids = Idset.filter (fun id -> List.mem id hyps) ids in + let ids = Id.Set.filter (fun id -> List.mem id hyps) ids in Cset.fold (fun cst -> cons (AllOccurrences, EvalConstRef cst)) csts (Id.Set.fold (fun id -> cons (AllOccurrences, EvalVarRef id)) ids [])) db) in Proofview.V82.of_tactic (unfold_option unfolds cls) gl diff --git a/tactics/eqdecide.ml b/tactics/eqdecide.ml index d912decff4..8764ef085d 100644 --- a/tactics/eqdecide.ml +++ b/tactics/eqdecide.ml @@ -89,6 +89,12 @@ let mkBranches (eqonleft,mk,c1,c2,typ) = clear_last; intros] +let inj_flags = Some { + Equality.keep_proof_equalities = true; (* necessary *) + Equality.injection_in_context = true; (* does not matter here *) + Equality.injection_pattern_l2r_order = true; (* does not matter here *) + } + let discrHyp id = let c env sigma = (sigma, (mkVar id, NoBindings)) in let tac c = Equality.discr_tac false (Some (None, ElimOnConstr c)) in @@ -136,7 +142,7 @@ let eqCase tac = let injHyp id = let c env sigma = (sigma, (mkVar id, NoBindings)) in - let tac c = Equality.injClause None false (Some (None, ElimOnConstr c)) in + let tac c = Equality.injClause inj_flags None false (Some (None, ElimOnConstr c)) in Tacticals.New.tclDELAYEDWITHHOLES false c tac let diseqCase hyps eqonleft = diff --git a/tactics/equality.ml b/tactics/equality.ml index e33dd2e5ed..7c03a3ba6a 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -48,6 +48,12 @@ module NamedDecl = Context.Named.Declaration (* Options *) +type inj_flags = { + keep_proof_equalities : bool; + injection_in_context : bool; + injection_pattern_l2r_order : bool; + } + let discriminate_introduction = ref true let discr_do_intro () = !discriminate_introduction @@ -63,7 +69,9 @@ let _ = let injection_pattern_l2r_order = ref true -let use_injection_pattern_l2r_order () = !injection_pattern_l2r_order +let use_injection_pattern_l2r_order = function + | None -> !injection_pattern_l2r_order + | Some flags -> flags.injection_pattern_l2r_order let _ = declare_bool_option @@ -75,9 +83,9 @@ let _ = let injection_in_context = ref false -let use_injection_in_context () = - !injection_in_context - && Flags.version_strictly_greater Flags.V8_5 +let use_injection_in_context = function + | None -> !injection_in_context && Flags.version_strictly_greater Flags.V8_5 + | Some flags -> flags.injection_in_context let _ = declare_bool_option @@ -721,7 +729,14 @@ let _ = optread = (fun () -> !keep_proof_equalities_for_injection) ; optwrite = (fun b -> keep_proof_equalities_for_injection := b) } -let find_positions env sigma ~no_discr t1 t2 = +let keep_proof_equalities = function + | None -> !keep_proof_equalities_for_injection + | Some flags -> flags.keep_proof_equalities + +(* [keep_proofs] is relevant for types in Prop with elimination in Type *) +(* In particular, it is relevant for injection but not for discriminate *) + +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 @@ -768,20 +783,22 @@ let find_positions env sigma ~no_discr t1 t2 = project env sorts posn t1_0 t2_0 in try - let sorts = if !keep_proof_equalities_for_injection then [InSet;InType;InProp] - else [InSet;InType] - in + let sorts = if keep_proofs then [InSet;InType;InProp] else [InSet;InType] in Inr (findrec sorts [] t1 t2) with DiscrFound (path,c1,c2) -> Inl (path,c1,c2) +let use_keep_proofs = function + | None -> !keep_proof_equalities_for_injection + | Some b -> b + let discriminable env sigma t1 t2 = - match find_positions env sigma ~no_discr:false t1 t2 with + match find_positions env sigma ~keep_proofs:false ~no_discr:false t1 t2 with | Inl _ -> true | _ -> false -let injectable env sigma t1 t2 = - match find_positions env sigma ~no_discr:true t1 t2 with +let injectable env sigma ~keep_proofs t1 t2 = + match find_positions env sigma ~keep_proofs:(use_keep_proofs keep_proofs) ~no_discr:true t1 t2 with | Inl _ -> assert false | Inr [] | Inr [([],_,_)] -> false | Inr _ -> true @@ -1024,7 +1041,7 @@ let discrEq (lbeq,_,(t,t1,t2) as u) eq_clause = let sigma = eq_clause.evd in Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in - match find_positions env sigma ~no_discr:false t1 t2 with + match find_positions env sigma ~keep_proofs:false ~no_discr:false t1 t2 with | Inr _ -> tclZEROMSG (str"Not a discriminable equality.") | Inl (cpath, (_,dirn), _) -> @@ -1069,9 +1086,8 @@ let discr with_evars = onEquality with_evars discrEq let discrClause with_evars = onClause (discrSimpleClause with_evars) let discrEverywhere with_evars = -(* - tclORELSE -*) + tclTHEN (Proofview.tclUNIT ()) + (* Delay the interpretation of side-effect *) (if discr_do_intro () then (tclTHEN (tclREPEAT introf) @@ -1079,9 +1095,7 @@ let discrEverywhere with_evars = (fun id -> tclCOMPLETE (discr with_evars (mkVar id,NoBindings))))) else (* <= 8.2 compat *) tryAllHypsAndConcl (discrSimpleClause with_evars)) -(* (fun gls -> - user_err ~hdr:"DiscrEverywhere" (str"No discriminable equalities.")) -*) + let discr_tac with_evars = function | None -> discrEverywhere with_evars | Some c -> onInductionArg (fun clear_flag -> discr with_evars) c @@ -1403,15 +1417,15 @@ let inject_at_positions env sigma l2r (eq,_,(t,t1,t2)) eq_clause posns tac = (if l2r then List.rev injectors else injectors))) (tac (List.length injectors))) -let injEqThen tac l2r (eq,_,(t,t1,t2) as u) eq_clause = +let injEqThen keep_proofs tac l2r (eq,_,(t,t1,t2) as u) eq_clause = let sigma = eq_clause.evd in let env = eq_clause.env in - match find_positions env sigma ~no_discr:true t1 t2 with + match find_positions env sigma ~keep_proofs ~no_discr:true t1 t2 with | Inl _ -> assert false | Inr [] -> let suggestion = - if !keep_proof_equalities_for_injection then + if keep_proofs then "" else " You can try to use option Set Keep Proof Equalities." in tclZEROMSG (strbrk("No information can be deduced from this equality and the injectivity of constructors. This may be because the terms are convertible, or due to pattern matching restrictions in the sort Prop." ^ suggestion)) @@ -1430,13 +1444,13 @@ let get_previous_hyp_position id gl = in aux MoveLast (Proofview.Goal.hyps (Proofview.Goal.assume gl)) -let injEq ?(old=false) with_evars clear_flag ipats = +let injEq flags ?(old=false) with_evars clear_flag ipats = (* Decide which compatibility mode to use *) let ipats_style, l2r, dft_clear_flag, bounded_intro = match ipats with - | None when not old && use_injection_in_context () -> + | None when not old && use_injection_in_context flags -> Some [], true, true, true | None -> None, false, false, false - | _ -> let b = use_injection_pattern_l2r_order () in ipats, b, b, b in + | _ -> let b = use_injection_pattern_l2r_order flags in ipats, b, b, b in (* Built the post tactic depending on compatibility mode *) let post_tac c n = match ipats_style with @@ -1456,26 +1470,26 @@ let injEq ?(old=false) with_evars clear_flag ipats = tclTHEN clear_tac intro_tac end | None -> tclIDTAC in - injEqThen post_tac l2r + injEqThen (keep_proof_equalities flags) post_tac l2r -let inj ipats with_evars clear_flag = onEquality with_evars (injEq with_evars clear_flag ipats) +let inj flags ipats with_evars clear_flag = onEquality with_evars (injEq flags with_evars clear_flag ipats) -let injClause ipats with_evars = function - | None -> onNegatedEquality with_evars (injEq with_evars None ipats) - | Some c -> onInductionArg (inj ipats with_evars) c +let injClause flags ipats with_evars = function + | None -> onNegatedEquality with_evars (injEq flags with_evars None ipats) + | Some c -> onInductionArg (inj flags ipats with_evars) c -let simpleInjClause with_evars = function - | None -> onNegatedEquality with_evars (injEq ~old:true with_evars None None) - | Some c -> onInductionArg (fun clear_flag -> onEquality with_evars (injEq ~old:true with_evars clear_flag None)) c +let simpleInjClause flags with_evars = function + | None -> onNegatedEquality with_evars (injEq flags ~old:true with_evars None None) + | Some c -> onInductionArg (fun clear_flag -> onEquality with_evars (injEq flags ~old:true with_evars clear_flag None)) c -let injConcl = injClause None false None -let injHyp clear_flag id = injClause None false (Some (clear_flag,ElimOnIdent (Loc.tag id))) +let injConcl flags = injClause flags None false None +let injHyp flags clear_flag id = injClause flags None false (Some (clear_flag,ElimOnIdent (Loc.tag id))) -let decompEqThen ntac (lbeq,_,(t,t1,t2) as u) clause = +let decompEqThen keep_proofs ntac (lbeq,_,(t,t1,t2) as u) clause = Proofview.Goal.enter begin fun gl -> let sigma = clause.evd in let env = Proofview.Goal.env gl in - match find_positions env sigma ~no_discr:false t1 t2 with + match find_positions env sigma ~keep_proofs ~no_discr:false t1 t2 with | Inl (cpath, (_,dirn), _) -> discr_positions env sigma u clause cpath dirn | Inr [] -> (* Change: do not fail, simplify clear this trivial hyp *) @@ -1485,18 +1499,18 @@ let decompEqThen ntac (lbeq,_,(t,t1,t2) as u) clause = (ntac (clenv_value clause)) end -let dEqThen with_evars ntac = function - | None -> onNegatedEquality with_evars (decompEqThen (ntac None)) - | Some c -> onInductionArg (fun clear_flag -> onEquality with_evars (decompEqThen (ntac clear_flag))) c +let dEqThen ~keep_proofs with_evars ntac = function + | None -> onNegatedEquality with_evars (decompEqThen (use_keep_proofs keep_proofs) (ntac None)) + | Some c -> onInductionArg (fun clear_flag -> onEquality with_evars (decompEqThen (use_keep_proofs keep_proofs) (ntac clear_flag))) c -let dEq with_evars = - dEqThen with_evars (fun clear_flag c x -> +let dEq ~keep_proofs with_evars = + dEqThen ~keep_proofs with_evars (fun clear_flag c x -> (apply_clear_request clear_flag (use_clear_hyp_by_default ()) c)) let intro_decomp_eq tac data (c, t) = Proofview.Goal.enter begin fun gl -> let cl = pf_apply make_clenv_binding gl (c, t) NoBindings in - decompEqThen (fun _ -> tac) data cl + decompEqThen !keep_proof_equalities_for_injection (fun _ -> tac) data cl end let _ = declare_intro_decomp_eq intro_decomp_eq diff --git a/tactics/equality.mli b/tactics/equality.mli index a4d1c0f9bd..65da2e7dc0 100644 --- a/tactics/equality.mli +++ b/tactics/equality.mli @@ -67,23 +67,31 @@ val replace_in_clause_maybe_by : constr -> constr -> clause -> unit Proofview.ta val replace : constr -> constr -> unit Proofview.tactic val replace_by : constr -> constr -> unit Proofview.tactic -> unit Proofview.tactic +type inj_flags = { + keep_proof_equalities : bool; (* One may want it or not *) + injection_in_context : bool; (* For regularity; one may want it from ML code but not interactively *) + injection_pattern_l2r_order : bool; (* Compatibility option: no reason not to want it *) + } + val discr : evars_flag -> constr with_bindings -> unit Proofview.tactic val discrConcl : unit Proofview.tactic val discrHyp : Id.t -> unit Proofview.tactic val discrEverywhere : evars_flag -> unit Proofview.tactic val discr_tac : evars_flag -> constr with_bindings destruction_arg option -> unit Proofview.tactic -val inj : intro_patterns option -> evars_flag -> + +(* Below, if flag is [None], it takes the value from the dynamic value of the option *) +val inj : inj_flags option -> intro_patterns option -> evars_flag -> clear_flag -> constr with_bindings -> unit Proofview.tactic -val injClause : intro_patterns option -> evars_flag -> +val injClause : inj_flags option -> intro_patterns option -> evars_flag -> constr with_bindings destruction_arg option -> unit Proofview.tactic -val injHyp : clear_flag -> Id.t -> unit Proofview.tactic -val injConcl : unit Proofview.tactic -val simpleInjClause : evars_flag -> +val injHyp : inj_flags option -> clear_flag -> Id.t -> unit Proofview.tactic +val injConcl : inj_flags option -> unit Proofview.tactic +val simpleInjClause : inj_flags option -> evars_flag -> constr with_bindings destruction_arg option -> unit Proofview.tactic -val dEq : evars_flag -> constr with_bindings destruction_arg option -> unit Proofview.tactic -val dEqThen : evars_flag -> (clear_flag -> constr -> int -> unit Proofview.tactic) -> constr with_bindings destruction_arg option -> unit Proofview.tactic +val dEq : keep_proofs:(bool option) -> evars_flag -> constr with_bindings destruction_arg option -> unit Proofview.tactic +val dEqThen : keep_proofs:(bool option) -> evars_flag -> (clear_flag -> constr -> int -> unit Proofview.tactic) -> constr with_bindings destruction_arg option -> unit Proofview.tactic val make_iterated_tuple : env -> evar_map -> constr -> (constr * types) -> evar_map * (constr * constr * constr) @@ -100,7 +108,7 @@ val rewriteInConcl : bool -> constr -> unit Proofview.tactic val discriminable : env -> evar_map -> constr -> constr -> bool (* Tells if tactic "injection" is applicable *) -val injectable : env -> evar_map -> constr -> constr -> bool +val injectable : env -> evar_map -> keep_proofs:(bool option) -> constr -> constr -> bool (* Subst *) diff --git a/tactics/inv.ml b/tactics/inv.ml index f391382bfc..c5aa74ba5c 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -371,7 +371,7 @@ let projectAndApply as_mode thin avoid id eqname names depids = (* If no immediate variable in the equation, try to decompose it *) (* and apply a trailer which again try to substitute *) (fun id -> - dEqThen false (deq_trailer id) + dEqThen ~keep_proofs:None false (deq_trailer id) (Some (None,ElimOnConstr (EConstr.mkVar id,NoBindings)))) id diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index bce0dda10c..07eea7b63e 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -623,7 +623,7 @@ module New = struct let name_elim = match EConstr.kind sigma elim with | Const (kn, _) -> string_of_con kn - | Var id -> string_of_id id + | Var id -> Id.to_string id | _ -> "\b" in user_err ~hdr:"Tacticals.general_elim_then_using" diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index 2a04c413be..3abd42d46a 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -226,12 +226,12 @@ module New : sig val nLastDecls : 'a Proofview.Goal.t -> int -> named_context - val ifOnHyp : (identifier * types -> bool) -> - (identifier -> unit Proofview.tactic) -> (identifier -> unit Proofview.tactic) -> - identifier -> unit Proofview.tactic + val ifOnHyp : (Id.t * types -> bool) -> + (Id.t -> unit Proofview.tactic) -> (Id.t -> unit Proofview.tactic) -> + Id.t -> unit Proofview.tactic - val onNthHypId : int -> (identifier -> unit tactic) -> unit tactic - val onLastHypId : (identifier -> unit tactic) -> unit tactic + val onNthHypId : int -> (Id.t -> unit tactic) -> unit tactic + val onLastHypId : (Id.t -> unit tactic) -> unit tactic val onLastHyp : (constr -> unit tactic) -> unit tactic val onLastDecl : (named_declaration -> unit tactic) -> unit tactic @@ -239,9 +239,9 @@ module New : sig (named_context -> unit tactic) -> unit tactic val afterHyp : Id.t -> (named_context -> unit tactic) -> unit tactic - val tryAllHyps : (identifier -> unit tactic) -> unit tactic - val tryAllHypsAndConcl : (identifier option -> unit tactic) -> unit tactic - val onClause : (identifier option -> unit tactic) -> clause -> unit tactic + val tryAllHyps : (Id.t -> unit tactic) -> unit tactic + val tryAllHypsAndConcl : (Id.t option -> unit tactic) -> unit tactic + val onClause : (Id.t option -> unit tactic) -> clause -> unit tactic val elimination_sort_of_goal : 'a Proofview.Goal.t -> sorts_family val elimination_sort_of_hyp : Id.t -> 'a Proofview.Goal.t -> sorts_family diff --git a/tactics/tactics.ml b/tactics/tactics.ml index e8a78d72d6..6f67606d24 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -839,7 +839,7 @@ let e_change_in_hyp redfun (id,where) = (convert_hyp c) end -type change_arg = Pattern.patvar_map -> evar_map -> evar_map * EConstr.constr +type change_arg = Ltac_pretype.patvar_map -> evar_map -> evar_map * EConstr.constr let make_change_arg c pats sigma = (sigma, replace_vars (Id.Map.bindings pats) c) @@ -1376,7 +1376,7 @@ let enforce_prop_bound_names rename tac = (* "very_standard" says that we should have "H" names only, but this would break compatibility even more... *) let s = match Namegen.head_name sigma t with - | Some id when not very_standard -> string_of_id id + | Some id when not very_standard -> Id.to_string id | _ -> "" in Name (add_suffix Namegen.default_prop_ident s) else @@ -1743,7 +1743,7 @@ let general_apply with_delta with_destruct with_evars clear_flag (loc,(c,lbind : let try_apply thm_ty nprod = try let n = nb_prod_modulo_zeta sigma thm_ty - nprod in - if n<0 then error "Applied theorem has not enough premisses."; + if n<0 then error "Applied theorem does not have enough premises."; let clause = make_clenv_binding_apply env sigma (Some n) (c,thm_ty) lbind in Clenvtac.res_pf clause ~with_evars ~flags with exn when catchable_exception exn -> diff --git a/tactics/tactics.mli b/tactics/tactics.mli index e07d514cd0..98cf1b4373 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -21,6 +21,7 @@ open Unification open Misctypes open Tactypes open Locus +open Ltac_pretype (** Main tactics defined in ML. This file is huge and should probably be split in more reasonable units at some point. Because of its size and age, the @@ -270,7 +271,7 @@ type eliminator = { val general_elim : evars_flag -> clear_flag -> constr with_bindings -> eliminator -> unit Proofview.tactic -val general_elim_clause : evars_flag -> unify_flags -> identifier option -> +val general_elim_clause : evars_flag -> unify_flags -> Id.t option -> clausenv -> eliminator -> unit Proofview.tactic val default_elim : evars_flag -> clear_flag -> constr with_bindings -> @@ -354,7 +355,7 @@ val assert_before : Name.t -> types -> unit Proofview.tactic val assert_after : Name.t -> types -> unit Proofview.tactic val assert_as : (* true = before *) bool -> - (* optionally tell if a specialization of some hyp: *) identifier option -> + (* optionally tell if a specialization of some hyp: *) Id.t option -> intro_pattern option -> constr -> unit Proofview.tactic (** Implements the tactics assert, enough and pose proof; note that "by" @@ -427,7 +428,7 @@ module Simple : sig val eapply : constr -> unit Proofview.tactic val elim : constr -> unit Proofview.tactic val case : constr -> unit Proofview.tactic - val apply_in : identifier -> constr -> unit Proofview.tactic + val apply_in : Id.t -> constr -> unit Proofview.tactic end diff --git a/test-suite/bugs/closed/2881.v b/test-suite/bugs/closed/2881.v new file mode 100644 index 0000000000..b4f09305b4 --- /dev/null +++ b/test-suite/bugs/closed/2881.v @@ -0,0 +1,7 @@ +(* About scoping of pattern variables in strict/non-strict mode *) + +Ltac eta_red := change (fun a => ?f0 a) with f0. +Goal forall T1 T2 (f : T1 -> T2), (fun x => f x) = f. +intros. +eta_red. +Abort. diff --git a/test-suite/bugs/closed/5245.v b/test-suite/bugs/closed/5245.v index 77bf169e18..e5bca5b5e4 100644 --- a/test-suite/bugs/closed/5245.v +++ b/test-suite/bugs/closed/5245.v @@ -15,4 +15,4 @@ Undo. progress hnf; intros; exact eq_refl. Undo. unfold foo_rel. intros x. exact eq_refl. -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/bugs/closed/5281.v b/test-suite/bugs/closed/5281.v new file mode 100644 index 0000000000..03bafdc9ae --- /dev/null +++ b/test-suite/bugs/closed/5281.v @@ -0,0 +1,6 @@ +Inductive A (T : Prop) := B (_ : T). +Scheme Equality for A. + +Goal forall (T:Prop), (forall x y : T, {x=y}+{x<>y}) -> forall x y : A T, {x=y}+{x<>y}. +decide equality. +Qed. diff --git a/test-suite/bugs/closed/5401.v b/test-suite/bugs/closed/5401.v new file mode 100644 index 0000000000..95193b993b --- /dev/null +++ b/test-suite/bugs/closed/5401.v @@ -0,0 +1,21 @@ +(* Testing printing of bound unnamed variables in pattern printer *) + +Module A. +Parameter P : nat -> Type. +Parameter v : forall m, P m. +Parameter f : forall (P : nat -> Type), (forall a, P a) -> P 0. +Class U (R : P 0) (m : forall x, P x) : Prop. +Instance w : U (f _ (fun _ => v _)) v. +Print HintDb typeclass_instances. +End A. + +(* #5731 *) + +Module B. +Axiom rel : Type -> Prop. +Axiom arrow_rel : forall {A1}, A1 -> rel A1. +Axiom forall_rel : forall E, (forall v1 : Type, E v1 -> rel v1) -> Prop. +Axiom inl_rel: forall_rel _ (fun _ => arrow_rel). +Hint Resolve inl_rel : foo. +Print HintDb foo. +End B. diff --git a/test-suite/bugs/closed/5786.v b/test-suite/bugs/closed/5786.v new file mode 100644 index 0000000000..20301ec4f5 --- /dev/null +++ b/test-suite/bugs/closed/5786.v @@ -0,0 +1,29 @@ +(* Printing all kinds of Ltac generic arguments *) + +Tactic Notation "myidtac" string(v) := idtac v. +Goal True. +myidtac "foo". +Abort. + +Tactic Notation "myidtac2" ref(c) := idtac c. +Goal True. +myidtac2 True. +Abort. + +Tactic Notation "myidtac3" preident(s) := idtac s. +Goal True. +myidtac3 foo. +Abort. + +Tactic Notation "myidtac4" int_or_var(n) := idtac n. +Goal True. +myidtac4 3. +Abort. + +Tactic Notation "myidtac5" ident(id) := idtac id. +Goal True. +myidtac5 foo. +Abort. + + + diff --git a/test-suite/bugs/closed/6070.v b/test-suite/bugs/closed/6070.v new file mode 100644 index 0000000000..49b16f6254 --- /dev/null +++ b/test-suite/bugs/closed/6070.v @@ -0,0 +1,32 @@ +(* A slight shortening of bug 6078 *) + +(* This bug exposed a different behavior of unshelve_unifiable + depending on which projection is found in the unification + heuristics *) + +Axiom flat_type : Type. +Axiom interp_flat_type : flat_type -> Type. +Inductive type := Arrow (_ _ : flat_type). +Definition interp_type (t : type) + := interp_flat_type (match t with Arrow s d => s end) + -> interp_flat_type (match t with Arrow s d => d end). +Axiom Expr : type -> Type. +Axiom Interp : forall {t : type}, Expr t -> interp_type t. +Axiom Wf : forall {t}, Expr t -> Prop. +Axiom a : forall f, interp_flat_type f. + +Definition packaged_expr_functionP A := + (fun F : Expr A -> Expr A + => forall e' v, Interp (F e') v = a (let (_,f) := A in f)). +Goal forall (f f0 : flat_type) + (e : forall _ : Expr (@Arrow f f0), + Expr (@Arrow f f0)), + @packaged_expr_functionP (@Arrow f f0) e. + intros. + refine (fun (e0 : Expr (Arrow f f0)) + => (fun zHwf':True => + (fun v : interp_flat_type f => + ?[G] : ?[U] = ?[V] :> interp_flat_type ?[v])) ?[H]); + [ | ]. + (* Was: Error: Tactic failure: Incorrect number of goals (expected 3 tactics). *) +Abort. diff --git a/test-suite/output/idtac.out b/test-suite/output/idtac.out new file mode 100644 index 0000000000..3855f88a72 --- /dev/null +++ b/test-suite/output/idtac.out @@ -0,0 +1,11 @@ +"foo" +True +foo +3 +foo +2 +< True False Prop > +< True False Prop > +< > +< > +<< 1 2 3 >> diff --git a/test-suite/output/idtac.v b/test-suite/output/idtac.v new file mode 100644 index 0000000000..ac60ea9175 --- /dev/null +++ b/test-suite/output/idtac.v @@ -0,0 +1,45 @@ +(* Printing all kinds of Ltac generic arguments *) + +Tactic Notation "myidtac" string(v) := idtac v. +Goal True. +myidtac "foo". +Abort. + +Tactic Notation "myidtac2" ref(c) := idtac c. +Goal True. +myidtac2 True. +Abort. + +Tactic Notation "myidtac3" preident(s) := idtac s. +Goal True. +myidtac3 foo. +Abort. + +Tactic Notation "myidtac4" int_or_var(n) := idtac n. +Goal True. +myidtac4 3. +Abort. + +Tactic Notation "myidtac5" ident(id) := idtac id. +Goal True. +myidtac5 foo. +Abort. + +(* Checking non focussing of idtac for integers *) +Goal True/\True. split. +all:let c:=numgoals in idtac c. +Abort. + +(* Checking printing of lists and its focussing *) +Tactic Notation "myidtac6" constr_list(l) := idtac "<" l ">". +Goal True/\True. split. +all:myidtac6 True False Prop. +(* An empty list is focussing because of interp_genarg of a constr *) +(* even if it is not focussing on printing *) +all:myidtac6. +Abort. + +Tactic Notation "myidtac7" int_list(l) := idtac "<<" l ">>". +Goal True/\True. split. +all:myidtac7 1 2 3. +Abort. diff --git a/test-suite/success/destruct.v b/test-suite/success/destruct.v index 0219c3bfdf..6fbe61a9be 100644 --- a/test-suite/success/destruct.v +++ b/test-suite/success/destruct.v @@ -430,3 +430,9 @@ eexists ?[x]. destruct (S _). change (0 = ?x). Abort. + +Goal (forall P, P 0 -> True/\True) -> True. +intro H. +destruct (H (fun x => True)). +match goal with |- True => idtac end. +Abort. diff --git a/test-suite/success/guard.v b/test-suite/success/guard.v index 83d47dc683..3a1c6dabeb 100644 --- a/test-suite/success/guard.v +++ b/test-suite/success/guard.v @@ -25,4 +25,4 @@ match f with match e in (_ = B) return (B -> foo A) -> nat with | eq_refl => fun (g' : nat -> foo A) => bar A e (g' O) end g -end e.
\ No newline at end of file +end e. diff --git a/test-suite/success/refine.v b/test-suite/success/refine.v index b8a8ff7561..22fb4d7576 100644 --- a/test-suite/success/refine.v +++ b/test-suite/success/refine.v @@ -122,3 +122,13 @@ Abort. Goal (forall A : Prop, A -> ~~A). Proof. refine(fun A a f => _). + +(* Checking beta-iota normalization of hypotheses in created evars *) + +Goal {x|x=0} -> True. +refine (fun y => let (x,a) := y in _). +match goal with a:_=0 |- _ => idtac end. + +Goal (forall P, {P 0}+{P 1}) -> True. +refine (fun H => if H (fun x => x=x) then _ else _). +match goal with _:0=0 |- _ => idtac end. diff --git a/theories/QArith/QArith_base.v b/theories/QArith/QArith_base.v index a19f9f9025..5996d30f25 100644 --- a/theories/QArith/QArith_base.v +++ b/theories/QArith/QArith_base.v @@ -171,6 +171,26 @@ Proof. auto with qarith. Qed. +Lemma Qeq_bool_comm x y: Qeq_bool x y = Qeq_bool y x. +Proof. + apply eq_true_iff_eq. rewrite !Qeq_bool_iff. now symmetry. +Qed. + +Lemma Qeq_bool_refl x: Qeq_bool x x = true. +Proof. + rewrite Qeq_bool_iff. now reflexivity. +Qed. + +Lemma Qeq_bool_sym x y: Qeq_bool x y = true -> Qeq_bool y x = true. +Proof. + rewrite !Qeq_bool_iff. now symmetry. +Qed. + +Lemma Qeq_bool_trans x y z: Qeq_bool x y = true -> Qeq_bool y z = true -> Qeq_bool x z = true. +Proof. + rewrite !Qeq_bool_iff; apply Qeq_trans. +Qed. + Hint Resolve Qnot_eq_sym : qarith. (** * Addition, multiplication and opposite *) diff --git a/theories/QArith/Qabs.v b/theories/QArith/Qabs.v index 116aa0d429..ec2ac7832d 100644 --- a/theories/QArith/Qabs.v +++ b/theories/QArith/Qabs.v @@ -100,6 +100,13 @@ rewrite Z.abs_mul. reflexivity. Qed. +Lemma Qabs_Qinv : forall q, Qabs (/ q) == / (Qabs q). +Proof. + intros [n d]; simpl. + unfold Qinv. + case_eq n; intros; simpl in *; apply Qeq_refl. +Qed. + Lemma Qabs_Qminus x y: Qabs (x - y) = Qabs (y - x). Proof. unfold Qminus, Qopp. simpl. diff --git a/tools/fake_ide.ml b/tools/fake_ide.ml index 79723431cf..b5c5b2b96d 100644 --- a/tools/fake_ide.ml +++ b/tools/fake_ide.ml @@ -288,7 +288,7 @@ let usage () = (Filename.basename Sys.argv.(0)) (Parser.print grammar)) -module Coqide = Spawn.Sync(struct end) +module Coqide = Spawn.Sync () let main = if Sys.os_type = "Unix" then Sys.set_signal Sys.sigpipe diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index c16e2751bc..910c81381b 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -350,7 +350,7 @@ let rec loop doc = not possible due exceptions. *) in vernac_loop doc (Stm.get_current_state ~doc) with - | CErrors.Drop -> () + | CErrors.Drop -> doc | CErrors.Quit -> exit 0 | any -> Feedback.msg_error (str "Anomaly: main loop exited with exception: " ++ diff --git a/toplevel/coqloop.mli b/toplevel/coqloop.mli index 46dabf995d..46934f326a 100644 --- a/toplevel/coqloop.mli +++ b/toplevel/coqloop.mli @@ -36,4 +36,4 @@ val do_vernac : Stm.doc -> Stateid.t -> Stm.doc * Stateid.t (** Main entry point of Coq: read and execute vernac commands. *) -val loop : Stm.doc -> unit +val loop : Stm.doc -> Stm.doc diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 19fcd99937..f3d5d9b859 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -79,6 +79,7 @@ let toploop_init = ref begin fun x -> will not be generally be initialized, thus stateid, etc... may be bogus. For now we just print to the console too *) let coqtop_init_feed = Coqloop.coqloop_feed +let drop_last_doc = ref None (* Default toplevel loop *) let console_toploop_run doc = @@ -88,8 +89,9 @@ let console_toploop_run doc = Flags.if_verbose warning "Dumpglob cannot be used in interactive mode."; Dumpglob.noglob () end; - Coqloop.loop doc; + let doc = Coqloop.loop doc in (* Initialise and launch the Ocaml toplevel *) + drop_last_doc := Some doc; Coqinit.init_ocaml_path(); Mltop.ocaml_toploop(); (* We let the feeder in place for users of Drop *) @@ -183,9 +185,9 @@ let load_vernacular doc sid = (fun (doc,sid) (f_in, verbosely) -> let s = Loadpath.locate_file f_in in if !Flags.beautify then - Flags.with_option Flags.beautify_file (Vernac.load_vernac ~verbosely ~interactive:false ~check:true doc sid) f_in + Flags.with_option Flags.beautify_file (Vernac.load_vernac ~verbosely ~interactive:false ~check:true doc sid) f_in else - Vernac.load_vernac ~verbosely ~interactive:false ~check:true doc sid s) + Vernac.load_vernac ~verbosely ~interactive:false ~check:true doc sid s) (doc, sid) (List.rev !load_vernacular_list) let load_init_vernaculars doc sid = @@ -726,7 +728,7 @@ let parse_args arglist = |"-no-glob"|"-noglob" -> Dumpglob.noglob (); glob_opt := true |"-native-compiler" -> if Coq_config.no_native_compiler then - warning "Native compilation was disabled at configure time." + warning "Native compilation was disabled at configure time." else Flags.native_compiler := true |"-output-context" -> output_context := true |"-profile-ltac" -> Flags.profile_ltac := true diff --git a/toplevel/coqtop.mli b/toplevel/coqtop.mli index 1c7c3f944a..5b9494eaa9 100644 --- a/toplevel/coqtop.mli +++ b/toplevel/coqtop.mli @@ -15,6 +15,9 @@ val init_toplevel : string list -> (Stm.doc * Stateid.t) option val start : unit -> unit +(* Last document seen after `Drop` *) +val drop_last_doc : Stm.doc option ref + (* For other toploops *) val toploop_init : (string list -> string list) ref val toploop_run : (Stm.doc -> unit) ref diff --git a/vernac/auto_ind_decl.ml b/vernac/auto_ind_decl.ml index 503508fc04..66a4a2e492 100644 --- a/vernac/auto_ind_decl.ml +++ b/vernac/auto_ind_decl.ml @@ -91,6 +91,15 @@ let destruct_on_using c id = let destruct_on_as c l = destruct false None c (Some (Loc.tag l)) None +let inj_flags = Some { + Equality.keep_proof_equalities = true; (* necessary *) + injection_in_context = true; (* does not matter here *) + Equality.injection_pattern_l2r_order = true; (* does not matter here *) + } + +let my_discr_tac = Equality.discr_tac false None +let my_inj_tac x = Equality.inj inj_flags None false None (EConstr.mkVar x,NoBindings) + (* reconstruct the inductive with the correct de Bruijn indexes *) let mkFullInd (ind,u) n = let mib = Global.lookup_mind (fst ind) in @@ -181,7 +190,7 @@ let build_beq_scheme mode kn = match EConstr.kind sigma c with | Rel x -> mkRel (x-nlist+ndx), Safe_typing.empty_private_constants | Var x -> - let eid = id_of_string ("eq_"^(string_of_id x)) in + let eid = Id.of_string ("eq_"^(Id.to_string x)) in let () = try ignore (Environ.lookup_named eid env) with Not_found -> raise (ParameterWithoutEquality (VarRef x)) @@ -595,7 +604,7 @@ let compute_bl_tact mode bl_scheme_key ind lnamesparrec nparrec = intro_using freshz; intros; Tacticals.New.tclTRY ( - Tacticals.New.tclORELSE reflexivity (Equality.discr_tac false None) + Tacticals.New.tclORELSE reflexivity my_discr_tac ); simpl_in_hyp (freshz,Locus.InHyp); (* @@ -739,9 +748,9 @@ let compute_lb_tact mode lb_scheme_key ind lnamesparrec nparrec = intro_using freshz; intros; Tacticals.New.tclTRY ( - Tacticals.New.tclORELSE reflexivity (Equality.discr_tac false None) + Tacticals.New.tclORELSE reflexivity my_discr_tac ); - Equality.inj None false None (EConstr.mkVar freshz,NoBindings); + my_inj_tac freshz; intros; simpl_in_concl; Auto.default_auto; Tacticals.New.tclREPEAT ( @@ -936,7 +945,7 @@ let compute_dec_tact ind lnamesparrec nparrec = NoBindings ) true; - Equality.discr_tac false None + my_discr_tac ] end ] diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml index 9ab89c8832..dbf7fec660 100644 --- a/vernac/lemmas.ml +++ b/vernac/lemmas.ml @@ -506,7 +506,7 @@ let save_proof ?proof = function let env = Global.env () in let ids_typ = Environ.global_vars_set env typ in let ids_def = Environ.global_vars_set env pproof in - Some (Environ.keep_hyps env (Idset.union ids_typ ids_def)) + Some (Environ.keep_hyps env (Id.Set.union ids_typ ids_def)) | _ -> None in let decl = Proof_global.get_universe_decl () in let evd = Evd.from_ctx universes in diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index e08cb83871..41f63644d4 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -1853,7 +1853,6 @@ let vernac_show = let open Feedback in function | OpenSubgoals -> pr_open_subgoals () | NthGoal n -> pr_nth_open_subgoal n | GoalId id -> pr_goal_by_id id - | GoalUid id -> pr_goal_by_uid id in msg_notice info | ShowProof -> show_proof () @@ -2070,7 +2069,7 @@ let interp ?proof ?loc locality poly c = | VernacProofMode mn -> Proof_global.set_proof_mode mn [@ocaml.warning "-3"] (* Extensions *) - | VernacExtend (opn,args) -> Vernacinterp.call ?locality (opn,args) + | VernacExtend (opn,args) -> Vernacinterp.call ?locality ?loc (opn,args) (* Vernaculars that take a locality flag *) let check_vernac_supports_locality c l = diff --git a/vernac/vernacinterp.ml b/vernac/vernacinterp.ml index 2d9c0fa362..41fee6bd08 100644 --- a/vernac/vernacinterp.ml +++ b/vernac/vernacinterp.ml @@ -11,7 +11,7 @@ open Pp open CErrors type deprecation = bool -type vernac_command = Genarg.raw_generic_argument list -> unit -> unit +type vernac_command = Genarg.raw_generic_argument list -> Loc.t option -> unit (* Table of vernac entries *) let vernac_tab = @@ -49,8 +49,8 @@ let warn_deprecated_command = (* Interpretation of a vernac command *) -let call ?locality (opn,converted_args) = - let loc = ref "Looking up command" in +let call ?locality ?loc (opn,converted_args) = + let phase = ref "Looking up command" in try let depr, callback = vinterp_map opn in let () = if depr then @@ -62,16 +62,16 @@ let call ?locality (opn,converted_args) = let pr = pr_sequence pr_gram rules in warn_deprecated_command pr; in - loc:= "Checking arguments"; + phase := "Checking arguments"; let hunk = callback converted_args in - loc:= "Executing command"; + phase := "Executing command"; Locality.LocalityFixme.set locality; - hunk(); + hunk loc; Locality.LocalityFixme.assert_consumed() with | Drop -> raise Drop | reraise -> let reraise = CErrors.push reraise in if !Flags.debug then - Feedback.msg_debug (str"Vernac Interpreter " ++ str !loc); + Feedback.msg_debug (str"Vernac Interpreter " ++ str !phase); iraise reraise diff --git a/vernac/vernacinterp.mli b/vernac/vernacinterp.mli index f58d070864..84370fdc29 100644 --- a/vernac/vernacinterp.mli +++ b/vernac/vernacinterp.mli @@ -9,7 +9,7 @@ (** Interpretation of extended vernac phrases. *) type deprecation = bool -type vernac_command = Genarg.raw_generic_argument list -> unit -> unit +type vernac_command = Genarg.raw_generic_argument list -> Loc.t option -> unit val vinterp_add : deprecation -> Vernacexpr.extend_name -> vernac_command -> unit @@ -17,4 +17,4 @@ val overwriting_vinterp_add : Vernacexpr.extend_name -> vernac_command -> unit val vinterp_init : unit -> unit -val call : ?locality:bool -> Vernacexpr.extend_name * Genarg.raw_generic_argument list -> unit +val call : ?locality:bool -> ?loc:Loc.t -> Vernacexpr.extend_name * Genarg.raw_generic_argument list -> unit |