diff options
155 files changed, 2598 insertions, 1455 deletions
diff --git a/.gitattributes b/.gitattributes index f2c096f2d..51fa208a7 100644 --- a/.gitattributes +++ b/.gitattributes @@ -2,6 +2,8 @@ .gitignore export-ignore .mailmap export-ignore +*.out -whitespace + *.asciidoc whitespace=trailing-space,tab-in-indent *.bat whitespace=cr-at-eol,trailing-space,tab-in-indent *.bib whitespace=trailing-space,tab-in-indent diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index fcf6413be..7c3489de4 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -284,6 +284,9 @@ ci-coquelicot: <<: *ci-template-vars EXTRA_PACKAGES: "$TIMING_PACKAGES autoconf" +ci-equations: + <<: *ci-template + ci-geocoq: <<: *ci-template allow_failure: true diff --git a/.travis.yml b/.travis.yml index 3ebfbefd2..1f6bb11e0 100644 --- a/.travis.yml +++ b/.travis.yml @@ -50,6 +50,7 @@ env: - TEST_TARGET="ci-compcert TIMED=1" - TEST_TARGET="ci-coq-dpdgraph" EXTRA_OPAM="ocamlgraph" - TEST_TARGET="ci-coquelicot TIMED=1" + - TEST_TARGET="ci-equations TIMED=1" - TEST_TARGET="ci-geocoq TIMED=1" - TEST_TARGET="ci-fiat-crypto TIMED=1" - TEST_TARGET="ci-fiat-parsers TIMED=1" diff --git a/API/API.ml b/API/API.ml index 78d9c0c26..378c03ee4 100644 --- a/API/API.ml +++ b/API/API.ml @@ -20,10 +20,6 @@ (******************************************************************************) module Coq_config = Coq_config -(* Reexporting deprecated symbols throu module aliases triggers a - warning in 4.06.0 *) -[@@@ocaml.warning "-3"] - (******************************************************************************) (* Kernel *) (******************************************************************************) diff --git a/API/API.mli b/API/API.mli index 8a4a6cc89..67e73dfdf 100644 --- a/API/API.mli +++ b/API/API.mli @@ -20,10 +20,6 @@ See below in the file for their concrete position. *) -(* Reexporting deprecated symbols throu module aliases triggers a - warning in 4.06.0 *) -[@@@ocaml.warning "-3"] - (************************************************************************) (* Modules from config/ *) (************************************************************************) @@ -87,6 +83,7 @@ sig val repr : t -> Id.t list val equal : t -> t -> bool val to_string : t -> string + val print : t -> Pp.t end module MBId : sig @@ -327,7 +324,7 @@ sig type identifier = Id.t [@@ocaml.deprecated "Alias of Names"] - module Idset : Set.S with type elt = identifier and type t = Id.Set.t + module Idset : Set.S with type elt = Id.t and type t = Id.Set.t [@@ocaml.deprecated "Alias of Id.Set.t"] end @@ -347,7 +344,7 @@ sig module LSet : sig - include CSig.SetS with type elt = universe_level + include CSig.SetS with type elt = Level.t val pr : (Level.t -> Pp.t) -> t -> Pp.t end @@ -375,7 +372,7 @@ sig type constraint_type = Lt | Le | Eq - type univ_constraint = universe_level * constraint_type * universe_level + type univ_constraint = Level.t * constraint_type * Level.t module Constraint : sig include Set.S with type elt = univ_constraint @@ -437,7 +434,7 @@ sig module LMap : sig - include CMap.ExtS with type key = universe_level and module Set := LSet + include CMap.ExtS with type key = Level.t and module Set := LSet val union : 'a t -> 'a t -> 'a t val diff : 'a t -> 'a t -> 'a t @@ -446,8 +443,8 @@ sig end type 'a universe_map = 'a LMap.t - type universe_subst = universe universe_map - type universe_level_subst = universe_level universe_map + type universe_subst = Universe.t universe_map + type universe_level_subst = Level.t universe_map val enforce_leq : Universe.t constraint_function val pr_uni : Universe.t -> Pp.t @@ -481,6 +478,7 @@ sig type family = InProp | InSet | InType val family : t -> family + val univ_of_sort : t -> Univ.Universe.t end module Evar : @@ -501,6 +499,7 @@ end module Constr : sig + open Names type t @@ -578,13 +577,13 @@ sig val kind : constr -> (constr, types, Sorts.t, Univ.Instance.t) kind_of_term val of_kind : (constr, types, Sorts.t, Univ.Instance.t) kind_of_term -> constr -val map_with_binders : - ('a -> 'a) -> ('a -> constr -> constr) -> 'a -> constr -> constr -val map : (constr -> constr) -> constr -> constr + val map_with_binders : + ('a -> 'a) -> ('a -> constr -> constr) -> 'a -> constr -> constr + val map : (constr -> constr) -> constr -> constr -val fold : ('a -> constr -> 'a) -> 'a -> constr -> 'a -val iter : (constr -> unit) -> constr -> unit -val compare_head : (constr -> constr -> bool) -> constr -> constr -> bool + val fold : ('a -> constr -> 'a) -> 'a -> constr -> 'a + val iter : (constr -> unit) -> constr -> unit + val compare_head : (constr -> constr -> bool) -> constr -> constr -> bool val equal : t -> t -> bool val eq_constr_nounivs : t -> t -> bool @@ -626,6 +625,109 @@ val compare_head : (constr -> constr -> bool) -> constr -> constr -> bool val mkCase : case_info * t * t * t array -> t + (** {6 Simple case analysis} *) + val isRel : constr -> bool + val isRelN : int -> constr -> bool + val isVar : constr -> bool + val isVarId : Id.t -> constr -> bool + val isInd : constr -> bool + val isEvar : constr -> bool + val isMeta : constr -> bool + val isEvar_or_Meta : constr -> bool + val isSort : constr -> bool + val isCast : constr -> bool + val isApp : constr -> bool + val isLambda : constr -> bool + val isLetIn : constr -> bool + val isProd : constr -> bool + val isConst : constr -> bool + val isConstruct : constr -> bool + val isFix : constr -> bool + val isCoFix : constr -> bool + val isCase : constr -> bool + val isProj : constr -> bool + + val is_Prop : constr -> bool + val is_Set : constr -> bool + val isprop : constr -> bool + val is_Type : constr -> bool + val iskind : constr -> bool + val is_small : Sorts.t -> bool + + (** {6 Term destructors } *) + (** Destructor operations are partial functions and + @raise DestKO if the term has not the expected form. *) + + exception DestKO + + (** Destructs a de Bruijn index *) + val destRel : constr -> int + + (** Destructs an existential variable *) + val destMeta : constr -> metavariable + + (** Destructs a variable *) + val destVar : constr -> Id.t + + (** Destructs a sort. [is_Prop] recognizes the sort {% \textsf{%}Prop{% }%}, whether + [isprop] recognizes both {% \textsf{%}Prop{% }%} and {% \textsf{%}Set{% }%}. *) + val destSort : constr -> Sorts.t + + (** Destructs a casted term *) + val destCast : constr -> constr * cast_kind * constr + + (** Destructs the product {% $ %}(x:t_1)t_2{% $ %} *) + val destProd : types -> Name.t * types * types + + (** Destructs the abstraction {% $ %}[x:t_1]t_2{% $ %} *) + val destLambda : constr -> Name.t * types * constr + + (** Destructs the let {% $ %}[x:=b:t_1]t_2{% $ %} *) + val destLetIn : constr -> Name.t * constr * types * constr + + (** Destructs an application *) + val destApp : constr -> constr * constr array + + (** Decompose any term as an applicative term; the list of args can be empty *) + val decompose_app : constr -> constr * constr list + + (** Same as [decompose_app], but returns an array. *) + val decompose_appvect : constr -> constr * constr array + + (** Destructs a constant *) + val destConst : constr -> Constant.t puniverses + + (** Destructs an existential variable *) + val destEvar : constr -> existential + + (** Destructs a (co)inductive type *) + val destInd : constr -> inductive puniverses + + (** Destructs a constructor *) + val destConstruct : constr -> constructor puniverses + + (** Destructs a [match c as x in I args return P with ... | + Ci(...yij...) => ti | ... end] (or [let (..y1i..) := c as x in I args + return P in t1], or [if c then t1 else t2]) + @return [(info,c,fun args x => P,[|...|fun yij => ti| ...|])] + where [info] is pretty-printing information *) + val destCase : constr -> case_info * constr * constr * constr array + + (** Destructs a projection *) + val destProj : constr -> Projection.t * constr + + (** Destructs the {% $ %}i{% $ %}th function of the block + [Fixpoint f{_ 1} ctx{_ 1} = b{_ 1} + with f{_ 2} ctx{_ 2} = b{_ 2} + ... + with f{_ n} ctx{_ n} = b{_ n}], + where the length of the {% $ %}j{% $ %}th context is {% $ %}ij{% $ %}. + *) + val destFix : constr -> fixpoint + + type cofixpoint = int * rec_declaration + val destCoFix : constr -> cofixpoint + end module Context : @@ -856,6 +958,7 @@ end module Term : sig + open Constr type sorts_family = Sorts.family = InProp | InSet | InType [@@ocaml.deprecated "Alias of Sorts.family"] @@ -863,15 +966,10 @@ sig [@@ocaml.deprecated "Alias of Sorts.contents"] type sorts = Sorts.t = - | Prop of contents + | Prop of Sorts.contents | Type of Univ.Universe.t [@@ocaml.deprecated "alias of API.Sorts.t"] - type constr = Constr.t - [@@ocaml.deprecated "Alias of Constr.t"] - type types = Constr.t - [@@ocaml.deprecated "Alias of Constr.types"] - type metavariable = int [@@ocaml.deprecated "Alias of Constr.metavariable"] @@ -890,11 +988,11 @@ sig type 'a puniverses = 'a Univ.puniverses [@@ocaml.deprecated "Alias of Constr.puniverses"] - type pconstant = Names.Constant.t puniverses + type pconstant = Names.Constant.t Constr.puniverses [@@ocaml.deprecated "Alias of Constr.pconstant"] - type pinductive = Names.inductive puniverses + type pinductive = Names.inductive Constr.puniverses [@@ocaml.deprecated "Alias of Constr.pinductive"] - type pconstructor = Names.constructor puniverses + type pconstructor = Names.constructor Constr.puniverses [@@ocaml.deprecated "Alias of Constr.pconstructor"] type case_style = Constr.case_style = | LetStyle @@ -907,7 +1005,7 @@ sig type case_printing = Constr.case_printing = { ind_tags : bool list; cstr_tags : bool list array; - style : case_style + style : Constr.case_style } [@@ocaml.deprecated "Alias of Constr.case_printing"] @@ -916,25 +1014,25 @@ sig ci_npar : int; ci_cstr_ndecls: int array; ci_cstr_nargs : int array; - ci_pp_info : case_printing + ci_pp_info : Constr.case_printing } [@@ocaml.deprecated "Alias of Constr.case_info"] type ('constr, 'types) pfixpoint = - (int array * int) * ('constr, 'types) prec_declaration + (int array * int) * ('constr, 'types) Constr.prec_declaration [@@ocaml.deprecated "Alias of Constr.pfixpoint"] type ('constr, 'types) pcofixpoint = - int * ('constr, 'types) prec_declaration + int * ('constr, 'types) Constr.prec_declaration [@@ocaml.deprecated "Alias of Constr.pcofixpoint"] type ('constr, 'types, 'sort, 'univs) kind_of_term = ('constr, 'types, 'sort, 'univs) Constr.kind_of_term = | Rel of int | Var of Names.Id.t | Meta of Constr.metavariable - | Evar of 'constr pexistential + | Evar of 'constr Constr.pexistential | Sort of 'sort - | Cast of 'constr * cast_kind * 'types + | Cast of 'constr * Constr.cast_kind * 'types | Prod of Names.Name.t * 'types * 'types | Lambda of Names.Name.t * 'types * 'constr | LetIn of Names.Name.t * 'constr * 'types * 'constr @@ -942,22 +1040,18 @@ sig | Const of (Names.Constant.t * 'univs) | Ind of (Names.inductive * 'univs) | Construct of (Names.constructor * 'univs) - | Case of case_info * 'constr * 'constr * 'constr array - | Fix of ('constr, 'types) pfixpoint - | CoFix of ('constr, 'types) pcofixpoint + | Case of Constr.case_info * 'constr * 'constr * 'constr array + | Fix of ('constr, 'types) Constr.pfixpoint + | CoFix of ('constr, 'types) Constr.pcofixpoint | Proj of Names.Projection.t * 'constr [@@ocaml.deprecated "Alias of Constr.kind_of_term"] - type existential = Constr.existential_key * constr array + type existential = Constr.existential_key * Constr.constr array [@@ocaml.deprecated "Alias of Constr.existential"] - type rec_declaration = Names.Name.t array * constr array * constr array + type rec_declaration = Names.Name.t array * Constr.constr array * Constr.constr array [@@ocaml.deprecated "Alias of Constr.rec_declaration"] - type fixpoint = (int array * int) * rec_declaration - [@@ocaml.deprecated "Alias of Constr.fixpoint"] - type cofixpoint = int * rec_declaration - [@@ocaml.deprecated "Alias of Constr.cofixpoint"] - val kind_of_term : constr -> (constr, types, Sorts.t, Univ.Instance.t) kind_of_term + val kind_of_term : Constr.constr -> (Constr.constr, Constr.types, Sorts.t, Univ.Instance.t) Constr.kind_of_term [@@ocaml.deprecated "Alias of Constr.kind"] - val applistc : constr -> constr list -> constr + val applistc : Constr.constr -> Constr.constr list -> Constr.constr val applist : constr * constr list -> constr [@@ocaml.deprecated "(sort of an) alias of API.Term.applistc"] @@ -971,7 +1065,7 @@ sig val mkMeta : Constr.metavariable -> constr [@@ocaml.deprecated "Alias of similarly named Constr function"] - val mkEvar : existential -> constr + val mkEvar : Constr.existential -> constr [@@ocaml.deprecated "Alias of similarly named Constr function"] val mkSort : Sorts.t -> types [@@ocaml.deprecated "Alias of similarly named Constr function"] @@ -981,7 +1075,7 @@ sig [@@ocaml.deprecated "Alias of similarly named Constr function"] val mkType : Univ.Universe.t -> types [@@ocaml.deprecated "Alias of similarly named Constr function"] - val mkCast : constr * cast_kind * constr -> constr + val mkCast : constr * Constr.cast_kind * constr -> constr [@@ocaml.deprecated "Alias of similarly named Constr function"] val mkProd : Names.Name.t * types * types -> types [@@ocaml.deprecated "Alias of similarly named Constr function"] @@ -999,11 +1093,11 @@ sig [@@ocaml.deprecated "Alias of similarly named Constr function"] val mkConstruct : Names.constructor -> constr [@@ocaml.deprecated "Alias of similarly named Constr function"] - val mkConstructU : Names.constructor puniverses -> constr + val mkConstructU : Names.constructor Constr.puniverses -> constr [@@ocaml.deprecated "Alias of similarly named Constr function"] - val mkConstructUi : (pinductive * int) -> constr + val mkConstructUi : (Constr.pinductive * int) -> constr [@@ocaml.deprecated "Alias of similarly named Constr function"] - val mkCase : case_info * constr * constr * constr array -> constr + val mkCase : Constr.case_info * constr * constr * constr array -> constr [@@ocaml.deprecated "Alias of similarly named Constr function"] val mkFix : fixpoint -> constr [@@ocaml.deprecated "Alias of similarly named Constr function"] @@ -1015,6 +1109,8 @@ sig val mkNamedProd : Names.Id.t -> types -> types -> types val decompose_app : constr -> constr * constr list + [@@ocaml.deprecated "Alias for the function in [Constr]"] + val decompose_prod : constr -> (Names.Name.t*constr) list * constr val decompose_prod_n : int -> constr -> (Names.Name.t * constr) list * constr val decompose_prod_assum : types -> Context.Rel.t * types @@ -1026,26 +1122,46 @@ sig val compose_lam : (Names.Name.t * constr) list -> constr -> constr val destSort : constr -> Sorts.t + [@@ocaml.deprecated "Alias for the function in [Constr]"] val destVar : constr -> Names.Id.t + [@@ocaml.deprecated "Alias for the function in [Constr]"] val destApp : constr -> constr * constr array + [@@ocaml.deprecated "Alias for the function in [Constr]"] val destProd : types -> Names.Name.t * types * types + [@@ocaml.deprecated "Alias for the function in [Constr]"] val destLetIn : constr -> Names.Name.t * constr * types * constr - val destEvar : constr -> existential + [@@ocaml.deprecated "Alias for the function in [Constr]"] + val destEvar : constr -> Constr.existential + [@@ocaml.deprecated "Alias for the function in [Constr]"] val destRel : constr -> int - val destConst : constr -> Names.Constant.t puniverses - val destCast : constr -> constr * cast_kind * constr + [@@ocaml.deprecated "Alias for the function in [Constr]"] + val destConst : constr -> Names.Constant.t Constr.puniverses + [@@ocaml.deprecated "Alias for the function in [Constr]"] + val destCast : constr -> constr * Constr.cast_kind * constr + [@@ocaml.deprecated "Alias for the function in [Constr]"] val destLambda : constr -> Names.Name.t * types * constr + [@@ocaml.deprecated "Alias for the function in [Constr]"] val isRel : constr -> bool + [@@ocaml.deprecated "Alias for the function in [Constr]"] val isVar : constr -> bool + [@@ocaml.deprecated "Alias for the function in [Constr]"] val isEvar : constr -> bool + [@@ocaml.deprecated "Alias for the function in [Constr]"] val isLetIn : constr -> bool + [@@ocaml.deprecated "Alias for the function in [Constr]"] val isLambda : constr -> bool + [@@ocaml.deprecated "Alias for the function in [Constr]"] val isConst : constr -> bool + [@@ocaml.deprecated "Alias for the function in [Constr]"] val isEvar_or_Meta : constr -> bool + [@@ocaml.deprecated "Alias for the function in [Constr]"] val isCast : constr -> bool + [@@ocaml.deprecated "Alias for the function in [Constr]"] val isMeta : constr -> bool + [@@ocaml.deprecated "Alias for the function in [Constr]"] val isApp : constr -> bool + [@@ocaml.deprecated "Alias for the function in [Constr]"] val fold_constr : ('a -> constr -> 'a) -> 'a -> constr -> 'a [@@ocaml.deprecated "Alias of Constr.fold"] @@ -1059,13 +1175,13 @@ sig val it_mkLambda_or_LetIn : constr -> Context.Rel.t -> constr val it_mkProd_or_LetIn : types -> Context.Rel.t -> types val prod_applist : constr -> constr list -> constr - exception DestKO + val map_constr : (constr -> constr) -> constr -> constr [@@ocaml.deprecated "Alias of Constr.map"] - val mkIndU : pinductive -> constr + val mkIndU : Constr.pinductive -> constr [@@ocaml.deprecated "Alias of Constr.mkIndU"] - val mkConstU : pconstant -> constr + val mkConstU : Constr.pconstant -> constr [@@ocaml.deprecated "Alias of Constr.mkConstU"] val map_constr_with_binders : ('a -> 'a) -> ('a -> constr -> constr) -> 'a -> constr -> constr @@ -1104,18 +1220,31 @@ sig val constr_ord : constr -> constr -> int [@@ocaml.deprecated "alias of Term.compare"] - val destInd : constr -> Names.inductive puniverses + val destInd : constr -> Names.inductive Constr.puniverses + [@@ocaml.deprecated "Alias for the function in [Constr]"] val univ_of_sort : Sorts.t -> Univ.Universe.t + [@@ocaml.deprecated "Alias for the function in [Constr]"] val strip_lam : constr -> constr val strip_prod_assum : types -> types val decompose_lam_assum : constr -> Context.Rel.t * constr val destFix : constr -> fixpoint + [@@ocaml.deprecated "Alias for the function in [Constr]"] val compare_constr : (constr -> constr -> bool) -> constr -> constr -> bool [@@ocaml.deprecated "Alias of Constr.compare_head."] + type constr = Constr.t + [@@ocaml.deprecated "Alias of Constr.t"] + type types = Constr.t + [@@ocaml.deprecated "Alias of Constr.types"] + + type fixpoint = (int array * int) * Constr.rec_declaration + [@@ocaml.deprecated "Alias of Constr.Constr.fixpoint"] + type cofixpoint = int * Constr.rec_declaration + [@@ocaml.deprecated "Alias of Constr.cofixpoint"] + end module Mod_subst : @@ -1288,8 +1417,8 @@ sig | TemplateArity of 'b type constant_universes = - | Monomorphic_const of Univ.universe_context - | Polymorphic_const of Univ.abstract_universe_context + | Monomorphic_const of Univ.UContext.t + | Polymorphic_const of Univ.AUContext.t type projection_body = { proj_ind : Names.MutInd.t; @@ -1308,7 +1437,7 @@ sig type constant_body = { const_hyps : Context.Named.t; const_body : constant_def; - const_type : Term.types; + const_type : Constr.types; const_body_code : Cemitcodes.to_patch_substituted option; const_universes : constant_universes; const_proj : projection_body option; @@ -1355,12 +1484,12 @@ sig | MEwith of module_alg_expr * with_declaration type abstract_inductive_universes = - | Monomorphic_ind of Univ.universe_context - | Polymorphic_ind of Univ.abstract_universe_context - | Cumulative_ind of Univ.abstract_cumulativity_info + | Monomorphic_ind of Univ.UContext.t + | Polymorphic_ind of Univ.AUContext.t + | Cumulative_ind of Univ.ACumulativityInfo.t type record_body = (Id.t * Constant.t array * projection_body array) option - + type mutual_inductive_body = { mind_packets : one_inductive_body array; mind_record : record_body option; @@ -1422,9 +1551,9 @@ sig | LocalAssumEntry of constr type inductive_universes = - | Monomorphic_ind_entry of Univ.universe_context - | Polymorphic_ind_entry of Univ.universe_context - | Cumulative_ind_entry of Univ.cumulativity_info + | Monomorphic_ind_entry of Univ.UContext.t + | Polymorphic_ind_entry of Univ.UContext.t + | Cumulative_ind_entry of Univ.CumulativityInfo.t type one_inductive_entry = { mind_entry_typename : Id.t; @@ -1451,8 +1580,8 @@ sig type 'a proof_output = Constr.t Univ.in_universe_context_set * 'a type 'a const_entry_body = 'a proof_output Future.computation type constant_universes_entry = - | Monomorphic_const_entry of Univ.universe_context - | Polymorphic_const_entry of Univ.universe_context + | Monomorphic_const_entry of Univ.UContext.t + | Polymorphic_const_entry of Univ.UContext.t type 'a definition_entry = { const_entry_body : 'a const_entry_body; (* List of section variables *) @@ -1493,12 +1622,12 @@ sig utj_val : 'types; utj_type : Sorts.t } - type unsafe_type_judgment = Term.types punsafe_type_judgment + type unsafe_type_judgment = Constr.types punsafe_type_judgment val empty_env : env val lookup_mind : Names.MutInd.t -> env -> Declarations.mutual_inductive_body val push_rel : Context.Rel.Declaration.t -> env -> env val push_rel_context : Context.Rel.t -> env -> env - val push_rec_types : Term.rec_declaration -> env -> env + val push_rec_types : Constr.rec_declaration -> env -> env val lookup_rel : int -> env -> Context.Rel.Declaration.t val lookup_named : Names.Id.t -> env -> Context.Named.Declaration.t val lookup_named_val : Names.Id.t -> named_context_val -> Context.Named.Declaration.t @@ -1538,13 +1667,13 @@ sig | FConstruct of Names.constructor Univ.puniverses | FApp of fconstr * fconstr array | FProj of Names.Projection.t * fconstr - | FFix of Term.fixpoint * fconstr Esubst.subs - | FCoFix of Term.cofixpoint * fconstr Esubst.subs - | FCaseT of Term.case_info * Constr.t * fconstr * Constr.t array * fconstr Esubst.subs (* predicate and branches are closures *) + | FFix of Constr.fixpoint * fconstr Esubst.subs + | FCoFix of Constr.cofixpoint * fconstr Esubst.subs + | FCaseT of Constr.case_info * Constr.t * fconstr * Constr.t array * fconstr Esubst.subs (* predicate and branches are closures *) | FLambda of int * (Names.Name.t * Constr.t) list * Constr.t * fconstr Esubst.subs | FProd of Names.Name.t * fconstr * fconstr | FLetIn of Names.Name.t * fconstr * fconstr * Constr.t * fconstr Esubst.subs - | FEvar of Term.existential * fconstr Esubst.subs + | FEvar of Constr.existential * fconstr Esubst.subs | FLIFT of int * fconstr | FCLOS of Constr.t * fconstr Esubst.subs | FLOCKED @@ -1580,7 +1709,7 @@ sig val betaiota : RedFlags.reds val betaiotazeta : RedFlags.reds - val create_clos_infos : ?evars:(Term.existential -> Constr.t option) -> RedFlags.reds -> Environ.env -> clos_infos + val create_clos_infos : ?evars:(Constr.existential -> Constr.t option) -> RedFlags.reds -> Environ.env -> clos_infos val whd_val : clos_infos -> fconstr -> Constr.t @@ -1601,13 +1730,13 @@ sig val whd_betaiotazeta : Environ.env -> Constr.t -> Constr.t - val is_arity : Environ.env -> Term.types -> bool + val is_arity : Environ.env -> Constr.types -> bool - val dest_prod : Environ.env -> Term.types -> Context.Rel.t * Term.types + val dest_prod : Environ.env -> Constr.types -> Context.Rel.t * Constr.types type 'a extended_conversion_function = ?l2r:bool -> ?reds:Names.transparent_state -> Environ.env -> - ?evars:((Term.existential->Constr.t option) * UGraph.t) -> + ?evars:((Constr.existential->Constr.t option) * UGraph.t) -> 'a -> 'a -> unit val conv : Constr.t extended_conversion_function end @@ -1616,7 +1745,7 @@ module Type_errors : sig open Names - open Term + open Constr open Environ type 'constr pguard_error = @@ -1648,9 +1777,9 @@ sig | UnboundVar of variable | NotAType of ('constr, 'types) punsafe_judgment | BadAssumption of ('constr, 'types) punsafe_judgment - | ReferenceVariables of identifier * 'constr - | ElimArity of pinductive * sorts_family list * 'constr * ('constr, 'types) punsafe_judgment - * (sorts_family * sorts_family * arity_error) option + | 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 | WrongCaseInfo of pinductive * case_info | NumberBranches of ('constr, 'types) punsafe_judgment * int @@ -1682,16 +1811,16 @@ end module Inductive : sig type mind_specif = Declarations.mutual_inductive_body * Declarations.one_inductive_body - val type_of_inductive : Environ.env -> mind_specif Univ.puniverses -> Term.types + val type_of_inductive : Environ.env -> mind_specif Univ.puniverses -> Constr.types exception SingletonInductiveBecomesProp of Names.Id.t val lookup_mind_specif : Environ.env -> Names.inductive -> mind_specif - val find_inductive : Environ.env -> Term.types -> Term.pinductive * Constr.t list + val find_inductive : Environ.env -> Constr.types -> Constr.pinductive * Constr.t list end module Typeops : sig - val infer_type : Environ.env -> Term.types -> Environ.unsafe_type_judgment - val type_of_constant_in : Environ.env -> Term.pconstant -> Term.types + val infer_type : Environ.env -> Constr.types -> Environ.unsafe_type_judgment + val type_of_constant_in : Environ.env -> Constr.pconstant -> Constr.types end module Mod_typing : @@ -1756,7 +1885,7 @@ sig type glob_constraint = glob_level * Univ.constraint_type * glob_level - type case_style = Term.case_style = + type case_style = Constr.case_style = | LetStyle | IfStyle | LetPatternStyle @@ -1857,8 +1986,8 @@ end module Univops : sig - val universes_of_constr : Term.constr -> Univ.universe_set - val restrict_universe_context : Univ.universe_context_set -> Univ.universe_set -> Univ.universe_context_set + val universes_of_constr : Constr.constr -> Univ.LSet.t + val restrict_universe_context : Univ.ContextSet.t -> Univ.LSet.t -> Univ.ContextSet.t end module Nameops : @@ -1934,8 +2063,10 @@ sig val split_dirpath : Names.DirPath.t -> Names.DirPath.t * Names.Id.t val dirpath_of_string : string -> Names.DirPath.t val pr_dirpath : Names.DirPath.t -> Pp.t + [@@ocaml.deprecated "Alias for DirPath.print"] val string_of_path : full_path -> string + val basename : full_path -> Names.Id.t type object_name = full_path * Names.KerName.t @@ -2006,7 +2137,7 @@ module Pattern : sig type case_info_pattern = - { cip_style : Misctypes.case_style; + { cip_style : Constr.case_style; cip_ind : Names.inductive option; cip_ind_tags : bool list option; (** indicates LetIn/Lambda in arity *) cip_extensible : bool (** does this match end with _ => _ ? *) } @@ -2027,8 +2158,8 @@ sig | PIf of constr_pattern * constr_pattern * constr_pattern | PCase of case_info_pattern * constr_pattern * constr_pattern * (int * bool list * constr_pattern) list (** index of constructor, nb of args *) - | PFix of Term.fixpoint - | PCoFix of Term.cofixpoint + | PFix of Constr.fixpoint + | PCoFix of Constr.cofixpoint end @@ -2079,7 +2210,7 @@ sig | GLambda of Names.Name.t * Decl_kinds.binding_kind * 'a glob_constr_g * 'a glob_constr_g | GProd of Names.Name.t * Decl_kinds.binding_kind * 'a glob_constr_g * 'a glob_constr_g | GLetIn of Names.Name.t * 'a glob_constr_g * 'a glob_constr_g option * 'a glob_constr_g - | GCases of Term.case_style * 'a glob_constr_g option * 'a tomatch_tuples_g * 'a cases_clauses_g + | GCases of Constr.case_style * 'a glob_constr_g option * 'a tomatch_tuples_g * 'a cases_clauses_g | GLetTuple of Names.Name.t list * (Names.Name.t * 'a glob_constr_g option) * 'a glob_constr_g * 'a glob_constr_g | GIf of 'a glob_constr_g * (Names.Name.t * 'a glob_constr_g option) * 'a glob_constr_g * 'a glob_constr_g | GRec of 'a fix_kind_g * Names.Id.t array * 'a glob_decl_g list array * @@ -2142,7 +2273,7 @@ sig | NProd of Names.Name.t * notation_constr * notation_constr | NBinderList of Names.Id.t * Names.Id.t * notation_constr * notation_constr | NLetIn of Names.Name.t * notation_constr * notation_constr option * notation_constr - | NCases of Term.case_style * notation_constr option * + | NCases of Constr.case_style * notation_constr option * (notation_constr * (Names.Name.t * (Names.inductive * Names.Name.t list) option)) list * (Glob_term.cases_pattern list * notation_constr) list | NLetTuple of Names.Name.t list * (Names.Name.t * notation_constr option) * @@ -2214,7 +2345,7 @@ sig | CApp of (proj_flag * constr_expr) * (constr_expr * explicitation Loc.located option) list | CRecord of (Libnames.reference * constr_expr) list - | CCases of Term.case_style + | CCases of Constr.case_style * constr_expr option * case_expr list * branch_expr list @@ -2606,9 +2737,9 @@ module Universes : sig type universe_binders type universe_opt_subst - val fresh_inductive_instance : Environ.env -> Names.inductive -> Term.pinductive Univ.in_universe_context_set - val new_Type : Names.DirPath.t -> Term.types - val type_of_global : Globnames.global_reference -> Term.types Univ.in_universe_context_set + val fresh_inductive_instance : Environ.env -> Names.inductive -> Constr.pinductive Univ.in_universe_context_set + val new_Type : Names.DirPath.t -> Constr.types + val type_of_global : Globnames.global_reference -> Constr.types Univ.in_universe_context_set val constr_of_global : Globnames.global_reference -> Constr.t val new_univ_level : Names.DirPath.t -> Univ.Level.t val new_sort_in_family : Sorts.family -> Sorts.t @@ -2733,7 +2864,7 @@ sig val create_evar_defs : evar_map -> evar_map - val meta_declare : Constr.metavariable -> Term.types -> ?name:Names.Name.t -> evar_map -> evar_map + val meta_declare : Constr.metavariable -> Constr.types -> ?name:Names.Name.t -> evar_map -> evar_map val clear_metas : evar_map -> evar_map @@ -2744,7 +2875,7 @@ sig val fresh_global : ?loc:Loc.t -> ?rigid:rigid -> ?names:Univ.Instance.t -> Environ.env -> evar_map -> Globnames.global_reference -> evar_map * Constr.t val evar_filtered_context : evar_info -> Context.Named.t - val fresh_inductive_instance : ?loc:Loc.t -> Environ.env -> evar_map -> Names.inductive -> evar_map * Term.pinductive + val fresh_inductive_instance : ?loc:Loc.t -> Environ.env -> evar_map -> Names.inductive -> evar_map * Constr.pinductive val fold_undefined : (Evar.t -> evar_info -> 'a -> 'a) -> evar_map -> 'a -> 'a val universe_context_set : evar_map -> Univ.ContextSet.t @@ -2801,8 +2932,8 @@ sig type evar_universe_context = UState.t [@@ocaml.deprecated "alias of API.UState.t"] - val existential_opt_value : evar_map -> Term.existential -> Constr.t option - val existential_value : evar_map -> Term.existential -> Constr.t + val existential_opt_value : evar_map -> Constr.existential -> Constr.t option + val existential_value : evar_map -> Constr.existential -> Constr.t exception NotInstantiatedEvar @@ -3033,7 +3164,7 @@ sig val map_constr_with_binders_left_to_right : Evd.evar_map -> (EConstr.rel_declaration -> 'a -> 'a) -> ('a -> EConstr.constr -> EConstr.constr) -> 'a -> EConstr.constr -> EConstr.constr - (** Remove the outer-most {!Term.kind_of_term.Cast} from a given term. *) + (** Remove the outer-most {!Constr.kind_of_term.Cast} from a given term. *) val strip_outer_cast : Evd.evar_map -> EConstr.constr -> EConstr.constr (** [nb_lam] ⟦[fun (x1:t1)...(xn:tn) => c]⟧ where [c] is not an abstraction gives [n]. @@ -3044,7 +3175,7 @@ sig val push_rel_assum : Names.Name.t * EConstr.types -> Environ.env -> Environ.env (** [push_rels_assum env_assumptions env] adds given {i env assumptions} to the {i env context} of a given {i environment}. *) - val push_rels_assum : (Names.Name.t * Term.types) list -> Environ.env -> Environ.env + val push_rels_assum : (Names.Name.t * Constr.types) list -> Environ.env -> Environ.env type meta_value_map = (Constr.metavariable * Constr.t) list @@ -3146,7 +3277,7 @@ sig ?naming:Misctypes.intro_pattern_naming_expr -> ?principal:bool -> Evd.rigid -> Evd.evar_map * (EConstr.constr * Sorts.t) val nf_evars_universes : Evd.evar_map -> Constr.t -> Constr.t - val safe_evar_value : Evd.evar_map -> Term.existential -> Constr.t option + val safe_evar_value : Evd.evar_map -> Constr.existential -> Constr.t option val evd_comb1 : (Evd.evar_map -> 'b -> Evd.evar_map * 'a) -> Evd.evar_map ref -> 'b -> 'a end @@ -3514,14 +3645,14 @@ sig | IndType of inductive_family * EConstr.constr list type constructor_summary = { - cs_cstr : Term.pconstructor; + cs_cstr : Constr.pconstructor; cs_params : Constr.t list; cs_nargs : int; cs_args : Context.Rel.t; cs_concl_realargs : Constr.t array; } - val arities_of_constructors : Environ.env -> Term.pinductive -> Term.types array + val arities_of_constructors : Environ.env -> Constr.pinductive -> Constr.types array val constructors_nrealargs_env : Environ.env -> Names.inductive -> int array val constructor_nallargs_env : Environ.env -> Names.constructor -> int @@ -3529,16 +3660,16 @@ sig val inductive_nparamdecls : Names.inductive -> int - val type_of_constructors : Environ.env -> Term.pinductive -> Term.types array + val type_of_constructors : Environ.env -> Constr.pinductive -> Constr.types array val find_mrectype : Environ.env -> Evd.evar_map -> EConstr.types -> (Names.inductive * EConstr.EInstance.t) * EConstr.constr list val mis_is_recursive : Names.inductive * Declarations.mutual_inductive_body * Declarations.one_inductive_body -> bool val nconstructors : Names.inductive -> int val find_rectype : Environ.env -> Evd.evar_map -> EConstr.types -> inductive_type val get_constructors : Environ.env -> inductive_family -> constructor_summary array - val dest_ind_family : inductive_family -> Names.inductive Term.puniverses * Constr.t list + val dest_ind_family : inductive_family -> Names.inductive Constr.puniverses * Constr.t list val find_inductive : Environ.env -> Evd.evar_map -> EConstr.types -> (Names.inductive * EConstr.EInstance.t) * Constr.t list - val type_of_inductive : Environ.env -> Term.pinductive -> Term.types + val type_of_inductive : Environ.env -> Constr.pinductive -> Constr.types end module Impargs : @@ -4190,12 +4321,12 @@ module Indrec : sig type dep_flag = bool val lookup_eliminator : Names.inductive -> Sorts.family -> Globnames.global_reference - val build_case_analysis_scheme : Environ.env -> Evd.evar_map -> Term.pinductive -> + val build_case_analysis_scheme : Environ.env -> Evd.evar_map -> Constr.pinductive -> dep_flag -> Sorts.family -> Evd.evar_map * Constr.t val make_elimination_ident : Names.Id.t -> Sorts.family -> Names.Id.t val build_mutual_induction_scheme : - Environ.env -> Evd.evar_map -> (Term.pinductive * dep_flag * Sorts.family) list -> Evd.evar_map * Constr.t list - val build_case_analysis_scheme_default : Environ.env -> Evd.evar_map -> Term.pinductive -> + Environ.env -> Evd.evar_map -> (Constr.pinductive * dep_flag * Sorts.family) list -> Evd.evar_map * Constr.t list + val build_case_analysis_scheme_default : Environ.env -> Evd.evar_map -> Constr.pinductive -> Sorts.family -> Evd.evar_map * Constr.t end @@ -4389,6 +4520,8 @@ sig val default_binder_kind : Constrexpr.binder_kind val mkLetInC : Names.Name.t Loc.located * Constrexpr.constr_expr * Constrexpr.constr_expr option * Constrexpr.constr_expr -> Constrexpr.constr_expr val mkCProdN : ?loc:Loc.t -> Constrexpr.local_binder_expr list -> Constrexpr.constr_expr -> Constrexpr.constr_expr + val replace_vars_constr_expr : + Names.Id.t Names.Id.Map.t -> Constrexpr.constr_expr -> Constrexpr.constr_expr end module Notation_ops : @@ -4443,8 +4576,11 @@ end module Topconstr : sig + val replace_vars_constr_expr : - Names.Id.t Names.Id.Map.t -> Constrexpr.constr_expr -> Constrexpr.constr_expr + Names.Id.t Names.Id.Map.t -> Constrexpr.constr_expr -> Constrexpr.constr_expr + [@@ocaml.deprecated "use Constrexpr_ops.free_vars_of_constr_expr"] + end module Constrintern : @@ -4485,13 +4621,13 @@ sig val interp_open_constr : Environ.env -> Evd.evar_map -> Constrexpr.constr_expr -> Evd.evar_map * EConstr.constr val locate_reference : Libnames.qualid -> Globnames.global_reference val interp_type : Environ.env -> Evd.evar_map -> ?impls:internalization_env -> - Constrexpr.constr_expr -> Term.types Evd.in_evar_universe_context + Constrexpr.constr_expr -> Constr.types Evd.in_evar_universe_context val interp_context_evars : ?global_level:bool -> ?impl_env:internalization_env -> ?shift:int -> Environ.env -> Evd.evar_map ref -> Constrexpr.local_binder_expr list -> internalization_env * ((Environ.env * EConstr.rel_context) * Impargs.manual_implicits) val compute_internalization_data : Environ.env -> var_internalization_type -> - Term.types -> Impargs.manual_explicitation list -> var_internalization_data + Constr.types -> Impargs.manual_explicitation list -> var_internalization_data val empty_internalization_env : internalization_env val global_reference : Names.Id.t -> Globnames.global_reference end @@ -4520,7 +4656,7 @@ sig type section_variable_entry = | SectionLocalDef of Safe_typing.private_constants Entries.definition_entry - | SectionLocalAssum of Term.types Univ.in_universe_context_set * Decl_kinds.polymorphic * bool + | SectionLocalAssum of Constr.types Univ.in_universe_context_set * Decl_kinds.polymorphic * bool type variable_declaration = Names.DirPath.t * section_variable_entry * Decl_kinds.logical_kind @@ -4534,7 +4670,7 @@ sig ?local:bool -> ?poly:Decl_kinds.polymorphic -> Names.Id.t -> ?types:Constr.t -> Constr.t Univ.in_universe_context_set -> Names.Constant.t val definition_entry : ?fix_exn:Future.fix_exn -> - ?opaque:bool -> ?inline:bool -> ?types:Term.types -> + ?opaque:bool -> ?inline:bool -> ?types:Constr.types -> ?poly:Decl_kinds.polymorphic -> ?univs:Univ.UContext.t -> ?eff:Safe_typing.private_constants -> Constr.t -> Safe_typing.private_constants Entries.definition_entry val definition_message : Names.Id.t -> unit @@ -4645,16 +4781,23 @@ sig type proof type 'a focus_kind + val proof : proof -> + Goal.goal list * (Goal.goal list * Goal.goal list) list * + Goal.goal list * Goal.goal list * Evd.evar_map + val run_tactic : Environ.env -> unit Proofview.tactic -> proof -> proof * (bool * Proofview_monad.Info.tree) val unshelve : proof -> proof val maximal_unfocus : 'a focus_kind -> proof -> proof val pr_proof : proof -> Pp.t + module V82 : sig val grab_evars : proof -> proof val subgoals : proof -> Goal.goal list Evd.sigma + [@@ocaml.deprecated "Use the first and fifth argument of [Proof.proof]"] + end end @@ -4941,7 +5084,6 @@ sig val ident : Id.t Gram.entry val name : Name.t located Gram.entry val identref : Id.t located Gram.entry - val pidentref : (Id.t located * (Id.t located list) option) Gram.entry val pattern_ident : Id.t Gram.entry val pattern_identref : Id.t located Gram.entry val base_ident : Id.t Gram.entry @@ -5138,12 +5280,20 @@ sig val pr_lconstr_env : Environ.env -> Evd.evar_map -> Constr.t -> Pp.t val pr_constr : Constr.t -> Pp.t + [@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_lconstr : Constr.t -> Pp.t + [@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_econstr : EConstr.constr -> Pp.t + [@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] + val pr_glob_constr : Glob_term.glob_constr -> Pp.t + [@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] + val pr_constr_pattern : Pattern.constr_pattern -> Pp.t + [@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] + 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 @@ -5151,11 +5301,17 @@ sig 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 : Ltac_pretype.closed_glob_constr -> Pp.t + [@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_lglob_constr : Glob_term.glob_constr -> Pp.t + [@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_leconstr_env : Environ.env -> Evd.evar_map -> EConstr.constr -> Pp.t val pr_leconstr : EConstr.constr -> Pp.t + [@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] + val pr_global : Globnames.global_reference -> Pp.t val pr_lconstr_under_binders : Ltac_pretype.constr_under_binders -> Pp.t + [@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] + 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 -> Ltac_pretype.constr_under_binders -> Pp.t @@ -5163,8 +5319,11 @@ sig 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 + val pr_ltype : Constr.types -> Pp.t + [@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_ljudge : EConstr.unsafe_judgment -> Pp.t * Pp.t + [@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] + val pr_idpred : Names.Id.Pred.t -> Pp.t val pr_cpred : Names.Cpred.t -> Pp.t val pr_transparent_state : Names.transparent_state -> Pp.t @@ -5593,7 +5752,7 @@ end module Hints : sig - type raw_hint = EConstr.t * EConstr.types * Univ.universe_context_set + type raw_hint = EConstr.t * EConstr.types * Univ.ContextSet.t type 'a hint_ast = | Res_pf of 'a (* Hint Apply *) @@ -5677,7 +5836,9 @@ sig val create_hint_db : bool -> hint_db_name -> Names.transparent_state -> bool -> unit val empty_hint_info : 'a Vernacexpr.hint_info_gen val repr_hint : hint -> (raw_hint * Clenv.clausenv) hint_ast + val pr_hint_db_env : Environ.env -> Evd.evar_map -> Hint_db.t -> Pp.t val pr_hint_db : Hint_db.t -> Pp.t + [@@ocaml.deprecated "please used pr_hint_db_env"] end module Auto : @@ -5741,7 +5902,7 @@ end module Autorewrite : sig type rew_rule = { rew_lemma: Constr.t; - rew_type: Term.types; + rew_type: Constr.types; rew_pat: Constr.t; rew_ctx: Univ.ContextSet.t; rew_l2r: bool; @@ -5754,7 +5915,7 @@ sig val add_rew_rules : string -> raw_rew_rule list -> unit val find_rewrites : string -> rew_rule list val find_matches : string -> Constr.t -> rew_rule list - val print_rewrite_hintdb : string -> Pp.t + val print_rewrite_hintdb : Environ.env -> Evd.evar_map -> string -> Pp.t end (************************************************************************) @@ -5787,11 +5948,12 @@ sig Future.fix_exn -> 'a declaration_hook -> Decl_kinds.locality -> Globnames.global_reference -> 'a val save_proof : ?proof:Proof_global.closed_proof -> Vernacexpr.proof_end -> unit val get_current_context : unit -> Evd.evar_map * Environ.env + [@@ocaml.deprecated "please use [Pfedit.get_current_context]"] end module Himsg : sig - val explain_refiner_error : Logic.refiner_error -> Pp.t + val explain_refiner_error : Environ.env -> Evd.evar_map -> Logic.refiner_error -> Pp.t val explain_pretype_error : Environ.env -> Evd.evar_map -> Pretype_errors.pretype_error -> Pp.t end diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index db02f7834..067a2a8a7 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -36,6 +36,10 @@ Here are a few tags Coq developers may add to your PR and what they mean. In gen - [needs: fixing](https://github.com/coq/coq/pulls?q=is%3Aopen+is%3Apr+label%3A%22needs%3A+fixing%22) indicates the PR needs a fix, as discussed in the comments. - [needs: testing](https://github.com/coq/coq/pulls?q=is%3Aopen+is%3Apr+label%3A%22needs%3A+testing%22) indicates the PR needs testing. This is often used when testing beyond what the test suite can handle is required. For example, performance benchmarking is currently performed with a different infrastructure. Unless some followup is specifically requested you aren't expected to do this additional testing. +The release manager uses the following filter to know which PRs seem ready for merge. If you are waiting for a PR to be merged, make sure it appears in this list: + +- [Pull requests ready for merge](https://github.com/coq/coq/pulls?utf8=%E2%9C%93&q=is%3Apr%20is%3Aopen%20-label%3A%22needs%3A%20discussion%22%20-label%3A%22needs%3A%20testing%22%20-label%3A%22needs%3A%20fixing%22%20-label%3A%22needs%3A%20progress%22%20-label%3A%22needs%3A%20rebase%22%20-label%3A%22needs%3A%20review%22%20-label%3A%22needs%3A%20independent%20fix%22%20-label%3A%22needs%3A%20feedback%22%20-label%3A%22help%20wanted%22%20-review%3Achanges_requested%20-status%3Apending%20base%3Amaster%20sort%3Aupdated-asc%20) + ## Documentation Currently the process for contributing to the documentation is the same as for changing anything else in Coq, so please submit a pull request as described above. diff --git a/Makefile.ci b/Makefile.ci index 0b2cbb663..a17d4ddf7 100644 --- a/Makefile.ci +++ b/Makefile.ci @@ -5,6 +5,7 @@ CI_TARGETS=ci-all \ ci-coq-dpdgraph \ ci-coquelicot \ ci-cpdt \ + ci-equations \ ci-fiat-crypto \ ci-fiat-parsers \ ci-flocq \ diff --git a/configure.ml b/configure.ml index 0952b15f5..86f6b7fe3 100644 --- a/configure.ml +++ b/configure.ml @@ -266,6 +266,7 @@ module Prefs = struct let nativecompiler = ref (not (os_type_win32 || os_type_cygwin)) let coqwebsite = ref "http://coq.inria.fr/" let force_caml_version = ref false + let force_findlib_version = ref false let warn_error = ref false end @@ -334,6 +335,8 @@ let args_options = Arg.align [ " URL of the coq website"; "-force-caml-version", Arg.Set Prefs.force_caml_version, " Force OCaml version"; + "-force-findlib-version", Arg.Set Prefs.force_findlib_version, + " Force findlib version"; "-warn-error", Arg.Set Prefs.warn_error, " Make OCaml warnings into errors"; "-camldir", Arg.String (fun _ -> ()), @@ -439,7 +442,7 @@ let browser = (** * OCaml programs *) -let camlbin, caml_version, camllib = +let camlbin, caml_version, camllib, findlib_version = let () = match !Prefs.ocamlfindcmd with | Some cmd -> reset_caml_find camlexec cmd | None -> @@ -451,6 +454,7 @@ let camlbin, caml_version, camllib = if not (is_executable camlexec.find) then die ("Error: cannot find the executable '"^camlexec.find^"'.") else + let findlib_version, _ = run camlexec.find ["query"; "findlib"; "-format"; "%v"] in let caml_version, _ = run camlexec.find ["ocamlc";"-version"] in let camllib, _ = run camlexec.find ["printconf";"stdlib"] in let camlbin = (* TODO beurk beurk beurk *) @@ -461,7 +465,7 @@ let camlbin, caml_version, camllib = let () = if is_executable (camlbin / "ocaml") then reset_caml_top camlexec (camlbin / "ocaml") in - camlbin, caml_version, camllib + camlbin, caml_version, camllib, findlib_version let camlp4compat = "-loc loc" @@ -491,8 +495,27 @@ let check_caml_version () = let _ = check_caml_version () -let coq_debug_flag_opt = - if caml_version_nums >= [3;10] then coq_debug_flag else "" +let findlib_version_list = numeric_prefix_list findlib_version + +let findlib_version_nums = + try + if List.length findlib_version_list < 2 then failwith "bad version"; + List.map s2i findlib_version_list + with _ -> + die ("I found ocamlfind but cannot read its version number!\n" ^ + "Is it installed properly?") + +let check_findlib_version () = + if findlib_version_nums >= [1;4;1] then + printf "You have OCamlfind %s. Good!\n" findlib_version + else + let () = printf "Your version of OCamlfind is %s.\n" findlib_version in + if !Prefs.force_findlib_version then + printf "*Warning* Your version of OCamlfind is outdated.\n" + else + die "You need OCamlfind 1.4.1 or later." + +let _ = check_findlib_version () let camltag = match caml_version_list with | x::y::_ -> "OCAML"^x^y @@ -1168,7 +1191,7 @@ let write_makefile f = pr "CFLAGS=%s\n\n" cflags; pr "# Compilation debug flags\n"; pr "CAMLDEBUG=%s\n" coq_debug_flag; - pr "CAMLDEBUGOPT=%s\n\n" coq_debug_flag_opt; + pr "CAMLDEBUGOPT=%s\n\n" coq_debug_flag; pr "# Compilation profile flag\n"; pr "CAMLTIMEPROF=%s\n\n" coq_profile_flag; pr "# Camlp4 : flavor, binaries, libraries ...\n"; diff --git a/default.nix b/default.nix new file mode 100644 index 000000000..9efabdbc2 --- /dev/null +++ b/default.nix @@ -0,0 +1,64 @@ +# How to use? + +# If you have Nix installed, you can get in an environment with everything +# needed to compile Coq and CoqIDE by running: +# $ nix-shell +# at the root of the Coq repository. + +# How to tweak default arguments? + +# nix-shell supports the --arg option (see Nix doc) that allows you for +# instance to do this: +# $ nix-shell --arg ocamlPackages "(import <nixpkgs> {}).ocamlPackages_latest" --arg buildIde false + +# You can also compile Coq and "install" it by running: +# $ make clean # (only needed if you have left-over compilation files) +# $ nix-build +# at the root of the Coq repository. +# nix-build also supports the --arg option, so you will be able to do: +# $ nix-build --arg doCheck false +# if you want to speed up things by not running the test-suite. +# Once the build is finished, you will find, in the current directory, +# a symlink to where Coq was installed. + +{ pkgs ? (import <nixpkgs> {}), ocamlPackages ? pkgs.ocamlPackages, + buildIde ? true, doCheck ? true }: + +with pkgs; + +stdenv.mkDerivation rec { + + name = "coq"; + + buildInputs = (with ocamlPackages; [ + + # Coq dependencies + ocaml + findlib + camlp5_strict + + ]) ++ (if buildIde then [ + + # CoqIDE dependencies + ocamlPackages.lablgtk + + ] else []) ++ (if doCheck then [ + + # Test-suite dependencies + python + rsync + which + + ] else []); + + src = + if lib.inNixShell then null + else + with builtins; filterSource + (path: _: !elem (baseNameOf path) [".git" "result" "bin"]) ./.; + + prefixKey = "-prefix "; + + inherit doCheck; + +} diff --git a/dev/base_include b/dev/base_include index 1c98754fd..1da5e3ed1 100644 --- a/dev/base_include +++ b/dev/base_include @@ -130,7 +130,6 @@ open Reserve open Syntax_def open Constrexpr open Constrexpr_ops -open Topconstr open Notation_term open Notation_ops open Prettyp diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index cb1493d6a..168a34e6e 100644 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -135,3 +135,9 @@ ######################################################################## : ${bignums_CI_BRANCH:=master} : ${bignums_CI_GITURL:=https://github.com/coq/bignums.git} + +######################################################################## +# Equations +######################################################################## +: ${Equations_CI_BRANCH:=8.8+alpha} +: ${Equations_CI_GITURL:=https://github.com/mattam82/Coq-Equations.git} diff --git a/dev/ci/ci-equations.sh b/dev/ci/ci-equations.sh new file mode 100755 index 000000000..f7470463d --- /dev/null +++ b/dev/ci/ci-equations.sh @@ -0,0 +1,10 @@ +#!/usr/bin/env bash + +ci_dir="$(dirname "$0")" +source ${ci_dir}/ci-common.sh + +Equations_CI_DIR=${CI_BUILD_DIR}/Equations + +git_checkout ${Equations_CI_BRANCH} ${Equations_CI_GITURL} ${Equations_CI_DIR} + +( cd ${Equations_CI_DIR} && coq_makefile -f _CoqProject -o Makefile && make -j ${NJOBS} && make -j ${NJOBS} test-suite && make -j ${NJOBS} examples && make install) diff --git a/dev/tools/should-check-whitespace.sh b/dev/tools/should-check-whitespace.sh index 8159506b4..190511d95 100755 --- a/dev/tools/should-check-whitespace.sh +++ b/dev/tools/should-check-whitespace.sh @@ -2,4 +2,4 @@ # determine if a file has whitespace checking enabled in .gitattributes -git check-attr whitespace -- "$1" | grep -q -v 'unspecified$' +git check-attr whitespace -- "$1" | grep -q -v -e 'unset$' -e 'unspecified$' diff --git a/dev/top_printers.ml b/dev/top_printers.ml index 5b09436c2..df5f05469 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -39,7 +39,7 @@ let ppfuture kx = pp (Future.print (fun _ -> str "_") kx) let ppid id = pp (Id.print id) let pplab l = pp (Label.print l) let ppmbid mbid = pp (str (MBId.debug_to_string mbid)) -let ppdir dir = pp (pr_dirpath dir) +let ppdir dir = pp (DirPath.print dir) let ppmp mp = pp(str (ModPath.debug_to_string mp)) let ppcon con = pp(Constant.debug_print con) let ppproj con = pp(Constant.debug_print (Projection.constant con)) @@ -60,6 +60,7 @@ let pprecarg = function let ppwf_paths x = pp (Rtree.pp_tree pprecarg x) (* term printers *) +let envpp pp = let sigma,env = Pfedit.get_current_context () in pp env sigma let rawdebug = ref false let ppevar evk = pp (str (Evd.string_of_existential evk)) let ppconstr x = pp (Termops.print_constr (EConstr.of_constr x)) @@ -69,9 +70,9 @@ let ppconstrdb x = pp(Flags.with_option rawdebug Termops.print_constr (EConstr.o let ppterm = ppconstr let ppsconstr x = ppconstr (Mod_subst.force_constr x) let ppconstr_univ x = Constrextern.with_universes ppconstr x -let ppglob_constr = (fun x -> pp(pr_lglob_constr x)) -let pppattern = (fun x -> pp(pr_constr_pattern x)) -let pptype = (fun x -> try pp(pr_ltype x) with e -> pp (str (Printexc.to_string e))) +let ppglob_constr = (fun x -> pp(pr_lglob_constr_env (Global.env()) x)) +let pppattern = (fun x -> pp(envpp pr_constr_pattern_env x)) +let pptype = (fun x -> try pp(envpp pr_ltype_env x) with e -> pp (str (Printexc.to_string e))) let ppfconstr c = ppconstr (CClosure.term_of_fconstr c) let ppbigint n = pp (str (Bigint.to_string n));; @@ -121,7 +122,7 @@ let rec pr_closure {idents=idents;typed=typed;untyped=untyped} = and pr_closed_glob_constr_idmap x = pridmap (fun _ -> pr_closed_glob_constr) x and pr_closed_glob_constr {closure=closure;term=term} = - pr_closure closure ++ pr_lglob_constr term + pr_closure closure ++ (pr_lglob_constr_env Global.(env ())) term let ppclosure x = pp (pr_closure x) let ppclosedglobconstr x = pp (pr_closed_glob_constr x) @@ -140,14 +141,14 @@ let safe_pr_global = function let ppglobal x = try pp(pr_global x) with _ -> safe_pr_global x let ppconst (sp,j) = - pp (str"#" ++ KerName.print sp ++ str"=" ++ pr_lconstr j.uj_val) + pp (str"#" ++ KerName.print sp ++ str"=" ++ envpp pr_lconstr_env j.uj_val) let ppvar ((id,a)) = - pp (str"#" ++ Id.print id ++ str":" ++ pr_lconstr a) + pp (str"#" ++ Id.print id ++ str":" ++ envpp pr_lconstr_env a) let genppj f j = let (c,t) = f j in (c ++ str " : " ++ t) -let ppj j = pp (genppj pr_ljudge j) +let ppj j = pp (genppj (envpp pr_ljudge_env) j) let prsubst s = pp (Mod_subst.debug_pr_subst s) let prdelta s = pp (Mod_subst.debug_pr_delta s) @@ -175,13 +176,13 @@ let ppclenv clenv = pp(pr_clenv clenv) let ppgoalgoal gl = pp(Goal.pr_goal gl) let ppgoal g = pp(Printer.pr_goal g) let ppgoalsigma g = pp(Printer.pr_goal g ++ Termops.pr_evar_map None (Refiner.project g)) -let pphintdb db = pp(Hints.pr_hint_db db) +let pphintdb db = pp(envpp Hints.pr_hint_db_env db) let ppproofview p = let gls,sigma = Proofview.proofview p in pp(pr_enum Goal.pr_goal gls ++ fnl () ++ Termops.pr_evar_map (Some 1) sigma) let ppopenconstr (x : Evd.open_constr) = - let (evd,c) = x in pp (Termops.pr_evar_map (Some 2) evd ++ pr_constr c) + let (evd,c) = x in pp (Termops.pr_evar_map (Some 2) evd ++ envpp pr_constr_env c) (* spiwack: deactivated until a replacement is found let pppftreestate p = pp(print_pftreestate p) *) diff --git a/engine/eConstr.ml b/engine/eConstr.ml index bcfbc8081..afdceae06 100644 --- a/engine/eConstr.ml +++ b/engine/eConstr.ml @@ -9,7 +9,6 @@ open CErrors open Util open Names -open Term open Constr open Context open Evd @@ -55,7 +54,7 @@ struct type t = Sorts.t let make s = s let kind sigma = function - | Type u -> sort_of_univ (Evd.normalize_universe sigma u) + | Sorts.Type u -> Sorts.sort_of_univ (Evd.normalize_universe sigma u) | s -> s let unsafe_to_sorts s = s end @@ -85,16 +84,16 @@ let rec whd_evar sigma c = | Some c -> whd_evar sigma c | None -> c end - | App (f, args) when Term.isEvar f -> + | App (f, args) when isEvar f -> (** Enforce smart constructor invariant on applications *) - let ev = Term.destEvar f in + let ev = destEvar f in begin match safe_evar_value sigma ev with | None -> c | Some f -> whd_evar sigma (mkApp (f, args)) end - | Cast (c0, k, t) when Term.isEvar c0 -> + | Cast (c0, k, t) when isEvar c0 -> (** Enforce smart constructor invariant on casts. *) - let ev = Term.destEvar c0 in + let ev = destEvar c0 in begin match safe_evar_value sigma ev with | None -> c | Some c -> whd_evar sigma (mkCast (c, k, t)) @@ -115,7 +114,7 @@ let rec to_constr sigma c = match Constr.kind c with | Some c -> to_constr sigma c | None -> Constr.map (fun c -> to_constr sigma c) c end -| Sort (Type u) -> +| Sort (Sorts.Type u) -> let u' = Evd.normalize_universe sigma u in if u' == u then c else mkSort (Sorts.sort_of_univ u') | Const (c', u) when not (Univ.Instance.is_empty u) -> diff --git a/engine/engine.mllib b/engine/engine.mllib index afc02d7f6..a3614f6c4 100644 --- a/engine/engine.mllib +++ b/engine/engine.mllib @@ -1,12 +1,13 @@ -Logic_monad Universes +Univops UState +Nameops Evd EConstr Namegen Termops -Proofview_monad Evarutil +Logic_monad +Proofview_monad Proofview Ftactic -Geninterp diff --git a/engine/evarutil.ml b/engine/evarutil.ml index df4ef2ce7..14d07ccae 100644 --- a/engine/evarutil.ml +++ b/engine/evarutil.ml @@ -11,11 +11,11 @@ open Util open Names open Term open Constr -open Termops -open Namegen open Pre_env open Environ open Evd +open Termops +open Namegen module RelDecl = Context.Rel.Declaration module NamedDecl = Context.Named.Declaration diff --git a/engine/evarutil.mli b/engine/evarutil.mli index 62288ced4..42f2d5f25 100644 --- a/engine/evarutil.mli +++ b/engine/evarutil.mli @@ -238,7 +238,8 @@ val subterm_source : existential_key -> Evar_kinds.t Loc.located -> val meta_counter_summary_name : string -(** Deprecater *) - +(** Deprecated *) type type_constraint = types option +[@@ocaml.deprecated "use the version in Evardefine"] type val_constraint = constr option +[@@ocaml.deprecated "use the version in Evardefine"] diff --git a/engine/evd.ml b/engine/evd.ml index 8d465384b..60bd6de2a 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -243,7 +243,7 @@ let evar_instance_array test_id info args = instrec filter (evar_context info) 0 let make_evar_instance_array info args = - evar_instance_array (NamedDecl.get_id %> Term.isVarId) info args + evar_instance_array (NamedDecl.get_id %> isVarId) info args let instantiate_evar_array info c args = let inst = make_evar_instance_array info args in @@ -707,10 +707,10 @@ let extract_all_conv_pbs evd = extract_conv_pbs evd (fun _ -> true) let loc_of_conv_pb evd (pbty,env,t1,t2) = - match kind (fst (Term.decompose_app t1)) with + match kind (fst (decompose_app t1)) with | Evar (evk1,_) -> fst (evar_source evk1 evd) | _ -> - match kind (fst (Term.decompose_app t2)) with + match kind (fst (decompose_app t2)) with | Evar (evk2,_) -> fst (evar_source evk2 evd) | _ -> None diff --git a/engine/evd.mli b/engine/evd.mli index af5373582..17fa15045 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -599,11 +599,16 @@ type open_constr = evar_map * constr (* Special case when before is empty *) type unsolvability_explanation = SeveralInstancesFound of int (** Failure explanation. *) +(** {5 Summary names} *) + +(* This stuff is internal and should not be used. Currently a hack in + the STM relies on it. *) +val evar_counter_summary_name : string + (** {5 Deprecated functions} *) +val create_evar_defs : evar_map -> evar_map +(* XXX: This is supposed to be deprecated by used by ssrmatching, what + should the replacement be? *) -val create_evar_defs : evar_map -> evar_map (** Create an [evar_map] with empty meta map: *) -(** {5 Summary names} *) - -val evar_counter_summary_name : string diff --git a/library/nameops.ml b/engine/nameops.ml index d598a63b8..5105d7bec 100644 --- a/library/nameops.ml +++ b/engine/nameops.ml @@ -203,13 +203,14 @@ let pr_name = print let pr_lab l = Label.print l -let default_library = Names.DirPath.initial (* = ["Top"] *) - -(*s Roots of the space of absolute names *) -let coq_string = "Coq" -let coq_root = Id.of_string coq_string -let default_root_prefix = DirPath.empty - (* Metavariables *) let pr_meta = Pp.int let string_of_meta = string_of_int + +(* Deprecated *) +open Libnames +let default_library = default_library +let coq_string = coq_string +let coq_root = coq_root +let default_root_prefix = default_root_prefix + diff --git a/library/nameops.mli b/engine/nameops.mli index 60e5a90bb..0fec8a925 100644 --- a/library/nameops.mli +++ b/engine/nameops.mli @@ -89,6 +89,10 @@ module Name : sig end +(** Metavariables *) +val pr_meta : Constr.metavariable -> Pp.t +val string_of_meta : Constr.metavariable -> string + val out_name : Name.t -> Id.t [@@ocaml.deprecated "Same as [Name.get_id]"] @@ -119,18 +123,16 @@ val pr_id : Id.t -> Pp.t val pr_lab : Label.t -> Pp.t [@@ocaml.deprecated "Same as [Names.Label.print]"] -(** some preset paths *) - +(** Deprecated stuff to libnames *) val default_library : DirPath.t +[@@ocaml.deprecated "Same as [Libnames.default_library]"] -(** This is the root of the standard library of Coq *) val coq_root : module_ident (** "Coq" *) +[@@ocaml.deprecated "Same as [Libnames.coq_root]"] + val coq_string : string (** "Coq" *) +[@@ocaml.deprecated "Same as [Libnames.coq_string]"] -(** This is the default root prefix for developments which doesn't - mention a root *) val default_root_prefix : DirPath.t +[@@ocaml.deprecated "Same as [Libnames.default_root_prefix]"] -(** Metavariables *) -val pr_meta : Constr.metavariable -> Pp.t -val string_of_meta : Constr.metavariable -> string diff --git a/engine/proofview.ml b/engine/proofview.ml index 598358c47..3b945c87f 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -1200,7 +1200,7 @@ module V82 = struct { Evd.it = comb ; sigma = solution } let top_goals initial { solution=solution; } = - let goals = CList.map (fun (t,_) -> fst (Term.destEvar (EConstr.Unsafe.to_constr t))) initial in + let goals = CList.map (fun (t,_) -> fst (Constr.destEvar (EConstr.Unsafe.to_constr t))) initial in { Evd.it = goals ; sigma=solution; } let top_evars initial = diff --git a/engine/proofview.mli b/engine/proofview.mli index 0379d4b49..7f7acf874 100644 --- a/engine/proofview.mli +++ b/engine/proofview.mli @@ -563,6 +563,7 @@ module V82 : sig (* Returns the open goals of the proofview together with the evar_map to interpret them. *) val goals : proofview -> Evar.t list Evd.sigma + [@@ocaml.deprecated "Use [Proofview.proofview]"] val top_goals : entry -> proofview -> Evar.t list Evd.sigma diff --git a/engine/uState.ml b/engine/uState.ml index dfea25dd0..01a479821 100644 --- a/engine/uState.ml +++ b/engine/uState.ml @@ -437,6 +437,9 @@ let make_flexible_variable ctx ~algebraic u = {ctx with uctx_univ_variables = uvars'; uctx_univ_algebraic = avars'} +let make_flexible_nonalgebraic ctx = + {ctx with uctx_univ_algebraic = Univ.LSet.empty} + let is_sort_variable uctx s = match s with | Sorts.Type u -> diff --git a/engine/uState.mli b/engine/uState.mli index b31e94b28..1c906fcb2 100644 --- a/engine/uState.mli +++ b/engine/uState.mli @@ -104,6 +104,11 @@ val add_global_univ : t -> Univ.Level.t -> t universe. Otherwise the variable is just made flexible. *) val make_flexible_variable : t -> algebraic:bool -> Univ.Level.t -> t +(** Turn all undefined flexible algebraic variables into simply flexible + ones. Can be used in case the variables might appear in universe instances + (typically for polymorphic program obligations). *) +val make_flexible_nonalgebraic : t -> t + val is_sort_variable : t -> Sorts.t -> Univ.Level.t option val normalize_variables : t -> Univ.universe_subst * t diff --git a/engine/universes.mli b/engine/universes.mli index 24613c4b9..a960099ed 100644 --- a/engine/universes.mli +++ b/engine/universes.mli @@ -169,6 +169,7 @@ val constr_of_global : Globnames.global_reference -> constr (** ** DEPRECATED ** synonym of [constr_of_global] *) val constr_of_reference : Globnames.global_reference -> constr +[@@ocaml.deprecated "synonym of [constr_of_global]"] (** Returns the type of the global reference, by creating a fresh instance of polymorphic references and computing their instantiated universe context. (side-effect on the diff --git a/library/univops.ml b/engine/univops.ml index 9dc138eb8..d498b2e0d 100644 --- a/library/univops.ml +++ b/engine/univops.ml @@ -6,8 +6,8 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Constr open Univ +open Constr let universes_of_constr c = let rec aux s c = @@ -15,7 +15,7 @@ let universes_of_constr c = | Const (_, u) | Ind (_, u) | Construct (_, u) -> LSet.fold LSet.add (Instance.levels u) s | Sort u when not (Sorts.is_small u) -> - let u = Term.univ_of_sort u in + let u = Sorts.univ_of_sort u in LSet.fold LSet.add (Universe.levels u) s | _ -> Constr.fold aux s c in aux LSet.empty c diff --git a/library/univops.mli b/engine/univops.mli index 9af568bcb..9af568bcb 100644 --- a/library/univops.mli +++ b/engine/univops.mli diff --git a/ide/ide_slave.ml b/ide/ide_slave.ml index 7cbab56d4..cfc0e09a0 100644 --- a/ide/ide_slave.ml +++ b/ide/ide_slave.ml @@ -217,7 +217,7 @@ let evars () = let doc = get_doc () in set_doc @@ Stm.finish ~doc; let pfts = Proof_global.give_me_the_proof () in - let { Evd.it = all_goals ; sigma = sigma } = Proof.V82.subgoals pfts in + let all_goals, _, _, _, sigma = Proof.proof pfts in let exl = Evar.Map.bindings (Evd.undefined_map sigma) in let map_evar ev = { Interface.evar_info = string_of_ppcmds (pr_evar sigma ev); } in let el = List.map map_evar exl in @@ -227,7 +227,7 @@ let evars () = let hints () = try let pfts = Proof_global.give_me_the_proof () in - let { Evd.it = all_goals ; sigma = sigma } = Proof.V82.subgoals pfts in + let all_goals, _, _, _, sigma = Proof.proof pfts in match all_goals with | [] -> None | g :: _ -> diff --git a/interp/constrexpr_ops.ml b/interp/constrexpr_ops.ml index 771c13734..737e86848 100644 --- a/interp/constrexpr_ops.ml +++ b/interp/constrexpr_ops.ml @@ -9,6 +9,7 @@ open Pp open Util open Names +open Nameops open Libnames open Constrexpr open Misctypes @@ -72,22 +73,22 @@ let rec cases_pattern_expr_eq p1 p2 = Option.equal (List.equal cases_pattern_expr_eq) a1 a2 && List.equal cases_pattern_expr_eq b1 b2 | CPatAtom(r1), CPatAtom(r2) -> - Option.equal eq_reference r1 r2 + Option.equal eq_reference r1 r2 | CPatOr a1, CPatOr a2 -> - List.equal cases_pattern_expr_eq a1 a2 + List.equal cases_pattern_expr_eq a1 a2 | CPatNotation (n1, s1, l1), CPatNotation (n2, s2, l2) -> String.equal n1 n2 && cases_pattern_notation_substitution_eq s1 s2 && List.equal cases_pattern_expr_eq l1 l2 | CPatPrim i1, CPatPrim i2 -> - prim_token_eq i1 i2 + prim_token_eq i1 i2 | CPatRecord l1, CPatRecord l2 -> - let equal (r1, e1) (r2, e2) = - eq_reference r1 r2 && cases_pattern_expr_eq e1 e2 - in - List.equal equal l1 l2 + let equal (r1, e1) (r2, e2) = + eq_reference r1 r2 && cases_pattern_expr_eq e1 e2 + in + List.equal equal l1 l2 | CPatDelimiters(s1,e1), CPatDelimiters(s2,e2) -> - String.equal s1 s2 && cases_pattern_expr_eq e1 e2 + String.equal s1 s2 && cases_pattern_expr_eq e1 e2 | _ -> false and cases_pattern_notation_substitution_eq (s1, n1) (s2, n2) = @@ -103,79 +104,79 @@ let eq_universes u1 u2 = let rec constr_expr_eq e1 e2 = if CAst.(e1.v == e2.v) then true else match CAst.(e1.v, e2.v) with - | CRef (r1,u1), CRef (r2,u2) -> eq_reference r1 r2 && eq_universes u1 u2 - | CFix(id1,fl1), CFix(id2,fl2) -> + | CRef (r1,u1), CRef (r2,u2) -> eq_reference r1 r2 && eq_universes u1 u2 + | CFix(id1,fl1), CFix(id2,fl2) -> eq_located Id.equal id1 id2 && List.equal fix_expr_eq fl1 fl2 - | CCoFix(id1,fl1), CCoFix(id2,fl2) -> + | CCoFix(id1,fl1), CCoFix(id2,fl2) -> eq_located Id.equal id1 id2 && List.equal cofix_expr_eq fl1 fl2 - | CProdN(bl1,a1), CProdN(bl2,a2) -> + | CProdN(bl1,a1), CProdN(bl2,a2) -> List.equal binder_expr_eq bl1 bl2 && constr_expr_eq a1 a2 - | CLambdaN(bl1,a1), CLambdaN(bl2,a2) -> + | CLambdaN(bl1,a1), CLambdaN(bl2,a2) -> List.equal binder_expr_eq bl1 bl2 && constr_expr_eq a1 a2 - | CLetIn((_,na1),a1,t1,b1), CLetIn((_,na2),a2,t2,b2) -> + | CLetIn((_,na1),a1,t1,b1), CLetIn((_,na2),a2,t2,b2) -> Name.equal na1 na2 && constr_expr_eq a1 a2 && Option.equal constr_expr_eq t1 t2 && constr_expr_eq b1 b2 - | CAppExpl((proj1,r1,_),al1), CAppExpl((proj2,r2,_),al2) -> + | CAppExpl((proj1,r1,_),al1), CAppExpl((proj2,r2,_),al2) -> Option.equal Int.equal proj1 proj2 && eq_reference r1 r2 && List.equal constr_expr_eq al1 al2 - | CApp((proj1,e1),al1), CApp((proj2,e2),al2) -> + | CApp((proj1,e1),al1), CApp((proj2,e2),al2) -> Option.equal Int.equal proj1 proj2 && constr_expr_eq e1 e2 && List.equal args_eq al1 al2 - | CRecord l1, CRecord l2 -> - let field_eq (r1, e1) (r2, e2) = - eq_reference r1 r2 && constr_expr_eq e1 e2 - in - List.equal field_eq l1 l2 - | CCases(_,r1,a1,brl1), CCases(_,r2,a2,brl2) -> + | CRecord l1, CRecord l2 -> + let field_eq (r1, e1) (r2, e2) = + eq_reference r1 r2 && constr_expr_eq e1 e2 + in + List.equal field_eq l1 l2 + | CCases(_,r1,a1,brl1), CCases(_,r2,a2,brl2) -> (** Don't care about the case_style *) Option.equal constr_expr_eq r1 r2 && List.equal case_expr_eq a1 a2 && List.equal branch_expr_eq brl1 brl2 - | CLetTuple (n1, (m1, e1), t1, b1), CLetTuple (n2, (m2, e2), t2, b2) -> - List.equal (eq_located Name.equal) n1 n2 && - Option.equal (eq_located Name.equal) m1 m2 && - Option.equal constr_expr_eq e1 e2 && - constr_expr_eq t1 t2 && - constr_expr_eq b1 b2 - | CIf (e1, (n1, r1), t1, f1), CIf (e2, (n2, r2), t2, f2) -> - constr_expr_eq e1 e2 && - Option.equal (eq_located Name.equal) n1 n2 && - Option.equal constr_expr_eq r1 r2 && - constr_expr_eq t1 t2 && - constr_expr_eq f1 f2 - | CHole _, CHole _ -> true - | CPatVar i1, CPatVar i2 -> - Id.equal i1 i2 - | CEvar (id1, c1), CEvar (id2, c2) -> - Id.equal id1 id2 && List.equal instance_eq c1 c2 - | CSort s1, CSort s2 -> - Miscops.glob_sort_eq s1 s2 - | CCast(a1,(CastConv b1|CastVM b1)), CCast(a2,(CastConv b2|CastVM b2)) -> + | CLetTuple (n1, (m1, e1), t1, b1), CLetTuple (n2, (m2, e2), t2, b2) -> + List.equal (eq_located Name.equal) n1 n2 && + Option.equal (eq_located Name.equal) m1 m2 && + Option.equal constr_expr_eq e1 e2 && + constr_expr_eq t1 t2 && + constr_expr_eq b1 b2 + | CIf (e1, (n1, r1), t1, f1), CIf (e2, (n2, r2), t2, f2) -> + constr_expr_eq e1 e2 && + Option.equal (eq_located Name.equal) n1 n2 && + Option.equal constr_expr_eq r1 r2 && + constr_expr_eq t1 t2 && + constr_expr_eq f1 f2 + | CHole _, CHole _ -> true + | CPatVar i1, CPatVar i2 -> + Id.equal i1 i2 + | CEvar (id1, c1), CEvar (id2, c2) -> + Id.equal id1 id2 && List.equal instance_eq c1 c2 + | CSort s1, CSort s2 -> + Miscops.glob_sort_eq s1 s2 + | CCast(a1,(CastConv b1|CastVM b1)), CCast(a2,(CastConv b2|CastVM b2)) -> constr_expr_eq a1 a2 && constr_expr_eq b1 b2 - | CCast(a1,CastCoerce), CCast(a2, CastCoerce) -> + | CCast(a1,CastCoerce), CCast(a2, CastCoerce) -> constr_expr_eq a1 a2 - | CNotation(n1, s1), CNotation(n2, s2) -> + | CNotation(n1, s1), CNotation(n2, s2) -> String.equal n1 n2 && constr_notation_substitution_eq s1 s2 - | CPrim i1, CPrim i2 -> - prim_token_eq i1 i2 - | CGeneralization (bk1, ak1, e1), CGeneralization (bk2, ak2, e2) -> - binding_kind_eq bk1 bk2 && - Option.equal abstraction_kind_eq ak1 ak2 && - constr_expr_eq e1 e2 - | CDelimiters(s1,e1), CDelimiters(s2,e2) -> - String.equal s1 s2 && - constr_expr_eq e1 e2 - | _ -> false + | CPrim i1, CPrim i2 -> + prim_token_eq i1 i2 + | CGeneralization (bk1, ak1, e1), CGeneralization (bk2, ak2, e2) -> + binding_kind_eq bk1 bk2 && + Option.equal abstraction_kind_eq ak1 ak2 && + constr_expr_eq e1 e2 + | CDelimiters(s1,e1), CDelimiters(s2,e2) -> + String.equal s1 s2 && + constr_expr_eq e1 e2 + | _ -> false and args_eq (a1,e1) (a2,e2) = Option.equal (eq_located explicitation_eq) e1 e2 && @@ -209,19 +210,19 @@ and cofix_expr_eq (id1,bl1,a1,b1) (id2,bl2,a2,b2) = constr_expr_eq b1 b2 and recursion_order_expr_eq r1 r2 = match r1, r2 with -| CStructRec, CStructRec -> true -| CWfRec e1, CWfRec e2 -> constr_expr_eq e1 e2 -| CMeasureRec (e1, o1), CMeasureRec (e2, o2) -> - constr_expr_eq e1 e2 && Option.equal constr_expr_eq o1 o2 -| _ -> false + | CStructRec, CStructRec -> true + | CWfRec e1, CWfRec e2 -> constr_expr_eq e1 e2 + | CMeasureRec (e1, o1), CMeasureRec (e2, o2) -> + constr_expr_eq e1 e2 && Option.equal constr_expr_eq o1 o2 + | _ -> false and local_binder_eq l1 l2 = match l1, l2 with -| CLocalDef (n1, e1, t1), CLocalDef (n2, e2, t2) -> - eq_located Name.equal n1 n2 && constr_expr_eq e1 e2 && Option.equal constr_expr_eq t1 t2 -| CLocalAssum (n1, _, e1), CLocalAssum (n2, _, e2) -> - (** Don't care about the [binder_kind] *) - List.equal (eq_located Name.equal) n1 n2 && constr_expr_eq e1 e2 -| _ -> false + | CLocalDef (n1, e1, t1), CLocalDef (n2, e2, t2) -> + eq_located Name.equal n1 n2 && constr_expr_eq e1 e2 && Option.equal constr_expr_eq t1 t2 + | CLocalAssum (n1, _, e1), CLocalAssum (n2, _, e2) -> + (** Don't care about the [binder_kind] *) + List.equal (eq_located Name.equal) n1 n2 && constr_expr_eq e1 e2 + | _ -> false and constr_notation_substitution_eq (e1, el1, bl1) (e2, el2, bl2) = List.equal constr_expr_eq e1 e2 && @@ -245,6 +246,270 @@ let local_binders_loc bll = match bll with | [] -> None | h :: l -> Loc.merge_opt (local_binder_loc h) (local_binder_loc (List.last bll)) +(** Folds and maps *) + +(* Legacy functions *) +let down_located f (_l, x) = f x +let located_fold_left f x (_l, y) = f x y + +let is_constructor id = + try Globnames.isConstructRef + (Smartlocate.global_of_extended_global + (Nametab.locate_extended (qualid_of_ident id))) + with Not_found -> false + +let rec cases_pattern_fold_names f a pt = match CAst.(pt.v) with + | CPatRecord l -> + List.fold_left (fun acc (r, cp) -> cases_pattern_fold_names f acc cp) a l + | CPatAlias (pat,id) -> f id a + | CPatOr (patl) -> + List.fold_left (cases_pattern_fold_names f) a patl + | CPatCstr (_,patl1,patl2) -> + List.fold_left (cases_pattern_fold_names f) + (Option.fold_left (List.fold_left (cases_pattern_fold_names f)) a patl1) patl2 + | CPatNotation (_,(patl,patll),patl') -> + List.fold_left (cases_pattern_fold_names f) + (List.fold_left (cases_pattern_fold_names f) a (patl@List.flatten patll)) patl' + | CPatDelimiters (_,pat) -> cases_pattern_fold_names f a pat + | CPatAtom (Some (Ident (_,id))) when not (is_constructor id) -> f id a + | CPatPrim _ | CPatAtom _ -> a + | CPatCast ({CAst.loc},_) -> + CErrors.user_err ?loc ~hdr:"cases_pattern_fold_names" + (Pp.strbrk "Casts are not supported here.") + +let ids_of_pattern = + cases_pattern_fold_names Id.Set.add Id.Set.empty + +let ids_of_pattern_list = + List.fold_left + (located_fold_left + (List.fold_left (cases_pattern_fold_names Id.Set.add))) + Id.Set.empty + +let ids_of_cases_indtype p = + cases_pattern_fold_names Id.Set.add Id.Set.empty p + +let ids_of_cases_tomatch tms = + List.fold_right + (fun (_, ona, indnal) l -> + Option.fold_right (fun t ids -> cases_pattern_fold_names Id.Set.add ids t) + indnal + (Option.fold_right (down_located (Name.fold_right Id.Set.add)) ona l)) + tms Id.Set.empty + +let rec fold_constr_expr_binders g f n acc b = function + | (nal,bk,t)::l -> + let nal = snd (List.split nal) in + let n' = List.fold_right (Name.fold_right g) nal n in + f n (fold_constr_expr_binders g f n' acc b l) t + | [] -> + f n acc b + +let rec fold_local_binders g f n acc b = function + | CLocalAssum (nal,bk,t)::l -> + let nal = snd (List.split nal) in + let n' = List.fold_right (Name.fold_right g) nal n in + f n (fold_local_binders g f n' acc b l) t + | CLocalDef ((_,na),c,t)::l -> + Option.fold_left (f n) (f n (fold_local_binders g f (Name.fold_right g na n) acc b l) c) t + | CLocalPattern (_,(pat,t))::l -> + let acc = fold_local_binders g f (cases_pattern_fold_names g n pat) acc b l in + Option.fold_left (f n) acc t + | [] -> + f n acc b + +let fold_constr_expr_with_binders g f n acc = CAst.with_val (function + | CAppExpl ((_,_,_),l) -> List.fold_left (f n) acc l + | CApp ((_,t),l) -> List.fold_left (f n) (f n acc t) (List.map fst l) + | CProdN (l,b) | CLambdaN (l,b) -> fold_constr_expr_binders g f n acc b l + | CLetIn (na,a,t,b) -> + f (Name.fold_right g (snd na) n) (Option.fold_left (f n) (f n acc a) t) b + | CCast (a,(CastConv b|CastVM b|CastNative b)) -> f n (f n acc a) b + | CCast (a,CastCoerce) -> f n acc a + | CNotation (_,(l,ll,bll)) -> + (* The following is an approximation: we don't know exactly if + an ident is binding nor to which subterms bindings apply *) + let acc = List.fold_left (f n) acc (l@List.flatten ll) in + List.fold_left (fun acc bl -> fold_local_binders g f n acc (CAst.make @@ CHole (None,IntroAnonymous,None)) bl) acc bll + | CGeneralization (_,_,c) -> f n acc c + | CDelimiters (_,a) -> f n acc a + | CHole _ | CEvar _ | CPatVar _ | CSort _ | CPrim _ | CRef _ -> + acc + | CRecord l -> List.fold_left (fun acc (id, c) -> f n acc c) acc l + | CCases (sty,rtnpo,al,bl) -> + let ids = ids_of_cases_tomatch al in + let acc = Option.fold_left (f (Id.Set.fold g ids n)) acc rtnpo in + let acc = List.fold_left (f n) acc (List.map (fun (fst,_,_) -> fst) al) in + List.fold_right (fun (loc,(patl,rhs)) acc -> + let ids = ids_of_pattern_list patl in + f (Id.Set.fold g ids n) acc rhs) bl acc + | CLetTuple (nal,(ona,po),b,c) -> + let n' = List.fold_right (down_located (Name.fold_right g)) nal n in + f (Option.fold_right (down_located (Name.fold_right g)) ona n') (f n acc b) c + | CIf (c,(ona,po),b1,b2) -> + let acc = f n (f n (f n acc b1) b2) c in + Option.fold_left + (f (Option.fold_right (down_located (Name.fold_right g)) ona n)) acc po + | CFix (_,l) -> + let n' = List.fold_right (fun ((_,id),_,_,_,_) -> g id) l n in + List.fold_right (fun (_,(_,o),lb,t,c) acc -> + fold_local_binders g f n' + (fold_local_binders g f n acc t lb) c lb) l acc + | CCoFix (_,_) -> + Feedback.msg_warning (strbrk "Capture check in multiple binders not done"); acc + ) + +let free_vars_of_constr_expr c = + let rec aux bdvars l = function + | { CAst.v = CRef (Ident (_,id),_) } -> if Id.List.mem id bdvars then l else Id.Set.add id l + | c -> fold_constr_expr_with_binders (fun a l -> a::l) aux bdvars l c + in aux [] Id.Set.empty c + +let occur_var_constr_expr id c = Id.Set.mem id (free_vars_of_constr_expr c) + +(* Used in correctness and interface *) +let map_binder g e nal = List.fold_right (down_located (Name.fold_right g)) nal e + +let map_binders f g e bl = + (* TODO: avoid variable capture in [t] by some [na] in [List.tl nal] *) + let h (e,bl) (nal,bk,t) = (map_binder g e nal,(nal,bk,f e t)::bl) in + let (e,rbl) = List.fold_left h (e,[]) bl in + (e, List.rev rbl) + +let map_local_binders f g e bl = + (* TODO: avoid variable capture in [t] by some [na] in [List.tl nal] *) + let h (e,bl) = function + CLocalAssum(nal,k,ty) -> + (map_binder g e nal, CLocalAssum(nal,k,f e ty)::bl) + | CLocalDef((loc,na),c,ty) -> + (Name.fold_right g na e, CLocalDef((loc,na),f e c,Option.map (f e) ty)::bl) + | CLocalPattern (loc,(pat,t)) -> + let ids = ids_of_pattern pat in + (Id.Set.fold g ids e, CLocalPattern (loc,(pat,Option.map (f e) t))::bl) in + let (e,rbl) = List.fold_left h (e,[]) bl in + (e, List.rev rbl) + +let map_constr_expr_with_binders g f e = CAst.map (function + | CAppExpl (r,l) -> CAppExpl (r,List.map (f e) l) + | CApp ((p,a),l) -> + CApp ((p,f e a),List.map (fun (a,i) -> (f e a,i)) l) + | CProdN (bl,b) -> + let (e,bl) = map_binders f g e bl in CProdN (bl,f e b) + | CLambdaN (bl,b) -> + let (e,bl) = map_binders f g e bl in CLambdaN (bl,f e b) + | CLetIn (na,a,t,b) -> + CLetIn (na,f e a,Option.map (f e) t,f (Name.fold_right g (snd na) e) b) + | CCast (a,c) -> CCast (f e a, Miscops.map_cast_type (f e) c) + | CNotation (n,(l,ll,bll)) -> + (* This is an approximation because we don't know what binds what *) + CNotation (n,(List.map (f e) l,List.map (List.map (f e)) ll, + List.map (fun bl -> snd (map_local_binders f g e bl)) bll)) + | CGeneralization (b,a,c) -> CGeneralization (b,a,f e c) + | CDelimiters (s,a) -> CDelimiters (s,f e a) + | CHole _ | CEvar _ | CPatVar _ | CSort _ + | CPrim _ | CRef _ as x -> x + | CRecord l -> CRecord (List.map (fun (id, c) -> (id, f e c)) l) + | CCases (sty,rtnpo,a,bl) -> + let bl = List.map (fun (loc,(patl,rhs)) -> + let ids = ids_of_pattern_list patl in + (loc,(patl,f (Id.Set.fold g ids e) rhs))) bl in + let ids = ids_of_cases_tomatch a in + let po = Option.map (f (Id.Set.fold g ids e)) rtnpo in + CCases (sty, po, List.map (fun (tm,x,y) -> f e tm,x,y) a,bl) + | CLetTuple (nal,(ona,po),b,c) -> + let e' = List.fold_right (down_located (Name.fold_right g)) nal e in + let e'' = Option.fold_right (down_located (Name.fold_right g)) ona e in + CLetTuple (nal,(ona,Option.map (f e'') po),f e b,f e' c) + | CIf (c,(ona,po),b1,b2) -> + let e' = Option.fold_right (down_located (Name.fold_right g)) ona e in + CIf (f e c,(ona,Option.map (f e') po),f e b1,f e b2) + | CFix (id,dl) -> + CFix (id,List.map (fun (id,n,bl,t,d) -> + let (e',bl') = map_local_binders f g e bl in + let t' = f e' t in + (* Note: fix names should be inserted before the arguments... *) + let e'' = List.fold_left (fun e ((_,id),_,_,_,_) -> g id e) e' dl in + let d' = f e'' d in + (id,n,bl',t',d')) dl) + | CCoFix (id,dl) -> + CCoFix (id,List.map (fun (id,bl,t,d) -> + let (e',bl') = map_local_binders f g e bl in + let t' = f e' t in + let e'' = List.fold_left (fun e ((_,id),_,_,_) -> g id e) e' dl in + let d' = f e'' d in + (id,bl',t',d')) dl) + ) + +(* Used in constrintern *) +let rec replace_vars_constr_expr l = function + | { CAst.loc; v = CRef (Ident (loc_id,id),us) } as x -> + (try CAst.make ?loc @@ CRef (Ident (loc_id,Id.Map.find id l),us) with Not_found -> x) + | c -> map_constr_expr_with_binders Id.Map.remove + replace_vars_constr_expr l c + +(* Returns the ranges of locs of the notation that are not occupied by args *) +(* and which are then occupied by proper symbols of the notation (or spaces) *) + +let locs_of_notation ?loc locs ntn = + let unloc loc = Option.cata Loc.unloc (0,0) loc in + let (bl, el) = unloc loc in + let locs = List.map unloc locs in + let rec aux pos = function + | [] -> if Int.equal pos el then [] else [(pos,el)] + | (ba,ea)::l -> if Int.equal pos ba then aux ea l else (pos,ba)::aux ea l + in aux bl (List.sort (fun l1 l2 -> fst l1 - fst l2) locs) + +let ntn_loc ?loc (args,argslist,binderslist) = + locs_of_notation ?loc + (List.map constr_loc (args@List.flatten argslist)@ + List.map local_binders_loc binderslist) + +let patntn_loc ?loc (args,argslist) = + locs_of_notation ?loc + (List.map cases_pattern_expr_loc (args@List.flatten argslist)) + +let error_invalid_pattern_notation ?loc () = + CErrors.user_err ?loc (str "Invalid notation for pattern.") + +(* Interpret the index of a recursion order annotation *) +let split_at_annot bl na = + let names = List.map snd (names_of_local_assums bl) in + match na with + | None -> + begin match names with + | [] -> CErrors.user_err (Pp.str "A fixpoint needs at least one parameter.") + | _ -> ([], bl) + end + | Some (loc, id) -> + let rec aux acc = function + | CLocalAssum (bls, k, t) as x :: rest -> + let test (_, na) = match na with + | Name id' -> Id.equal id id' + | Anonymous -> false + in + let l, r = List.split_when test bls in + begin match r with + | [] -> aux (x :: acc) rest + | _ -> + let ans = match l with + | [] -> acc + | _ -> CLocalAssum (l, k, t) :: acc + in + (List.rev ans, CLocalAssum (r, k, t) :: rest) + end + | CLocalDef ((_,na),_,_) as x :: rest -> + if Name.equal (Name id) na then + CErrors.user_err ?loc + (Id.print id ++ str" must be a proper parameter and not a local definition.") + else + aux (x :: acc) rest + | CLocalPattern (_,_) :: rest -> + Loc.raise ?loc (Stream.Error "pattern with quote not allowed after fix") + | [] -> + CErrors.user_err ?loc + (str "No parameter named " ++ Id.print id ++ str".") + in aux [] bl + (** Pseudo-constructors *) let mkIdentC id = CAst.make @@ CRef (Ident (Loc.tag id),None) @@ -265,38 +530,40 @@ let add_name_in_env env n = | Anonymous -> env | Name id -> id :: env -let (fresh_var, fresh_var_hook) = Hook.make ~default:(fun _ _ -> assert false) () +let fresh_var env c = + Namegen.next_ident_away (Id.of_string "pat") + (List.fold_left (fun accu id -> Id.Set.add id accu) (free_vars_of_constr_expr c) env) let expand_binders ?loc mkC bl c = let rec loop ?loc bl c = match bl with | [] -> ([], c) | b :: bl -> - match b with - | CLocalDef ((loc1,_) as n, oty, b) -> - let env, c = loop ?loc:(Loc.merge_opt loc1 loc) bl c in - let env = add_name_in_env env n in - (env, CAst.make ?loc @@ CLetIn (n,oty,b,c)) - | CLocalAssum ((loc1,_)::_ as nl, bk, t) -> - let env, c = loop ?loc:(Loc.merge_opt loc1 loc) bl c in - let env = List.fold_left add_name_in_env env nl in - (env, mkC ?loc (nl,bk,t) c) - | CLocalAssum ([],_,_) -> loop ?loc bl c - | CLocalPattern (loc1, (p, ty)) -> - let env, c = loop ?loc:(Loc.merge_opt loc1 loc) bl c in - let ni = Hook.get fresh_var env c in - let id = (loc1, Name ni) in - let ty = match ty with - | Some ty -> ty - | None -> CAst.make ?loc:loc1 @@ CHole (None, IntroAnonymous, None) - in - let e = CAst.make @@ CRef (Libnames.Ident (loc1, ni), None) in - let c = CAst.make ?loc @@ - CCases - (LetPatternStyle, None, [(e,None,None)], - [(Loc.tag ?loc:loc1 ([(loc1,[p])], c))]) - in - (ni :: env, mkC ?loc ([id],Default Explicit,ty) c) + match b with + | CLocalDef ((loc1,_) as n, oty, b) -> + let env, c = loop ?loc:(Loc.merge_opt loc1 loc) bl c in + let env = add_name_in_env env n in + (env, CAst.make ?loc @@ CLetIn (n,oty,b,c)) + | CLocalAssum ((loc1,_)::_ as nl, bk, t) -> + let env, c = loop ?loc:(Loc.merge_opt loc1 loc) bl c in + let env = List.fold_left add_name_in_env env nl in + (env, mkC ?loc (nl,bk,t) c) + | CLocalAssum ([],_,_) -> loop ?loc bl c + | CLocalPattern (loc1, (p, ty)) -> + let env, c = loop ?loc:(Loc.merge_opt loc1 loc) bl c in + let ni = fresh_var env c in + let id = (loc1, Name ni) in + let ty = match ty with + | Some ty -> ty + | None -> CAst.make ?loc:loc1 @@ CHole (None, IntroAnonymous, None) + in + let e = CAst.make @@ CRef (Libnames.Ident (loc1, ni), None) in + let c = CAst.make ?loc @@ + CCases + (LetPatternStyle, None, [(e,None,None)], + [(Loc.tag ?loc:loc1 ([(loc1,[p])], c))]) + in + (ni :: env, mkC ?loc ([id],Default Explicit,ty) c) in let (_, c) = loop ?loc bl c in c @@ -309,24 +576,34 @@ let mkCLambdaN ?loc bll c = let mk ?loc b c = CAst.make ?loc @@ CLambdaN ([b],c) in expand_binders ?loc mk bll c -(* Deprecated *) -let abstract_constr_expr c bl = mkCLambdaN ?loc:(local_binders_loc bl) bl c -let prod_constr_expr c bl = mkCProdN ?loc:(local_binders_loc bl) bl c - let coerce_reference_to_id = function | Ident (_,id) -> id | Qualid (loc,_) -> - CErrors.user_err ?loc ~hdr:"coerce_reference_to_id" - (str "This expression should be a simple identifier.") + CErrors.user_err ?loc ~hdr:"coerce_reference_to_id" + (str "This expression should be a simple identifier.") let coerce_to_id = function | { CAst.v = CRef (Ident (loc,id),None) } -> (loc,id) | { CAst.loc; _ } -> CErrors.user_err ?loc - ~hdr:"coerce_to_id" - (str "This expression should be a simple identifier.") + ~hdr:"coerce_to_id" + (str "This expression should be a simple identifier.") let coerce_to_name = function | { CAst.v = CRef (Ident (loc,id),None) } -> (loc,Name id) | { CAst.loc; CAst.v = CHole (None,Misctypes.IntroAnonymous,None) } -> (loc,Anonymous) | { CAst.loc; _ } -> CErrors.user_err ?loc ~hdr:"coerce_to_name" (str "This expression should be a name.") + +let asymmetric_patterns = ref (false) +let _ = Goptions.declare_bool_option { + Goptions.optdepr = false; + Goptions.optname = "no parameters in constructors"; + Goptions.optkey = ["Asymmetric";"Patterns"]; + Goptions.optread = (fun () -> !asymmetric_patterns); + Goptions.optwrite = (fun a -> asymmetric_patterns:=a); +} + +(************************************************************************) +(* Deprecated *) +let abstract_constr_expr c bl = mkCLambdaN ?loc:(local_binders_loc bl) bl c +let prod_constr_expr c bl = mkCProdN ?loc:(local_binders_loc bl) bl c diff --git a/interp/constrexpr_ops.mli b/interp/constrexpr_ops.mli index 7bd275e51..3ecb3d321 100644 --- a/interp/constrexpr_ops.mli +++ b/interp/constrexpr_ops.mli @@ -56,11 +56,11 @@ val mkCProdN : ?loc:Loc.t -> local_binder_expr list -> constr_expr -> constr_exp (** @deprecated variant of mkCLambdaN *) val abstract_constr_expr : constr_expr -> local_binder_expr list -> constr_expr +[@@ocaml.deprecated "deprecated variant of mkCLambdaN"] (** @deprecated variant of mkCProdN *) val prod_constr_expr : constr_expr -> local_binder_expr list -> constr_expr - -val fresh_var_hook : (Names.Id.t list -> Constrexpr.constr_expr -> Names.Id.t) Hook.t +[@@ocaml.deprecated "deprecated variant of mkCProdN"] (** {6 Destructors}*) @@ -83,3 +83,36 @@ val names_of_local_binders : local_binder_expr list -> Name.t located list val names_of_local_assums : local_binder_expr list -> Name.t located list (** Same as [names_of_local_binder_exprs], but does not take the [let] bindings into account. *) + +(** { 6 Folds and maps } *) + +(** Used in typeclasses *) +val fold_constr_expr_with_binders : (Id.t -> 'a -> 'a) -> + ('a -> 'b -> constr_expr -> 'b) -> 'a -> 'b -> constr_expr -> 'b + +(** Used in correctness and interface; absence of var capture not guaranteed + in pattern-matching clauses and in binders of the form [x,y:T(x)] *) + +val map_constr_expr_with_binders : + (Id.t -> 'a -> 'a) -> ('a -> constr_expr -> constr_expr) -> + 'a -> constr_expr -> constr_expr + +val replace_vars_constr_expr : + Id.t Id.Map.t -> constr_expr -> constr_expr + +(** Specific function for interning "in indtype" syntax of "match" *) +val ids_of_cases_indtype : cases_pattern_expr -> Id.Set.t + +val free_vars_of_constr_expr : constr_expr -> Id.Set.t +val occur_var_constr_expr : Id.t -> constr_expr -> bool + +val split_at_annot : local_binder_expr list -> Id.t located option -> local_binder_expr list * local_binder_expr list + +val ntn_loc : ?loc:Loc.t -> constr_notation_substitution -> string -> (int * int) list +val patntn_loc : ?loc:Loc.t -> cases_pattern_notation_substitution -> string -> (int * int) list + +(** For cases pattern parsing errors *) +val error_invalid_pattern_notation : ?loc:Loc.t -> unit -> 'a + +(** Placeholder for global option, should be moved to a parameter *) +val asymmetric_patterns : bool ref diff --git a/interp/constrextern.ml b/interp/constrextern.ml index 0ce672cc8..e1df24f71 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -21,7 +21,6 @@ open CAst open Constrexpr open Constrexpr_ops open Notation_ops -open Topconstr open Glob_term open Glob_ops open Pattern @@ -414,7 +413,7 @@ let rec extern_cases_pattern_in_scope (scopes:local_scopes) vars pat = with Not_found | No_match | Exit -> let c = extern_reference ?loc Id.Set.empty (ConstructRef cstrsp) in - if !Topconstr.asymmetric_patterns then + if !asymmetric_patterns then if pattern_printable_in_both_syntax cstrsp then CPatCstr (c, None, args) else CPatCstr (c, Some (add_patt_for_params (fst cstrsp) args), []) @@ -446,7 +445,7 @@ and apply_notation_to_pattern ?loc gr ((subst,substlist),(nb_to_drop,more_args)) List.map (extern_cases_pattern_in_scope subscope vars) c) substlist in let l2 = List.map (extern_cases_pattern_in_scope allscopes vars) more_args in - let l2' = if !Topconstr.asymmetric_patterns || not (List.is_empty ll) then l2 + let l2' = if !asymmetric_patterns || not (List.is_empty ll) then l2 else match drop_implicits_in_patt gr nb_to_drop l2 with |Some true_args -> true_args @@ -462,7 +461,7 @@ and apply_notation_to_pattern ?loc gr ((subst,substlist),(nb_to_drop,more_args)) extern_cases_pattern_in_scope (scopt,scl@scopes) vars c) subst in let l2 = List.map (extern_cases_pattern_in_scope allscopes vars) more_args in - let l2' = if !Topconstr.asymmetric_patterns then l2 + let l2' = if !asymmetric_patterns then l2 else match drop_implicits_in_patt gr (nb_to_drop + List.length l1) l2 with |Some true_args -> true_args diff --git a/interp/constrextern.mli b/interp/constrextern.mli index d980b1995..51b06580e 100644 --- a/interp/constrextern.mli +++ b/interp/constrextern.mli @@ -60,6 +60,19 @@ val set_extern_reference : val get_extern_reference : unit -> (?loc:Loc.t -> Id.Set.t -> global_reference -> reference) +(** WARNING: The following functions are evil due to + side-effects. Think of the following case as used in the printer: + + without_specific_symbols [SynDefRule kn] (pr_glob_constr_env env) c + + vs + + without_specific_symbols [SynDefRule kn] pr_glob_constr_env env c + + which one is wrong? We should turn this kind of state into an + explicit argument. +*) + (** This forces printing universe names of Type\{.\} *) val with_universes : ('a -> 'b) -> 'a -> 'b diff --git a/interp/constrintern.ml b/interp/constrintern.ml index dee415f8f..977146b2f 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -24,7 +24,6 @@ open Constrexpr open Constrexpr_ops open Notation_term open Notation_ops -open Topconstr open Nametab open Notation open Inductiveops diff --git a/interp/impargs.ml b/interp/impargs.ml index f70154e61..3105214d5 100644 --- a/interp/impargs.ml +++ b/interp/impargs.ml @@ -10,7 +10,6 @@ open CErrors open Util open Names open Globnames -open Term open Constr open Reduction open Declarations diff --git a/interp/implicit_quantifiers.ml b/interp/implicit_quantifiers.ml index a5302b54d..519f2480b 100644 --- a/interp/implicit_quantifiers.ml +++ b/interp/implicit_quantifiers.ml @@ -94,8 +94,8 @@ let free_vars_of_constr_expr c ?(bound=Id.Set.empty) l = let rec aux bdvars l c = match CAst.(c.v) with | CRef (Ident (loc,id),_) -> found loc id bdvars l | CNotation ("{ _ : _ | _ }", ({ CAst.v = CRef (Ident (_, id),_) } :: _, [], [])) when not (Id.Set.mem id bdvars) -> - Topconstr.fold_constr_expr_with_binders (fun a l -> Id.Set.add a l) aux (Id.Set.add id bdvars) l c - | _ -> Topconstr.fold_constr_expr_with_binders (fun a l -> Id.Set.add a l) aux bdvars l c + Constrexpr_ops.fold_constr_expr_with_binders (fun a l -> Id.Set.add a l) aux (Id.Set.add id bdvars) l c + | _ -> Constrexpr_ops.fold_constr_expr_with_binders (fun a l -> Id.Set.add a l) aux bdvars l c in aux bound l c let ids_of_names l = diff --git a/interp/interp.mllib b/interp/interp.mllib index e3500cfea..bb22cf468 100644 --- a/interp/interp.mllib +++ b/interp/interp.mllib @@ -1,13 +1,13 @@ Tactypes Stdarg Genintern -Constrexpr_ops Notation_ops -Ppextend Notation -Dumpglob Syntax_def Smartlocate +Constrexpr_ops +Ppextend +Dumpglob Topconstr Reserve Impargs diff --git a/interp/reserve.ml b/interp/reserve.ml index 6fd1d0b58..22c5a2f5e 100644 --- a/interp/reserve.ml +++ b/interp/reserve.ml @@ -102,7 +102,7 @@ let declare_reserved_type idl t = let find_reserved_type id = Id.Map.find (root_of_id id) !reserve_table let constr_key c = - try RefKey (canonical_gr (global_of_constr (fst (Term.decompose_app c)))) + try RefKey (canonical_gr (global_of_constr (fst (Constr.decompose_app c)))) with Not_found -> Oth let revert_reserved_type t = diff --git a/interp/topconstr.ml b/interp/topconstr.ml index c64d3aa26..ecfb766ff 100644 --- a/interp/topconstr.ml +++ b/interp/topconstr.ml @@ -6,294 +6,16 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i*) -open Pp -open CErrors -open Util -open Names -open Nameops -open Libnames -open Misctypes -open Constrexpr open Constrexpr_ops -(*i*) - -let asymmetric_patterns = ref (false) -let _ = Goptions.declare_bool_option { - Goptions.optdepr = false; - Goptions.optname = "no parameters in constructors"; - Goptions.optkey = ["Asymmetric";"Patterns"]; - Goptions.optread = (fun () -> !asymmetric_patterns); - Goptions.optwrite = (fun a -> asymmetric_patterns:=a); -} - -(**********************************************************************) -(* Miscellaneous *) - -let error_invalid_pattern_notation ?loc () = - user_err ?loc (str "Invalid notation for pattern.") - -(* Legacy functions *) -let down_located f (_l, x) = f x -let located_fold_left f x (_l, y) = f x y - -(**********************************************************************) -(* Functions on constr_expr *) - -let is_constructor id = - try Globnames.isConstructRef - (Smartlocate.global_of_extended_global - (Nametab.locate_extended (qualid_of_ident id))) - with Not_found -> false - -let rec cases_pattern_fold_names f a pt = match CAst.(pt.v) with - | CPatRecord l -> - List.fold_left (fun acc (r, cp) -> cases_pattern_fold_names f acc cp) a l - | CPatAlias (pat,id) -> f id a - | CPatOr (patl) -> - List.fold_left (cases_pattern_fold_names f) a patl - | CPatCstr (_,patl1,patl2) -> - List.fold_left (cases_pattern_fold_names f) - (Option.fold_left (List.fold_left (cases_pattern_fold_names f)) a patl1) patl2 - | CPatNotation (_,(patl,patll),patl') -> - List.fold_left (cases_pattern_fold_names f) - (List.fold_left (cases_pattern_fold_names f) a (patl@List.flatten patll)) patl' - | CPatDelimiters (_,pat) -> cases_pattern_fold_names f a pat - | CPatAtom (Some (Ident (_,id))) when not (is_constructor id) -> f id a - | CPatPrim _ | CPatAtom _ -> a - | CPatCast ({CAst.loc},_) -> - CErrors.user_err ?loc ~hdr:"cases_pattern_fold_names" - (Pp.strbrk "Casts are not supported here.") - -let ids_of_pattern = - cases_pattern_fold_names Id.Set.add Id.Set.empty - -let ids_of_pattern_list = - List.fold_left - (located_fold_left - (List.fold_left (cases_pattern_fold_names Id.Set.add))) - Id.Set.empty - -let ids_of_cases_indtype p = - cases_pattern_fold_names Id.Set.add Id.Set.empty p - -let ids_of_cases_tomatch tms = - List.fold_right - (fun (_, ona, indnal) l -> - Option.fold_right (fun t ids -> cases_pattern_fold_names Id.Set.add ids t) - indnal - (Option.fold_right (down_located (Name.fold_right Id.Set.add)) ona l)) - tms Id.Set.empty - -let rec fold_constr_expr_binders g f n acc b = function - | (nal,bk,t)::l -> - let nal = snd (List.split nal) in - let n' = List.fold_right (Name.fold_right g) nal n in - f n (fold_constr_expr_binders g f n' acc b l) t - | [] -> - f n acc b - -let rec fold_local_binders g f n acc b = function - | CLocalAssum (nal,bk,t)::l -> - let nal = snd (List.split nal) in - let n' = List.fold_right (Name.fold_right g) nal n in - f n (fold_local_binders g f n' acc b l) t - | CLocalDef ((_,na),c,t)::l -> - Option.fold_left (f n) (f n (fold_local_binders g f (Name.fold_right g na n) acc b l) c) t - | CLocalPattern (_,(pat,t))::l -> - let acc = fold_local_binders g f (cases_pattern_fold_names g n pat) acc b l in - Option.fold_left (f n) acc t - | [] -> - f n acc b - -let fold_constr_expr_with_binders g f n acc = CAst.with_val (function - | CAppExpl ((_,_,_),l) -> List.fold_left (f n) acc l - | CApp ((_,t),l) -> List.fold_left (f n) (f n acc t) (List.map fst l) - | CProdN (l,b) | CLambdaN (l,b) -> fold_constr_expr_binders g f n acc b l - | CLetIn (na,a,t,b) -> - f (Name.fold_right g (snd na) n) (Option.fold_left (f n) (f n acc a) t) b - | CCast (a,(CastConv b|CastVM b|CastNative b)) -> f n (f n acc a) b - | CCast (a,CastCoerce) -> f n acc a - | CNotation (_,(l,ll,bll)) -> - (* The following is an approximation: we don't know exactly if - an ident is binding nor to which subterms bindings apply *) - let acc = List.fold_left (f n) acc (l@List.flatten ll) in - List.fold_left (fun acc bl -> fold_local_binders g f n acc (CAst.make @@ CHole (None,IntroAnonymous,None)) bl) acc bll - | CGeneralization (_,_,c) -> f n acc c - | CDelimiters (_,a) -> f n acc a - | CHole _ | CEvar _ | CPatVar _ | CSort _ | CPrim _ | CRef _ -> - acc - | CRecord l -> List.fold_left (fun acc (id, c) -> f n acc c) acc l - | CCases (sty,rtnpo,al,bl) -> - let ids = ids_of_cases_tomatch al in - let acc = Option.fold_left (f (Id.Set.fold g ids n)) acc rtnpo in - let acc = List.fold_left (f n) acc (List.map (fun (fst,_,_) -> fst) al) in - List.fold_right (fun (loc,(patl,rhs)) acc -> - let ids = ids_of_pattern_list patl in - f (Id.Set.fold g ids n) acc rhs) bl acc - | CLetTuple (nal,(ona,po),b,c) -> - let n' = List.fold_right (down_located (Name.fold_right g)) nal n in - f (Option.fold_right (down_located (Name.fold_right g)) ona n') (f n acc b) c - | CIf (c,(ona,po),b1,b2) -> - let acc = f n (f n (f n acc b1) b2) c in - Option.fold_left - (f (Option.fold_right (down_located (Name.fold_right g)) ona n)) acc po - | CFix (_,l) -> - let n' = List.fold_right (fun ((_,id),_,_,_,_) -> g id) l n in - List.fold_right (fun (_,(_,o),lb,t,c) acc -> - fold_local_binders g f n' - (fold_local_binders g f n acc t lb) c lb) l acc - | CCoFix (_,_) -> - Feedback.msg_warning (strbrk "Capture check in multiple binders not done"); acc - ) - -let free_vars_of_constr_expr c = - let rec aux bdvars l = function - | { CAst.v = CRef (Ident (_,id),_) } -> if Id.List.mem id bdvars then l else Id.Set.add id l - | c -> fold_constr_expr_with_binders (fun a l -> a::l) aux bdvars l c - in aux [] Id.Set.empty c - -let occur_var_constr_expr id c = Id.Set.mem id (free_vars_of_constr_expr c) - -(* Interpret the index of a recursion order annotation *) - -let split_at_annot bl na = - let names = List.map snd (names_of_local_assums bl) in - match na with - | None -> - begin match names with - | [] -> user_err (Pp.str "A fixpoint needs at least one parameter.") - | _ -> ([], bl) - end - | Some (loc, id) -> - let rec aux acc = function - | CLocalAssum (bls, k, t) as x :: rest -> - let test (_, na) = match na with - | Name id' -> Id.equal id id' - | Anonymous -> false - in - let l, r = List.split_when test bls in - begin match r with - | [] -> aux (x :: acc) rest - | _ -> - let ans = match l with - | [] -> acc - | _ -> CLocalAssum (l, k, t) :: acc - in - (List.rev ans, CLocalAssum (r, k, t) :: rest) - end - | CLocalDef ((_,na),_,_) as x :: rest -> - if Name.equal (Name id) na then - user_err ?loc - (Id.print id ++ str" must be a proper parameter and not a local definition.") - else - aux (x :: acc) rest - | CLocalPattern (_,_) :: rest -> - Loc.raise ?loc (Stream.Error "pattern with quote not allowed after fix") - | [] -> - user_err ?loc - (str "No parameter named " ++ Id.print id ++ str".") - in aux [] bl - -(* Used in correctness and interface *) - -let map_binder g e nal = List.fold_right (down_located (Name.fold_right g)) nal e - -let map_binders f g e bl = - (* TODO: avoid variable capture in [t] by some [na] in [List.tl nal] *) - let h (e,bl) (nal,bk,t) = (map_binder g e nal,(nal,bk,f e t)::bl) in - let (e,rbl) = List.fold_left h (e,[]) bl in - (e, List.rev rbl) - -let map_local_binders f g e bl = - (* TODO: avoid variable capture in [t] by some [na] in [List.tl nal] *) - let h (e,bl) = function - CLocalAssum(nal,k,ty) -> - (map_binder g e nal, CLocalAssum(nal,k,f e ty)::bl) - | CLocalDef((loc,na),c,ty) -> - (Name.fold_right g na e, CLocalDef((loc,na),f e c,Option.map (f e) ty)::bl) - | CLocalPattern (loc,(pat,t)) -> - let ids = ids_of_pattern pat in - (Id.Set.fold g ids e, CLocalPattern (loc,(pat,Option.map (f e) t))::bl) in - let (e,rbl) = List.fold_left h (e,[]) bl in - (e, List.rev rbl) - -let map_constr_expr_with_binders g f e = CAst.map (function - | CAppExpl (r,l) -> CAppExpl (r,List.map (f e) l) - | CApp ((p,a),l) -> - CApp ((p,f e a),List.map (fun (a,i) -> (f e a,i)) l) - | CProdN (bl,b) -> - let (e,bl) = map_binders f g e bl in CProdN (bl,f e b) - | CLambdaN (bl,b) -> - let (e,bl) = map_binders f g e bl in CLambdaN (bl,f e b) - | CLetIn (na,a,t,b) -> - CLetIn (na,f e a,Option.map (f e) t,f (Name.fold_right g (snd na) e) b) - | CCast (a,c) -> CCast (f e a, Miscops.map_cast_type (f e) c) - | CNotation (n,(l,ll,bll)) -> - (* This is an approximation because we don't know what binds what *) - CNotation (n,(List.map (f e) l,List.map (List.map (f e)) ll, - List.map (fun bl -> snd (map_local_binders f g e bl)) bll)) - | CGeneralization (b,a,c) -> CGeneralization (b,a,f e c) - | CDelimiters (s,a) -> CDelimiters (s,f e a) - | CHole _ | CEvar _ | CPatVar _ | CSort _ - | CPrim _ | CRef _ as x -> x - | CRecord l -> CRecord (List.map (fun (id, c) -> (id, f e c)) l) - | CCases (sty,rtnpo,a,bl) -> - let bl = List.map (fun (loc,(patl,rhs)) -> - let ids = ids_of_pattern_list patl in - (loc,(patl,f (Id.Set.fold g ids e) rhs))) bl in - let ids = ids_of_cases_tomatch a in - let po = Option.map (f (Id.Set.fold g ids e)) rtnpo in - CCases (sty, po, List.map (fun (tm,x,y) -> f e tm,x,y) a,bl) - | CLetTuple (nal,(ona,po),b,c) -> - let e' = List.fold_right (down_located (Name.fold_right g)) nal e in - let e'' = Option.fold_right (down_located (Name.fold_right g)) ona e in - CLetTuple (nal,(ona,Option.map (f e'') po),f e b,f e' c) - | CIf (c,(ona,po),b1,b2) -> - let e' = Option.fold_right (down_located (Name.fold_right g)) ona e in - CIf (f e c,(ona,Option.map (f e') po),f e b1,f e b2) - | CFix (id,dl) -> - CFix (id,List.map (fun (id,n,bl,t,d) -> - let (e',bl') = map_local_binders f g e bl in - let t' = f e' t in - (* Note: fix names should be inserted before the arguments... *) - let e'' = List.fold_left (fun e ((_,id),_,_,_,_) -> g id e) e' dl in - let d' = f e'' d in - (id,n,bl',t',d')) dl) - | CCoFix (id,dl) -> - CCoFix (id,List.map (fun (id,bl,t,d) -> - let (e',bl') = map_local_binders f g e bl in - let t' = f e' t in - let e'' = List.fold_left (fun e ((_,id),_,_,_) -> g id e) e' dl in - let d' = f e'' d in - (id,bl',t',d')) dl) - ) - -(* Used in constrintern *) -let rec replace_vars_constr_expr l = function - | { CAst.loc; v = CRef (Ident (loc_id,id),us) } as x -> - (try CAst.make ?loc @@ CRef (Ident (loc_id,Id.Map.find id l),us) with Not_found -> x) - | c -> map_constr_expr_with_binders Id.Map.remove - replace_vars_constr_expr l c - -(* Returns the ranges of locs of the notation that are not occupied by args *) -(* and which are then occupied by proper symbols of the notation (or spaces) *) - -let locs_of_notation ?loc locs ntn = - let unloc loc = Option.cata Loc.unloc (0,0) loc in - let (bl, el) = unloc loc in - let locs = List.map unloc locs in - let rec aux pos = function - | [] -> if Int.equal pos el then [] else [(pos,el)] - | (ba,ea)::l -> if Int.equal pos ba then aux ea l else (pos,ba)::aux ea l - in aux bl (List.sort (fun l1 l2 -> fst l1 - fst l2) locs) - -let ntn_loc ?loc (args,argslist,binderslist) = - locs_of_notation ?loc - (List.map constr_loc (args@List.flatten argslist)@ - List.map local_binders_loc binderslist) - -let patntn_loc ?loc (args,argslist) = - locs_of_notation ?loc - (List.map cases_pattern_expr_loc (args@List.flatten argslist)) +let asymmetric_patterns = asymmetric_patterns +let error_invalid_pattern_notation = error_invalid_pattern_notation +let split_at_annot = split_at_annot +let ntn_loc = ntn_loc +let patntn_loc = patntn_loc +let map_constr_expr_with_binders = map_constr_expr_with_binders +let fold_constr_expr_with_binders = fold_constr_expr_with_binders +let ids_of_cases_indtype = ids_of_cases_indtype +let occur_var_constr_expr = occur_var_constr_expr +let free_vars_of_constr_expr = free_vars_of_constr_expr +let replace_vars_constr_expr = replace_vars_constr_expr diff --git a/interp/topconstr.mli b/interp/topconstr.mli index 922f87955..9fc02461e 100644 --- a/interp/topconstr.mli +++ b/interp/topconstr.mli @@ -10,40 +10,43 @@ open Loc open Names open Constrexpr -(** Topconstr *) - +(** Topconstr: This whole module is deprecated in favor of Constrexpr_ops *) val asymmetric_patterns : bool ref +[@@ocaml.deprecated "use Constrexpr_ops.asymmetric_patterns"] (** Utilities on constr_expr *) +val split_at_annot : local_binder_expr list -> Id.t located option -> local_binder_expr list * local_binder_expr list +[@@ocaml.deprecated "use Constrexpr_ops.split_at_annot"] + +val ntn_loc : ?loc:Loc.t -> constr_notation_substitution -> string -> (int * int) list +[@@ocaml.deprecated "use Constrexpr_ops.ntn_loc"] +val patntn_loc : ?loc:Loc.t -> cases_pattern_notation_substitution -> string -> (int * int) list +[@@ocaml.deprecated "use Constrexpr_ops.patntn_loc"] + +(** For cases pattern parsing errors *) +val error_invalid_pattern_notation : ?loc:Loc.t -> unit -> 'a +[@@ocaml.deprecated "use Constrexpr_ops.error_invalid_pattern_notation"] -val replace_vars_constr_expr : - Id.t Id.Map.t -> constr_expr -> constr_expr +(*************************************************************************) +val replace_vars_constr_expr : Id.t Id.Map.t -> constr_expr -> constr_expr +[@@ocaml.deprecated "use Constrexpr_ops.free_vars_of_constr_expr"] val free_vars_of_constr_expr : constr_expr -> Id.Set.t +[@@ocaml.deprecated "use Constrexpr_ops.free_vars_of_constr_expr"] + val occur_var_constr_expr : Id.t -> constr_expr -> bool +[@@ocaml.deprecated "use Constrexpr_ops.occur_var_constr_expr"] (** Specific function for interning "in indtype" syntax of "match" *) val ids_of_cases_indtype : cases_pattern_expr -> Id.Set.t - -val split_at_annot : local_binder_expr list -> Id.t located option -> local_binder_expr list * local_binder_expr list +[@@ocaml.deprecated "use Constrexpr_ops.ids_of_cases_indtype"] (** Used in typeclasses *) - val fold_constr_expr_with_binders : (Id.t -> 'a -> 'a) -> ('a -> 'b -> constr_expr -> 'b) -> 'a -> 'b -> constr_expr -> 'b - -(** Used in correctness and interface; absence of var capture not guaranteed - in pattern-matching clauses and in binders of the form [x,y:T(x)] *) +[@@ocaml.deprecated "use Constrexpr_ops.fold_constr_expr_with_binders"] val map_constr_expr_with_binders : (Id.t -> 'a -> 'a) -> ('a -> constr_expr -> constr_expr) -> 'a -> constr_expr -> constr_expr - -val ntn_loc : - ?loc:Loc.t -> constr_notation_substitution -> string -> (int * int) list -val patntn_loc : - ?loc:Loc.t -> cases_pattern_notation_substitution -> string -> (int * int) list - -(** For cases pattern parsing errors *) - -val error_invalid_pattern_notation : ?loc:Loc.t -> unit -> 'a +[@@ocaml.deprecated "use Constrexpr_ops.map_constr_expr_with_binders"] diff --git a/kernel/constr.ml b/kernel/constr.ml index cec00c04b..be59f9341 100644 --- a/kernel/constr.ml +++ b/kernel/constr.ml @@ -233,7 +233,6 @@ let mkMeta n = Meta n (* Constructs a Variable named id *) let mkVar id = Var id - (************************************************************************) (* kind_of_term = constructions as seen by the user *) (************************************************************************) @@ -250,6 +249,168 @@ let of_kind = function | Cast (c, knd, t) -> mkCast (c, knd, t) | k -> k +(**********************************************************************) +(* Non primitive term destructors *) +(**********************************************************************) + +(* Destructor operations : partial functions + Raise [DestKO] if the const has not the expected form *) + +exception DestKO + +let isMeta c = match kind c with Meta _ -> true | _ -> false + +(* Destructs a type *) +let isSort c = match kind c with + | Sort _ -> true + | _ -> false + +let rec isprop c = match kind c with + | Sort (Sorts.Prop _) -> true + | Cast (c,_,_) -> isprop c + | _ -> false + +let rec is_Prop c = match kind c with + | Sort (Sorts.Prop Sorts.Null) -> true + | Cast (c,_,_) -> is_Prop c + | _ -> false + +let rec is_Set c = match kind c with + | Sort (Sorts.Prop Sorts.Pos) -> true + | Cast (c,_,_) -> is_Set c + | _ -> false + +let rec is_Type c = match kind c with + | Sort (Sorts.Type _) -> true + | Cast (c,_,_) -> is_Type c + | _ -> false + +let is_small = Sorts.is_small +let iskind c = isprop c || is_Type c + +(* Tests if an evar *) +let isEvar c = match kind c with Evar _ -> true | _ -> false +let isEvar_or_Meta c = match kind c with + | Evar _ | Meta _ -> true + | _ -> false + +let isCast c = match kind c with Cast _ -> true | _ -> false +(* Tests if a de Bruijn index *) +let isRel c = match kind c with Rel _ -> true | _ -> false +let isRelN n c = + match kind c with Rel n' -> Int.equal n n' | _ -> false +(* Tests if a variable *) +let isVar c = match kind c with Var _ -> true | _ -> false +let isVarId id c = match kind c with Var id' -> Id.equal id id' | _ -> false +(* Tests if an inductive *) +let isInd c = match kind c with Ind _ -> true | _ -> false +let isProd c = match kind c with | Prod _ -> true | _ -> false +let isLambda c = match kind c with | Lambda _ -> true | _ -> false +let isLetIn c = match kind c with LetIn _ -> true | _ -> false +let isApp c = match kind c with App _ -> true | _ -> false +let isConst c = match kind c with Const _ -> true | _ -> false +let isConstruct c = match kind c with Construct _ -> true | _ -> false +let isCase c = match kind c with Case _ -> true | _ -> false +let isProj c = match kind c with Proj _ -> true | _ -> false +let isFix c = match kind c with Fix _ -> true | _ -> false +let isCoFix c = match kind c with CoFix _ -> true | _ -> false + +(* Destructs a de Bruijn index *) +let destRel c = match kind c with + | Rel n -> n + | _ -> raise DestKO + +(* Destructs an existential variable *) +let destMeta c = match kind c with + | Meta n -> n + | _ -> raise DestKO + +(* Destructs a variable *) +let destVar c = match kind c with + | Var id -> id + | _ -> raise DestKO + +let destSort c = match kind c with + | Sort s -> s + | _ -> raise DestKO + +(* Destructs a casted term *) +let destCast c = match kind c with + | Cast (t1,k,t2) -> (t1,k,t2) + | _ -> raise DestKO + +(* Destructs the product (x:t1)t2 *) +let destProd c = match kind c with + | Prod (x,t1,t2) -> (x,t1,t2) + | _ -> raise DestKO + +(* Destructs the abstraction [x:t1]t2 *) +let destLambda c = match kind c with + | Lambda (x,t1,t2) -> (x,t1,t2) + | _ -> raise DestKO + +(* Destructs the let [x:=b:t1]t2 *) +let destLetIn c = match kind c with + | LetIn (x,b,t1,t2) -> (x,b,t1,t2) + | _ -> raise DestKO + +(* Destructs an application *) +let destApp c = match kind c with + | App (f,a) -> (f, a) + | _ -> raise DestKO + +(* Destructs a constant *) +let destConst c = match kind c with + | Const kn -> kn + | _ -> raise DestKO + +(* Destructs an existential variable *) +let destEvar c = match kind c with + | Evar (kn, a as r) -> r + | _ -> raise DestKO + +(* Destructs a (co)inductive type named kn *) +let destInd c = match kind c with + | Ind (kn, a as r) -> r + | _ -> raise DestKO + +(* Destructs a constructor *) +let destConstruct c = match kind c with + | Construct (kn, a as r) -> r + | _ -> raise DestKO + +(* Destructs a term <p>Case c of lc1 | lc2 .. | lcn end *) +let destCase c = match kind c with + | Case (ci,p,c,v) -> (ci,p,c,v) + | _ -> raise DestKO + +let destProj c = match kind c with + | Proj (p, c) -> (p, c) + | _ -> raise DestKO + +let destFix c = match kind c with + | Fix fix -> fix + | _ -> raise DestKO + +let destCoFix c = match kind c with + | CoFix cofix -> cofix + | _ -> raise DestKO + + +(******************************************************************) +(* Flattening and unflattening of embedded applications and casts *) +(******************************************************************) + +let decompose_app c = + match kind c with + | App (f,cl) -> (f, Array.to_list cl) + | _ -> (c,[]) + +let decompose_appvect c = + match kind c with + | App (f,cl) -> (f, cl) + | _ -> (c,[||]) + (****************************************************************************) (* Functions to recur through subterms *) (****************************************************************************) diff --git a/kernel/constr.mli b/kernel/constr.mli index 474ab3884..4c5ea9e95 100644 --- a/kernel/constr.mli +++ b/kernel/constr.mli @@ -225,6 +225,110 @@ type ('constr, 'types, 'sort, 'univs) kind_of_term = val kind : constr -> (constr, types, Sorts.t, Univ.Instance.t) kind_of_term val of_kind : (constr, types, Sorts.t, Univ.Instance.t) kind_of_term -> constr +(** {6 Simple case analysis} *) +val isRel : constr -> bool +val isRelN : int -> constr -> bool +val isVar : constr -> bool +val isVarId : Id.t -> constr -> bool +val isInd : constr -> bool +val isEvar : constr -> bool +val isMeta : constr -> bool +val isEvar_or_Meta : constr -> bool +val isSort : constr -> bool +val isCast : constr -> bool +val isApp : constr -> bool +val isLambda : constr -> bool +val isLetIn : constr -> bool +val isProd : constr -> bool +val isConst : constr -> bool +val isConstruct : constr -> bool +val isFix : constr -> bool +val isCoFix : constr -> bool +val isCase : constr -> bool +val isProj : constr -> bool + +val is_Prop : constr -> bool +val is_Set : constr -> bool +val isprop : constr -> bool +val is_Type : constr -> bool +val iskind : constr -> bool +val is_small : Sorts.t -> bool + +(** {6 Term destructors } *) +(** Destructor operations are partial functions and + @raise DestKO if the term has not the expected form. *) + +exception DestKO + +(** Destructs a de Bruijn index *) +val destRel : constr -> int + +(** Destructs an existential variable *) +val destMeta : constr -> metavariable + +(** Destructs a variable *) +val destVar : constr -> Id.t + +(** Destructs a sort. [is_Prop] recognizes the sort {% \textsf{%}Prop{% }%}, whether + [isprop] recognizes both {% \textsf{%}Prop{% }%} and {% \textsf{%}Set{% }%}. *) +val destSort : constr -> Sorts.t + +(** Destructs a casted term *) +val destCast : constr -> constr * cast_kind * constr + +(** Destructs the product {% $ %}(x:t_1)t_2{% $ %} *) +val destProd : types -> Name.t * types * types + +(** Destructs the abstraction {% $ %}[x:t_1]t_2{% $ %} *) +val destLambda : constr -> Name.t * types * constr + +(** Destructs the let {% $ %}[x:=b:t_1]t_2{% $ %} *) +val destLetIn : constr -> Name.t * constr * types * constr + +(** Destructs an application *) +val destApp : constr -> constr * constr array + +(** Decompose any term as an applicative term; the list of args can be empty *) +val decompose_app : constr -> constr * constr list + +(** Same as [decompose_app], but returns an array. *) +val decompose_appvect : constr -> constr * constr array + +(** Destructs a constant *) +val destConst : constr -> Constant.t puniverses + +(** Destructs an existential variable *) +val destEvar : constr -> existential + +(** Destructs a (co)inductive type *) +val destInd : constr -> inductive puniverses + +(** Destructs a constructor *) +val destConstruct : constr -> constructor puniverses + +(** Destructs a [match c as x in I args return P with ... | +Ci(...yij...) => ti | ... end] (or [let (..y1i..) := c as x in I args +return P in t1], or [if c then t1 else t2]) +@return [(info,c,fun args x => P,[|...|fun yij => ti| ...|])] +where [info] is pretty-printing information *) +val destCase : constr -> case_info * constr * constr * constr array + +(** Destructs a projection *) +val destProj : constr -> projection * constr + +(** Destructs the {% $ %}i{% $ %}th function of the block + [Fixpoint f{_ 1} ctx{_ 1} = b{_ 1} + with f{_ 2} ctx{_ 2} = b{_ 2} + ... + with f{_ n} ctx{_ n} = b{_ n}], + where the length of the {% $ %}j{% $ %}th context is {% $ %}ij{% $ %}. +*) +val destFix : constr -> fixpoint + +val destCoFix : constr -> cofixpoint + +(** {6 Equality} *) + (** [equal a b] is true if [a] equals [b] modulo alpha, casts, and application grouping *) val equal : constr -> constr -> bool @@ -344,7 +448,7 @@ val compare_head_gen_leq : (bool -> Univ.Instance.t -> Univ.Instance.t -> bool) (constr -> constr -> bool) -> (constr -> constr -> bool) -> constr -> constr -> bool - + (** {6 Hashconsing} *) val hash : constr -> int diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index f4e611c19..083b0ae40 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -56,7 +56,7 @@ let weaker_noccur_between env x nvars t = else None let is_constructor_head t = - Term.isRel(fst(Term.decompose_app t)) + isRel(fst(decompose_app t)) (************************************************************************) (* Various well-formedness check for inductive declarations *) @@ -135,7 +135,7 @@ let infos_and_sort env t = | Prod (name,c1,c2) -> let varj = infer_type env c1 in let env1 = Environ.push_rel (LocalAssum (name,varj.utj_val)) env in - let max = Universe.sup max (Term.univ_of_sort varj.utj_type) in + let max = Universe.sup max (Sorts.univ_of_sort varj.utj_type) in aux env1 c2 max | _ when is_constructor_head t -> max | _ -> (* don't fail if not positive, it is tested later *) max @@ -184,7 +184,7 @@ let cumulate_arity_large_levels env sign = match d with | LocalAssum (_,t) -> let tj = infer_type env t in - let u = Term.univ_of_sort tj.utj_type in + let u = Sorts.univ_of_sort tj.utj_type in (Universe.sup u lev, push_rel d env) | LocalDef _ -> lev, push_rel d env) @@ -351,7 +351,7 @@ let typecheck_inductive env mie = | None -> clev in let full_polymorphic () = - let defu = Term.univ_of_sort def_level in + let defu = Sorts.univ_of_sort def_level in let is_natural = type_in_type env || (UGraph.check_leq (universes env') infu defu) in @@ -555,7 +555,7 @@ let check_positivity_one ~chkpos recursive (env,_,ntypes,_ as ienv) paramsctxt ( constructor [cn] has a type of the shape [… -> c … -> P], where, more generally, the arrows may be dependent). *) let rec check_pos (env, n, ntypes, ra_env as ienv) nmr c = - let x,largs = Term.decompose_app (whd_all env c) in + let x,largs = decompose_app (whd_all env c) in match kind x with | Prod (na,b,d) -> let () = assert (List.is_empty largs) in @@ -663,7 +663,7 @@ let check_positivity_one ~chkpos recursive (env,_,ntypes,_ as ienv) paramsctxt ( inductive type. *) and check_constructors ienv check_head nmr c = let rec check_constr_rec (env,n,ntypes,ra_env as ienv) nmr lrec c = - let x,largs = Term.decompose_app (whd_all env c) in + let x,largs = decompose_app (whd_all env c) in match kind x with | Prod (na,b,d) -> @@ -916,11 +916,11 @@ let build_inductive env prv iu env_ar paramsctxt kn isrecord isfinite inds nmr r let ar = {template_param_levels = paramlevs; template_level = lev} in TemplateArity ar, all_sorts | RegularArity (info,ar,defs) -> - let s = sort_of_univ defs in + let s = Sorts.sort_of_univ defs in let kelim = allowed_sorts info s in let ar = RegularArity { mind_user_arity = Vars.subst_univs_level_constr substunivs ar; - mind_sort = sort_of_univ (Univ.subst_univs_level_universe substunivs defs); } in + mind_sort = Sorts.sort_of_univ (Univ.subst_univs_level_universe substunivs defs); } in ar, kelim in (* Assigning VM tags to constructors *) let nconst, nblock = ref 0, ref 0 in diff --git a/kernel/inductive.ml b/kernel/inductive.ml index cb03a4d6b..0782ea820 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -29,20 +29,20 @@ let lookup_mind_specif env (kn,tyi) = (mib, mib.mind_packets.(tyi)) let find_rectype env c = - let (t, l) = Term.decompose_app (whd_all env c) in + let (t, l) = decompose_app (whd_all env c) in match kind t with | Ind ind -> (ind, l) | _ -> raise Not_found let find_inductive env c = - let (t, l) = Term.decompose_app (whd_all env c) in + let (t, l) = decompose_app (whd_all env c) in match kind t with | Ind ind when (fst (lookup_mind_specif env (out_punivs ind))).mind_finite <> Decl_kinds.CoFinite -> (ind, l) | _ -> raise Not_found let find_coinductive env c = - let (t, l) = Term.decompose_app (whd_all env c) in + let (t, l) = decompose_app (whd_all env c) in match kind t with | Ind ind when (fst (lookup_mind_specif env (out_punivs ind))).mind_finite == Decl_kinds.CoFinite -> (ind, l) @@ -354,7 +354,7 @@ let build_branches_type (ind,u) (_,mip as specif) params p = let typi = full_constructor_instantiate (ind,u,specif,params) cty in let (cstrsign,ccl) = Term.decompose_prod_assum typi in let nargs = Context.Rel.length cstrsign in - let (_,allargs) = Term.decompose_app ccl in + let (_,allargs) = decompose_app ccl in let (lparams,vargs) = List.chop (inductive_params specif) allargs in let cargs = let cstr = ith_constructor_of_inductive ind (i+1) in @@ -566,8 +566,8 @@ let check_inductive_codomain env p = let env = push_rel_context absctx env in let arctx, s = dest_prod_assum env ar in let env = push_rel_context arctx env in - let i,l' = Term.decompose_app (whd_all env s) in - Term.isInd i + let i,l' = decompose_app (whd_all env s) in + isInd i (* The following functions are almost duplicated from indtypes.ml, except that they carry here a poorer environment (containing less information). *) @@ -621,7 +621,7 @@ close to check_positive in indtypes.ml, but does no positivity check and does no compute the number of recursive arguments. *) let get_recargs_approx env tree ind args = let rec build_recargs (env, ra_env as ienv) tree c = - let x,largs = Term.decompose_app (whd_all env c) in + let x,largs = decompose_app (whd_all env c) in match kind x with | Prod (na,b,d) -> assert (List.is_empty largs); @@ -680,7 +680,7 @@ let get_recargs_approx env tree ind args = and build_recargs_constructors ienv trees c = let rec recargs_constr_rec (env,ra_env as ienv) trees lrec c = - let x,largs = Term.decompose_app (whd_all env c) in + let x,largs = decompose_app (whd_all env c) in match kind x with | Prod (na,b,d) -> @@ -709,7 +709,7 @@ let restrict_spec env spec p = let env = push_rel_context absctx env in let arctx, s = dest_prod_assum env ar in let env = push_rel_context arctx env in - let i,args = Term.decompose_app (whd_all env s) in + let i,args = decompose_app (whd_all env s) in match kind i with | Ind i -> begin match spec with @@ -730,7 +730,7 @@ let restrict_spec env spec p = let rec subterm_specif renv stack t = (* maybe reduction is not always necessary! *) - let f,l = Term.decompose_app (whd_all renv.env t) in + let f,l = decompose_app (whd_all renv.env t) in match kind f with | Rel k -> subterm_var k renv | Case (ci,p,c,lbr) -> @@ -863,7 +863,7 @@ let filter_stack_domain env ci p stack = let d = LocalAssum (n,a) in let ctx, a = dest_prod_assum env a in let env = push_rel_context ctx env in - let ty, args = Term.decompose_app (whd_all env a) in + let ty, args = decompose_app (whd_all env a) in let elt = match kind ty with | Ind ind -> let spec' = stack_element_specif elt in @@ -894,7 +894,7 @@ let check_one_fix renv recpos trees def = (* if [t] does not make recursive calls, it is guarded: *) if noccur_with_meta renv.rel_min nfi t then () else - let (f,l) = Term.decompose_app (whd_betaiotazeta renv.env t) in + let (f,l) = decompose_app (whd_betaiotazeta renv.env t) in match kind f with | Rel p -> (* Test if [p] is a fixpoint (recursive call) *) @@ -1120,7 +1120,7 @@ let rec codomain_is_coind env c = let check_one_cofix env nbfix def deftype = let rec check_rec_call env alreadygrd n tree vlra t = if not (noccur_with_meta n nbfix t) then - let c,args = Term.decompose_app (whd_all env t) in + let c,args = decompose_app (whd_all env t) in match kind c with | Rel p when n <= p && p < n+nbfix -> (* recursive call: must be guarded and no nested recursive diff --git a/kernel/modops.ml b/kernel/modops.ml index b1df1a187..11e6be659 100644 --- a/kernel/modops.ml +++ b/kernel/modops.ml @@ -266,9 +266,9 @@ let subst_structure subst = subst_structure subst do_delta_codom (* lclrk : retroknowledge_action list, rkaction : retroknowledge action *) let add_retroknowledge mp = let perform rkaction env = match rkaction with - |Retroknowledge.RKRegister (f, e) when (Term.isConst e || Term.isInd e) -> + | Retroknowledge.RKRegister (f, e) when (isConst e || isInd e) -> Environ.register env f e - |_ -> + | _ -> CErrors.anomaly ~label:"Modops.add_retroknowledge" (Pp.str "had to import an unsupported kind of term.") in diff --git a/kernel/names.ml b/kernel/names.ml index cb27104d1..b02c0b840 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -179,6 +179,8 @@ struct | [] -> "<>" | sl -> String.concat "." (List.rev_map Id.to_string sl) + let print dp = str (to_string dp) + let initial = [default_module_name] module Hdir = Hashcons.Hlist(Id) diff --git a/kernel/names.mli b/kernel/names.mli index ba0637c8a..709ebeb7f 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -159,6 +159,7 @@ sig val hcons : t -> t (** Hashconsing of directory paths. *) + val print : t -> Pp.t end (** {6 Names of structure elements } *) diff --git a/kernel/term.ml b/kernel/term.ml index 1c970867a..4217cfac7 100644 --- a/kernel/term.ml +++ b/kernel/term.ml @@ -11,6 +11,7 @@ open Pp open CErrors open Names open Vars +open Constr (**********************************************************************) (** Redeclaration of types from module Constr *) @@ -165,167 +166,52 @@ let hcons_types = Constr.hcons (* Non primitive term destructors *) (**********************************************************************) -(* Destructor operations : partial functions - Raise [DestKO] if the const has not the expected form *) - -exception DestKO - +exception DestKO = DestKO (* Destructs a de Bruijn index *) -let destRel c = match kind_of_term c with - | Rel n -> n - | _ -> raise DestKO - -(* Destructs an existential variable *) -let destMeta c = match kind_of_term c with - | Meta n -> n - | _ -> raise DestKO - -let isMeta c = match kind_of_term c with Meta _ -> true | _ -> false - -(* Destructs a variable *) -let destVar c = match kind_of_term c with - | Var id -> id - | _ -> raise DestKO - -(* Destructs a type *) -let isSort c = match kind_of_term c with - | Sort _ -> true - | _ -> false - -let destSort c = match kind_of_term c with - | Sort s -> s - | _ -> raise DestKO - -let rec isprop c = match kind_of_term c with - | Sort (Prop _) -> true - | Cast (c,_,_) -> isprop c - | _ -> false - -let rec is_Prop c = match kind_of_term c with - | Sort (Prop Null) -> true - | Cast (c,_,_) -> is_Prop c - | _ -> false - -let rec is_Set c = match kind_of_term c with - | Sort (Prop Pos) -> true - | Cast (c,_,_) -> is_Set c - | _ -> false - -let rec is_Type c = match kind_of_term c with - | Sort (Type _) -> true - | Cast (c,_,_) -> is_Type c - | _ -> false - -let is_small = Sorts.is_small - -let iskind c = isprop c || is_Type c - -(* Tests if an evar *) -let isEvar c = match kind_of_term c with Evar _ -> true | _ -> false - -let isEvar_or_Meta c = match kind_of_term c with - | Evar _ | Meta _ -> true - | _ -> false - -(* Destructs a casted term *) -let destCast c = match kind_of_term c with - | Cast (t1,k,t2) -> (t1,k,t2) - | _ -> raise DestKO - -let isCast c = match kind_of_term c with Cast _ -> true | _ -> false - - -(* Tests if a de Bruijn index *) -let isRel c = match kind_of_term c with Rel _ -> true | _ -> false -let isRelN n c = - match kind_of_term c with Rel n' -> Int.equal n n' | _ -> false - -(* Tests if a variable *) -let isVar c = match kind_of_term c with Var _ -> true | _ -> false -let isVarId id c = - match kind_of_term c with Var id' -> Id.equal id id' | _ -> false - -(* Tests if an inductive *) -let isInd c = match kind_of_term c with Ind _ -> true | _ -> false - -(* Destructs the product (x:t1)t2 *) -let destProd c = match kind_of_term c with - | Prod (x,t1,t2) -> (x,t1,t2) - | _ -> raise DestKO - -let isProd c = match kind_of_term c with | Prod _ -> true | _ -> false - -(* Destructs the abstraction [x:t1]t2 *) -let destLambda c = match kind_of_term c with - | Lambda (x,t1,t2) -> (x,t1,t2) - | _ -> raise DestKO - -let isLambda c = match kind_of_term c with | Lambda _ -> true | _ -> false - -(* Destructs the let [x:=b:t1]t2 *) -let destLetIn c = match kind_of_term c with - | LetIn (x,b,t1,t2) -> (x,b,t1,t2) - | _ -> raise DestKO - -let isLetIn c = match kind_of_term c with LetIn _ -> true | _ -> false - -(* Destructs an application *) -let destApp c = match kind_of_term c with - | App (f,a) -> (f, a) - | _ -> raise DestKO - +let destRel = destRel +let destMeta = destRel +let isMeta = isMeta +let destVar = destVar +let isSort = isSort +let destSort = destSort +let isprop = isprop +let is_Prop = is_Prop +let is_Set = is_Set +let is_Type = is_Type +let is_small = is_small +let iskind = iskind +let isEvar = isEvar +let isEvar_or_Meta = isEvar_or_Meta +let destCast = destCast +let isCast = isCast +let isRel = isRel +let isRelN = isRelN +let isVar = isVar +let isVarId = isVarId +let isInd = isInd +let destProd = destProd +let isProd = isProd +let destLambda = destLambda +let isLambda = isLambda +let destLetIn = destLetIn +let isLetIn = isLetIn +let destApp = destApp let destApplication = destApp - -let isApp c = match kind_of_term c with App _ -> true | _ -> false - -(* Destructs a constant *) -let destConst c = match kind_of_term c with - | Const kn -> kn - | _ -> raise DestKO - -let isConst c = match kind_of_term c with Const _ -> true | _ -> false - -(* Destructs an existential variable *) -let destEvar c = match kind_of_term c with - | Evar (kn, a as r) -> r - | _ -> raise DestKO - -(* Destructs a (co)inductive type named kn *) -let destInd c = match kind_of_term c with - | Ind (kn, a as r) -> r - | _ -> raise DestKO - -(* Destructs a constructor *) -let destConstruct c = match kind_of_term c with - | Construct (kn, a as r) -> r - | _ -> raise DestKO - -let isConstruct c = match kind_of_term c with Construct _ -> true | _ -> false - -(* Destructs a term <p>Case c of lc1 | lc2 .. | lcn end *) -let destCase c = match kind_of_term c with - | Case (ci,p,c,v) -> (ci,p,c,v) - | _ -> raise DestKO - -let isCase c = match kind_of_term c with Case _ -> true | _ -> false - -let isProj c = match kind_of_term c with Proj _ -> true | _ -> false - -let destProj c = match kind_of_term c with - | Proj (p, c) -> (p, c) - | _ -> raise DestKO - -let destFix c = match kind_of_term c with - | Fix fix -> fix - | _ -> raise DestKO - -let isFix c = match kind_of_term c with Fix _ -> true | _ -> false - -let destCoFix c = match kind_of_term c with - | CoFix cofix -> cofix - | _ -> raise DestKO - -let isCoFix c = match kind_of_term c with CoFix _ -> true | _ -> false +let isApp = isApp +let destConst = destConst +let isConst = isConst +let destEvar = destEvar +let destInd = destInd +let destConstruct = destConstruct +let isConstruct = isConstruct +let destCase = destCase +let isCase = isCase +let isProj = isProj +let destProj = destProj +let destFix = destFix +let isFix = isFix +let destCoFix = destCoFix +let isCoFix = isCoFix (******************************************************************) (* Flattening and unflattening of embedded applications and casts *) diff --git a/kernel/term.mli b/kernel/term.mli index 33c6b0b08..4efb582d0 100644 --- a/kernel/term.mli +++ b/kernel/term.mli @@ -16,90 +16,133 @@ open Constr *) +exception DestKO +[@@ocaml.deprecated "Alias for [Constr.DestKO]"] + (** {5 Simple term case analysis. } *) val isRel : constr -> bool +[@@ocaml.deprecated "Alias for [Constr.isRel]"] val isRelN : int -> constr -> bool +[@@ocaml.deprecated "Alias for [Constr.isRelN]"] val isVar : constr -> bool +[@@ocaml.deprecated "Alias for [Constr.isVar]"] val isVarId : Id.t -> constr -> bool +[@@ocaml.deprecated "Alias for [Constr.isVarId]"] val isInd : constr -> bool +[@@ocaml.deprecated "Alias for [Constr.isInd]"] val isEvar : constr -> bool +[@@ocaml.deprecated "Alias for [Constr.isEvar]"] val isMeta : constr -> bool +[@@ocaml.deprecated "Alias for [Constr.isMeta]"] val isEvar_or_Meta : constr -> bool +[@@ocaml.deprecated "Alias for [Constr.isEvar_or_Meta]"] val isSort : constr -> bool +[@@ocaml.deprecated "Alias for [Constr.isSort]"] val isCast : constr -> bool +[@@ocaml.deprecated "Alias for [Constr.isCast]"] val isApp : constr -> bool +[@@ocaml.deprecated "Alias for [Constr.isApp]"] val isLambda : constr -> bool +[@@ocaml.deprecated "Alias for [Constr.isLambda]"] val isLetIn : constr -> bool +[@@ocaml.deprecated "Alias for [Constr.isletIn]"] val isProd : constr -> bool +[@@ocaml.deprecated "Alias for [Constr.isProp]"] val isConst : constr -> bool +[@@ocaml.deprecated "Alias for [Constr.isConst]"] val isConstruct : constr -> bool +[@@ocaml.deprecated "Alias for [Constr.isConstruct]"] val isFix : constr -> bool +[@@ocaml.deprecated "Alias for [Constr.isFix]"] val isCoFix : constr -> bool +[@@ocaml.deprecated "Alias for [Constr.isCoFix]"] val isCase : constr -> bool +[@@ocaml.deprecated "Alias for [Constr.isCase]"] val isProj : constr -> bool +[@@ocaml.deprecated "Alias for [Constr.isProj]"] val is_Prop : constr -> bool +[@@ocaml.deprecated "Alias for [Constr.is_Prop]"] val is_Set : constr -> bool +[@@ocaml.deprecated "Alias for [Constr.is_Set]"] val isprop : constr -> bool +[@@ocaml.deprecated "Alias for [Constr.isprop]"] val is_Type : constr -> bool +[@@ocaml.deprecated "Alias for [Constr.is_Type]"] val iskind : constr -> bool +[@@ocaml.deprecated "Alias for [Constr.is_kind]"] val is_small : Sorts.t -> bool +[@@ocaml.deprecated "Alias for [Constr.is_small]"] (** {5 Term destructors } *) (** Destructor operations are partial functions and @raise DestKO if the term has not the expected form. *) -exception DestKO - (** Destructs a de Bruijn index *) val destRel : constr -> int +[@@ocaml.deprecated "Alias for [Constr.destRel]"] (** Destructs an existential variable *) val destMeta : constr -> metavariable +[@@ocaml.deprecated "Alias for [Constr.destMeta]"] (** Destructs a variable *) val destVar : constr -> Id.t +[@@ocaml.deprecated "Alias for [Constr.destVar]"] (** Destructs a sort. [is_Prop] recognizes the sort {% \textsf{%}Prop{% }%}, whether [isprop] recognizes both {% \textsf{%}Prop{% }%} and {% \textsf{%}Set{% }%}. *) val destSort : constr -> Sorts.t +[@@ocaml.deprecated "Alias for [Constr.destSort]"] (** Destructs a casted term *) val destCast : constr -> constr * cast_kind * constr +[@@ocaml.deprecated "Alias for [Constr.destCast]"] (** Destructs the product {% $ %}(x:t_1)t_2{% $ %} *) val destProd : types -> Name.t * types * types +[@@ocaml.deprecated "Alias for [Constr.destProd]"] (** Destructs the abstraction {% $ %}[x:t_1]t_2{% $ %} *) val destLambda : constr -> Name.t * types * constr +[@@ocaml.deprecated "Alias for [Constr.destLambda]"] (** Destructs the let {% $ %}[x:=b:t_1]t_2{% $ %} *) val destLetIn : constr -> Name.t * constr * types * constr +[@@ocaml.deprecated "Alias for [Constr.destLetIn]"] (** Destructs an application *) val destApp : constr -> constr * constr array +[@@ocaml.deprecated "Alias for [Constr.destApp]"] (** Obsolete synonym of destApp *) val destApplication : constr -> constr * constr array +[@@ocaml.deprecated "Alias for [Constr.destApplication]"] (** Decompose any term as an applicative term; the list of args can be empty *) val decompose_app : constr -> constr * constr list +[@@ocaml.deprecated "Alias for [Constr.decompose_app]"] (** Same as [decompose_app], but returns an array. *) val decompose_appvect : constr -> constr * constr array +[@@ocaml.deprecated "Alias for [Constr.decompose_appvect]"] (** Destructs a constant *) val destConst : constr -> Constant.t puniverses +[@@ocaml.deprecated "Alias for [Constr.destConst]"] (** Destructs an existential variable *) val destEvar : constr -> existential +[@@ocaml.deprecated "Alias for [Constr.destEvar]"] (** Destructs a (co)inductive type *) val destInd : constr -> inductive puniverses +[@@ocaml.deprecated "Alias for [Constr.destInd]"] (** Destructs a constructor *) val destConstruct : constr -> constructor puniverses +[@@ocaml.deprecated "Alias for [Constr.destConstruct]"] (** Destructs a [match c as x in I args return P with ... | Ci(...yij...) => ti | ... end] (or [let (..y1i..) := c as x in I args @@ -107,9 +150,11 @@ return P in t1], or [if c then t1 else t2]) @return [(info,c,fun args x => P,[|...|fun yij => ti| ...|])] where [info] is pretty-printing information *) val destCase : constr -> case_info * constr * constr * constr array +[@@ocaml.deprecated "Alias for [Constr.destCase]"] (** Destructs a projection *) val destProj : constr -> projection * constr +[@@ocaml.deprecated "Alias for [Constr.destProj]"] (** Destructs the {% $ %}i{% $ %}th function of the block [Fixpoint f{_ 1} ctx{_ 1} = b{_ 1} @@ -119,8 +164,10 @@ val destProj : constr -> projection * constr where the length of the {% $ %}j{% $ %}th context is {% $ %}ij{% $ %}. *) val destFix : constr -> fixpoint +[@@ocaml.deprecated "Alias for [Constr.destFix]"] val destCoFix : constr -> cofixpoint +[@@ocaml.deprecated "Alias for [Constr.destCoFix]"] (** {5 Derived constructors} *) @@ -415,8 +462,11 @@ val map_constr_with_binders : [@@ocaml.deprecated "Alias for [Constr.map_with_binders]"] val map_puniverses : ('a -> 'b) -> 'a puniverses -> 'b puniverses +[@@ocaml.deprecated "Alias for [Constr.map_puniverses]"] val univ_of_sort : Sorts.t -> Univ.Universe.t +[@@ocaml.deprecated "Alias for [Sorts.univ_of_sort]"] val sort_of_univ : Univ.Universe.t -> Sorts.t +[@@ocaml.deprecated "Alias for [Sorts.sort_of_univ]"] val iter_constr : (constr -> unit) -> constr -> unit [@@ocaml.deprecated "Alias for [Constr.iter]"] diff --git a/library/coqlib.ml b/library/coqlib.ml index 141fff033..4a2390985 100644 --- a/library/coqlib.ml +++ b/library/coqlib.ml @@ -14,7 +14,7 @@ open Libnames open Globnames open Nametab -let coq = Nameops.coq_string (* "Coq" *) +let coq = Libnames.coq_string (* "Coq" *) (************************************************************************) (* Generic functions to find Coq objects *) @@ -32,7 +32,7 @@ let find_reference locstr dir s = of not found errors here *) user_err ~hdr:locstr Pp.(str "cannot find " ++ Libnames.pr_path sp ++ - str "; maybe library " ++ Libnames.pr_dirpath dp ++ + str "; maybe library " ++ DirPath.print dp ++ str " has to be required first.") let coq_reference locstr dir s = find_reference locstr (coq::dir) s @@ -52,14 +52,14 @@ let gen_reference_in_modules locstr dirs s = | [] -> anomaly ~label:locstr (str "cannot find " ++ str s ++ str " in module" ++ str (if List.length dirs > 1 then "s " else " ") ++ - prlist_with_sep pr_comma pr_dirpath dirs ++ str ".") + prlist_with_sep pr_comma DirPath.print dirs ++ str ".") | l -> anomaly ~label:locstr (str "ambiguous name " ++ str s ++ str " can represent " ++ prlist_with_sep pr_comma (fun x -> Libnames.pr_path (Nametab.path_of_global x)) l ++ str " in module" ++ str (if List.length dirs > 1 then "s " else " ") ++ - prlist_with_sep pr_comma pr_dirpath dirs ++ str ".") + prlist_with_sep pr_comma DirPath.print dirs ++ str ".") (* For tactics/commands requiring vernacular libraries *) @@ -79,7 +79,7 @@ let check_required_library d = *) (* or failing ...*) user_err ~hdr:"Coqlib.check_required_library" - (str "Library " ++ pr_dirpath dir ++ str " has to be required first.") + (str "Library " ++ DirPath.print dir ++ str " has to be required first.") (************************************************************************) (* Specific Coq objects *) diff --git a/library/declaremods.ml b/library/declaremods.ml index cda40f49f..db83dafef 100644 --- a/library/declaremods.ml +++ b/library/declaremods.ml @@ -167,13 +167,13 @@ let consistency_checks exists dir dirinfo = try Nametab.locate_dir (qualid_of_dirpath dir) with Not_found -> user_err ~hdr:"consistency_checks" - (pr_dirpath dir ++ str " should already exist!") + (DirPath.print dir ++ str " should already exist!") in assert (eq_global_dir_reference globref dirinfo) else if Nametab.exists_dir dir then user_err ~hdr:"consistency_checks" - (pr_dirpath dir ++ str " already exists") + (DirPath.print dir ++ str " already exists") let compute_visibility exists i = if exists then Nametab.Exactly i else Nametab.Until i diff --git a/library/heads.ml b/library/heads.ml index 8b8e407f7..ee3bfe1bd 100644 --- a/library/heads.ml +++ b/library/heads.ml @@ -8,7 +8,6 @@ open Util open Names -open Term open Constr open Vars open Mod_subst diff --git a/library/lib.ml b/library/lib.ml index 36292d367..3dbb16c7b 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -12,7 +12,6 @@ open Util open Names open Libnames open Globnames -open Nameops open Libobject open Context.Named.Declaration @@ -361,8 +360,8 @@ let end_compilation_checks dir = | None -> anomaly (Pp.str "There should be a module name...") | Some m -> if not (Names.DirPath.equal m dir) then anomaly - (str "The current open module has name" ++ spc () ++ pr_dirpath m ++ - spc () ++ str "and not" ++ spc () ++ pr_dirpath m ++ str "."); + (str "The current open module has name" ++ spc () ++ DirPath.print m ++ + spc () ++ str "and not" ++ spc () ++ DirPath.print m ++ str "."); in oname diff --git a/library/libnames.ml b/library/libnames.ml index efb1348ab..81878e72f 100644 --- a/library/libnames.ml +++ b/library/libnames.ml @@ -13,7 +13,7 @@ open Names (**********************************************) -let pr_dirpath sl = str (DirPath.to_string sl) +let pr_dirpath sl = DirPath.print sl (*s Operations on dirpaths *) @@ -232,6 +232,14 @@ let join_reference ns r = Qualid (loc, make_qualid (dirpath_of_string (Names.Id.to_string id1)) id2) +(* Default paths *) +let default_library = Names.DirPath.initial (* = ["Top"] *) + +(*s Roots of the space of absolute names *) +let coq_string = "Coq" +let coq_root = Id.of_string coq_string +let default_root_prefix = DirPath.empty + (* Deprecated synonyms *) let make_short_qualid = qualid_of_ident diff --git a/library/libnames.mli b/library/libnames.mli index ab2585334..ed01163ee 100644 --- a/library/libnames.mli +++ b/library/libnames.mli @@ -11,12 +11,13 @@ open Loc open Names (** {6 Dirpaths } *) -(** FIXME: ought to be in Names.dir_path *) +val dirpath_of_string : string -> DirPath.t val pr_dirpath : DirPath.t -> Pp.t +[@@ocaml.deprecated "Alias for DirPath.print"] -val dirpath_of_string : string -> DirPath.t val string_of_dirpath : DirPath.t -> string +[@@ocaml.deprecated "Alias for DirPath.to_string"] (** Pop the suffix of a [DirPath.t]. Raises a [Failure] for an empty path *) val pop_dirpath : DirPath.t -> DirPath.t @@ -127,7 +128,20 @@ val pr_reference : reference -> Pp.t val loc_of_reference : reference -> Loc.t option val join_reference : reference -> reference -> reference -(** Deprecated synonyms *) +(** some preset paths *) +val default_library : DirPath.t + +(** This is the root of the standard library of Coq *) +val coq_root : module_ident (** "Coq" *) +val coq_string : string (** "Coq" *) +(** This is the default root prefix for developments which doesn't + mention a root *) +val default_root_prefix : DirPath.t + +(** Deprecated synonyms *) val make_short_qualid : Id.t -> qualid (** = qualid_of_ident *) +[@@ocaml.deprecated "Alias for qualid_of_ident"] + val qualid_of_sp : full_path -> qualid (** = qualid_of_path *) +[@@ocaml.deprecated "Alias for qualid_of_sp"] diff --git a/library/library.ml b/library/library.ml index 99ef66699..88470d121 100644 --- a/library/library.ml +++ b/library/library.ml @@ -12,9 +12,8 @@ open Util open Names open Libnames -open Nameops -open Libobject open Lib +open Libobject (************************************************************************) (*s Low-level interning/externing of libraries to files *) @@ -132,7 +131,7 @@ let try_find_library dir = try find_library dir with Not_found -> user_err ~hdr:"Library.find_library" - (str "Unknown library " ++ pr_dirpath dir) + (str "Unknown library " ++ DirPath.print dir) let register_library_filename dir f = (* Not synchronized: overwrite the previous binding if one existed *) @@ -331,7 +330,7 @@ let error_unmapped_dir qid = let prefix, _ = repr_qualid qid in user_err ~hdr:"load_absolute_library_from" (str "Cannot load " ++ pr_qualid qid ++ str ":" ++ spc () ++ - str "no physical path bound to" ++ spc () ++ pr_dirpath prefix ++ fnl ()) + str "no physical path bound to" ++ spc () ++ DirPath.print prefix ++ fnl ()) let error_lib_not_found qid = user_err ~hdr:"load_absolute_library_from" @@ -465,8 +464,8 @@ let rec intern_library (needed, contents) (dir, f) from = if not (DirPath.equal dir m.library_name) then user_err ~hdr:"load_physical_library" (str "The file " ++ str f ++ str " contains library" ++ spc () ++ - pr_dirpath m.library_name ++ spc () ++ str "and not library" ++ - spc() ++ pr_dirpath dir); + DirPath.print m.library_name ++ spc () ++ str "and not library" ++ + spc() ++ DirPath.print dir); Feedback.feedback (Feedback.FileLoaded(DirPath.to_string dir, f)); m.library_digests, intern_library_deps (needed, contents) dir m f @@ -477,9 +476,9 @@ and intern_library_deps libs dir m from = and intern_mandatory_library caller from libs (dir,d) = let digest, libs = intern_library libs (dir, None) (Some from) in if not (Safe_typing.digest_match ~actual:digest ~required:d) then - user_err (str "Compiled library " ++ pr_dirpath caller ++ + user_err (str "Compiled library " ++ DirPath.print caller ++ str " (in file " ++ str from ++ str ") makes inconsistent assumptions \ - over library " ++ pr_dirpath dir); + over library " ++ DirPath.print dir); libs let rec_intern_library libs (dir, f) = @@ -617,7 +616,7 @@ let check_coq_overwriting p id = let is_empty = match l with [] -> true | _ -> false in if not !Flags.boot && not is_empty && Id.equal (List.last l) coq_root then user_err - (str "Cannot build module " ++ pr_dirpath p ++ str "." ++ Id.print id ++ str "." ++ spc () ++ + (str "Cannot build module " ++ DirPath.print p ++ str "." ++ Id.print id ++ str "." ++ spc () ++ str "it starts with prefix \"Coq\" which is reserved for the Coq library.") let start_library fo = @@ -625,7 +624,7 @@ let start_library fo = try let lp = Loadpath.find_load_path (Filename.dirname fo) in Loadpath.logical lp - with Not_found -> Nameops.default_root_prefix + with Not_found -> Libnames.default_root_prefix in let file = Filename.chop_extension (Filename.basename fo) in let id = Id.of_string file in @@ -665,7 +664,7 @@ let current_reexports () = !libraries_exports_list let error_recursively_dependent_library dir = user_err - (strbrk "Unable to use logical name " ++ pr_dirpath dir ++ + (strbrk "Unable to use logical name " ++ DirPath.print dir ++ strbrk " to save current library because" ++ strbrk " it already depends on a library of this name.") diff --git a/library/library.mllib b/library/library.mllib index d94fc2291..e43bfb5a1 100644 --- a/library/library.mllib +++ b/library/library.mllib @@ -1,5 +1,3 @@ -Univops -Nameops Libnames Globnames Libobject diff --git a/library/loadpath.ml b/library/loadpath.ml index 757e972b1..eb6dae84a 100644 --- a/library/loadpath.ml +++ b/library/loadpath.ml @@ -54,8 +54,8 @@ let warn_overriding_logical_loadpath = CWarnings.create ~name:"overriding-logical-loadpath" ~category:"loadpath" (fun (phys_path, old_path, coq_path) -> str phys_path ++ strbrk " was previously bound to " ++ - pr_dirpath old_path ++ strbrk "; it is remapped to " ++ - pr_dirpath coq_path) + DirPath.print old_path ++ strbrk "; it is remapped to " ++ + DirPath.print coq_path) let add_load_path phys_path coq_path ~implicit = let phys_path = CUnix.canonical_path_name phys_path in @@ -75,7 +75,7 @@ let add_load_path phys_path coq_path ~implicit = else let () = (* Do not warn when overriding the default "-I ." path *) - if not (DirPath.equal old_path Nameops.default_root_prefix) then + if not (DirPath.equal old_path Libnames.default_root_prefix) then warn_overriding_logical_loadpath (phys_path, old_path, coq_path) in true in diff --git a/parsing/egramcoq.ml b/parsing/egramcoq.ml index 9504768a8..2cb7da569 100644 --- a/parsing/egramcoq.ml +++ b/parsing/egramcoq.ml @@ -442,7 +442,7 @@ let make_act : type r. r target -> _ -> r gen_eval = function CAst.make ~loc @@ CNotation (notation , env) | ForPattern -> fun notation loc env -> let invalid = List.exists (fun (_, b) -> not b) env.binders in - let () = if invalid then Topconstr.error_invalid_pattern_notation ~loc () in + let () = if invalid then Constrexpr_ops.error_invalid_pattern_notation ~loc () in let env = (env.constrs, env.constrlists) in CAst.make ~loc @@ CPatNotation (notation, env, []) diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index a5b58b855..a01ea26af 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -129,16 +129,10 @@ let test_plural_form_types loc kwd = function warn_plural_command ~loc:!@loc kwd | _ -> () -let fresh_var env c = - Namegen.next_ident_away (Id.of_string "pat") - (List.fold_left (fun accu id -> Id.Set.add id accu) (Topconstr.free_vars_of_constr_expr c) env) - -let _ = Hook.set Constrexpr_ops.fresh_var_hook fresh_var - (* Gallina declarations *) GEXTEND Gram GLOBAL: gallina gallina_ext thm_token def_body of_type_with_opt_coercion - record_field decl_notation rec_definition pidentref ident_decl; + record_field decl_notation rec_definition ident_decl; gallina: (* Definition, Theorem, Variable, Axiom, ... *) @@ -228,9 +222,6 @@ GEXTEND Gram [ [ l = universe_level; ord = [ "<" -> Univ.Lt | "=" -> Univ.Eq | "<=" -> Univ.Le ]; r = universe_level -> (l, ord, r) ] ] ; - pidentref: - [ [ i = identref; l = OPT [ "@{" ; l = LIST0 identref; "}" -> l ] -> (i,l) ] ] - ; univ_decl : [ [ "@{" ; l = LIST0 identref; ext = [ "+" -> true | -> false ]; cs = [ "|"; l' = LIST0 univ_constraint SEP ","; diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index d34da159e..8e6a01aa3 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -444,7 +444,6 @@ module Prim = let name = Gram.entry_create "Prim.name" let identref = Gram.entry_create "Prim.identref" - let pidentref = Gram.entry_create "Prim.pidentref" let ident_decl = Gram.entry_create "Prim.ident_decl" let pattern_ident = Gram.entry_create "pattern_ident" let pattern_identref = Gram.entry_create "pattern_identref" diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 2f0375419..d17ccb0b4 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -194,7 +194,6 @@ module Prim : val ident : Id.t Gram.entry val name : Name.t located Gram.entry val identref : Id.t located Gram.entry - val pidentref : (Id.t located * (Id.t located list) option) Gram.entry val ident_decl : ident_decl Gram.entry val pattern_ident : Id.t Gram.entry val pattern_identref : Id.t located Gram.entry diff --git a/plugins/btauto/refl_btauto.ml b/plugins/btauto/refl_btauto.ml index da8955f0d..a09abfa19 100644 --- a/plugins/btauto/refl_btauto.ml +++ b/plugins/btauto/refl_btauto.ml @@ -200,7 +200,8 @@ module Btauto = struct let assign = List.combine env var in let map_msg (key, v) = let b = if v then str "true" else str "false" in - let term = Printer.pr_constr key in + let sigma, env = Pfedit.get_current_context () in + let term = Printer.pr_constr_env env sigma key in term ++ spc () ++ str ":=" ++ spc () ++ b in let assign = List.map map_msg assign in diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml index faabd7c14..ccef9ab96 100644 --- a/plugins/cc/ccalgo.ml +++ b/plugins/cc/ccalgo.ml @@ -12,13 +12,13 @@ open CErrors open Pp -open Goptions open Names -open Term +open Sorts open Constr open Vars -open Tacmach open Evd +open Goptions +open Tacmach open Util let init_size=5 @@ -437,7 +437,7 @@ and make_app l=function and applist_proj c l = match c with | Symb s -> applist_projection s l - | _ -> applistc (constr_of_term c) l + | _ -> Term.applistc (constr_of_term c) l and applist_projection c l = match Constr.kind c with | Const c when Environ.is_projection (fst c) (Global.env()) -> @@ -447,10 +447,10 @@ and applist_projection c l = let ty = Typeops.type_of_constant_in (Global.env ()) c in (* FIXME constraints *) let pb = Environ.lookup_projection p (Global.env()) in let ctx,_ = Term.decompose_prod_n_assum (pb.Declarations.proj_npars + 1) ty in - it_mkLambda_or_LetIn (mkProj(p,mkRel 1)) ctx + Term.it_mkLambda_or_LetIn (mkProj(p,mkRel 1)) ctx | hd :: tl -> - applistc (mkProj (p, hd)) tl) - | _ -> applistc c l + Term.applistc (mkProj (p, hd)) tl) + | _ -> Term.applistc c l let rec canonize_name sigma c = let c = EConstr.Unsafe.to_constr c in @@ -838,7 +838,7 @@ let complete_one_class state i= let _args = List.map (fun i -> constr_of_term (term state.uf i)) pac.args in - let typ = prod_applist _c (List.rev _args) in + let typ = Term.prod_applist _c (List.rev _args) in let ct = app (term state.uf i) typ pac.arity in state.uf.epsilons <- pac :: state.uf.epsilons; ignore (add_term state ct) diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 7dec34d4d..8642df684 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -12,7 +12,6 @@ open Evd open Names open Inductiveops open Declarations -open Term open Constr open EConstr open Vars diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml index 995d5fd19..5903733a6 100644 --- a/plugins/extraction/table.ml +++ b/plugins/extraction/table.ml @@ -486,7 +486,7 @@ let check_loaded_modfile mp = match base_mp mp with if not (Library.library_is_loaded dp) then begin match base_mp (Lib.current_mp ()) with | MPfile dp' when not (DirPath.equal dp dp') -> - err (str "Please load library " ++ pr_dirpath dp ++ str " first.") + err (str "Please load library " ++ DirPath.print dp ++ str " first.") | _ -> () end | _ -> () diff --git a/plugins/firstorder/ground.ml b/plugins/firstorder/ground.ml index f660ba734..d46201335 100644 --- a/plugins/firstorder/ground.ml +++ b/plugins/firstorder/ground.ml @@ -11,7 +11,7 @@ open Formula open Sequent open Rules open Instances -open Term +open Constr open Tacmach.New open Tacticals.New diff --git a/plugins/firstorder/rules.ml b/plugins/firstorder/rules.ml index d6309b057..1a6eba8c6 100644 --- a/plugins/firstorder/rules.ml +++ b/plugins/firstorder/rules.ml @@ -235,8 +235,8 @@ let constant str = Universes.constr_of_global @@ Coqlib.coq_reference "User" ["Init";"Logic"] str let defined_connectives=lazy - [AllOccurrences,EvalConstRef (fst (Term.destConst (constant "not"))); - AllOccurrences,EvalConstRef (fst (Term.destConst (constant "iff")))] + [AllOccurrences,EvalConstRef (fst (Constr.destConst (constant "not"))); + AllOccurrences,EvalConstRef (fst (Constr.destConst (constant "iff")))] let normalize_evaluables= Proofview.Goal.enter begin fun gl -> diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index bd5fb1d92..62ca70626 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -1,7 +1,7 @@ open Printer open CErrors open Util -open Term +open Constr open EConstr open Vars open Namegen @@ -44,6 +44,10 @@ let observe_tac s tac g = observe_tac_stream (str s) tac g *) +let pr_leconstr_fp = + let sigma, env = Pfedit.get_current_context () in + Printer.pr_leconstr_env env sigma + let debug_queue = Stack.create () let rec print_debug_queue e = @@ -172,7 +176,7 @@ let is_incompatible_eq sigma t = | _ -> false with e when CErrors.noncritical e -> false in - if res then observe (str "is_incompatible_eq " ++ Printer.pr_leconstr t); + if res then observe (str "is_incompatible_eq " ++ pr_leconstr_fp t); res let change_hyp_with_using msg hyp_id t tac : tactic = @@ -220,7 +224,8 @@ let find_rectype env sigma c = let isAppConstruct ?(env=Global.env ()) sigma t = try let t',l = find_rectype env sigma t in - observe (str "isAppConstruct : " ++ Printer.pr_leconstr t ++ str " -> " ++ Printer.pr_leconstr (applist (t',l))); + observe (str "isAppConstruct : " ++ Printer.pr_leconstr_env env sigma t ++ str " -> " ++ + Printer.pr_leconstr_env env sigma (applist (t',l))); true with Not_found -> false @@ -233,7 +238,8 @@ exception NoChange let change_eq env sigma hyp_id (context:rel_context) x t end_of_type = let nochange ?t' msg = begin - observe (str ("Not treating ( "^msg^" )") ++ pr_leconstr t ++ str " " ++ match t' with None -> str "" | Some t -> Printer.pr_leconstr t ); + observe (str ("Not treating ( "^msg^" )") ++ pr_leconstr_env env sigma t ++ str " " ++ + match t' with None -> str "" | Some t -> Printer.pr_leconstr_env env sigma t ); raise NoChange; end in @@ -841,7 +847,7 @@ let build_proof | Rel _ -> anomaly (Pp.str "Free var in goal conclusion!") and build_proof do_finalize dyn_infos g = (* observe (str "proving with "++Printer.pr_lconstr dyn_infos.info++ str " on goal " ++ pr_gls g); *) - observe_tac_stream (str "build_proof with " ++ Printer.pr_leconstr dyn_infos.info ) (build_proof_aux do_finalize dyn_infos) g + observe_tac_stream (str "build_proof with " ++ pr_leconstr_fp dyn_infos.info ) (build_proof_aux do_finalize dyn_infos) g and build_proof_args do_finalize dyn_infos (* f_args' args *) :tactic = fun g -> let (f_args',args) = dyn_infos.info in @@ -1135,7 +1141,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam princ_params ); observe (str "fbody_with_full_params := " ++ - pr_leconstr fbody_with_full_params + pr_leconstr_env (Global.env ()) !evd fbody_with_full_params ); let all_funs_with_full_params = Array.map (fun f -> applist(f, List.rev_map var_of_decl full_params)) all_funs diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index 722dbc16b..996e2b6af 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -1,7 +1,8 @@ open Printer open CErrors -open Util open Term +open Sorts +open Util open Constr open Vars open Namegen @@ -115,7 +116,9 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = let dummy_var = mkVar (Id.of_string "________") in let mk_replacement c i args = let res = mkApp(rel_to_fun.(i), Array.map pop (array_get_start args)) in - observe (str "replacing " ++ pr_lconstr c ++ str " by " ++ pr_lconstr res); + observe (str "replacing " ++ + pr_lconstr_env env Evd.empty c ++ str " by " ++ + pr_lconstr_env env Evd.empty res); res in let rec compute_new_princ_type remove env pre_princ : types*(constr list) = @@ -565,7 +568,7 @@ let make_scheme evd (fas : (pconstant*Sorts.family) list) : Safe_typing.private_ List.map (* we can now compute the other principles *) (fun scheme_type -> incr i; - observe (Printer.pr_lconstr scheme_type); + observe (Printer.pr_lconstr_env env sigma scheme_type); let type_concl = (strip_prod_assum scheme_type) in let applied_f = List.hd (List.rev (snd (decompose_app type_concl))) in let f = fst (decompose_app applied_f) in @@ -577,8 +580,8 @@ let make_scheme evd (fas : (pconstant*Sorts.family) list) : Safe_typing.private_ let g = fst (decompose_app applied_g) in if Constr.equal f g then raise (Found_type j); - observe (Printer.pr_lconstr f ++ str " <> " ++ - Printer.pr_lconstr g) + observe (Printer.pr_lconstr_env env sigma f ++ str " <> " ++ + Printer.pr_lconstr_env env sigma g) ) ta; diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 8ab6dbcdf..fa4353630 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -1,7 +1,6 @@ open Printer open Pp open Names -open Term open Constr open Vars open Glob_term @@ -379,29 +378,30 @@ let add_pat_variables pat typ env : Environ.env = fst ( Context.Rel.fold_outside (fun decl (env,ctxt) -> - let open Context.Rel.Declaration in - match decl with + let open Context.Rel.Declaration in + let sigma, _ = Pfedit.get_current_context () in + match decl with | LocalAssum (Anonymous,_) | LocalDef (Anonymous,_,_) -> assert false | LocalAssum (Name id, t) -> - let new_t = substl ctxt t in - observe (str "for variable " ++ Ppconstr.pr_id id ++ fnl () ++ - str "old type := " ++ Printer.pr_lconstr t ++ fnl () ++ - str "new type := " ++ Printer.pr_lconstr new_t ++ fnl () - ); - let open Context.Named.Declaration in - (Environ.push_named (LocalAssum (id,new_t)) env,mkVar id::ctxt) - | LocalDef (Name id, v, t) -> - let new_t = substl ctxt t in - let new_v = substl ctxt v in - observe (str "for variable " ++ Ppconstr.pr_id id ++ fnl () ++ - str "old type := " ++ Printer.pr_lconstr t ++ fnl () ++ - str "new type := " ++ Printer.pr_lconstr new_t ++ fnl () ++ - str "old value := " ++ Printer.pr_lconstr v ++ fnl () ++ - str "new value := " ++ Printer.pr_lconstr new_v ++ fnl () - ); - let open Context.Named.Declaration in - (Environ.push_named (LocalDef (id,new_v,new_t)) env,mkVar id::ctxt) - ) + let new_t = substl ctxt t in + observe (str "for variable " ++ Ppconstr.pr_id id ++ fnl () ++ + str "old type := " ++ Printer.pr_lconstr_env env sigma t ++ fnl () ++ + str "new type := " ++ Printer.pr_lconstr_env env sigma new_t ++ fnl () + ); + let open Context.Named.Declaration in + (Environ.push_named (LocalAssum (id,new_t)) env,mkVar id::ctxt) + | LocalDef (Name id, v, t) -> + let new_t = substl ctxt t in + let new_v = substl ctxt v in + observe (str "for variable " ++ Ppconstr.pr_id id ++ fnl () ++ + str "old type := " ++ Printer.pr_lconstr_env env sigma t ++ fnl () ++ + str "new type := " ++ Printer.pr_lconstr_env env sigma new_t ++ fnl () ++ + str "old value := " ++ Printer.pr_lconstr_env env sigma v ++ fnl () ++ + str "new value := " ++ Printer.pr_lconstr_env env sigma new_v ++ fnl () + ); + let open Context.Named.Declaration in + (Environ.push_named (LocalDef (id,new_v,new_t)) env,mkVar id::ctxt) + ) (Environ.rel_context new_env) ~init:(env,[]) ) @@ -479,7 +479,7 @@ let rec pattern_to_term_and_type env typ = DAst.with_val (function let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = - observe (str " Entering : " ++ Printer.pr_glob_constr rt); + observe (str " Entering : " ++ Printer.pr_glob_constr_env env rt); let open CAst in match DAst.get rt with | GRef _ | GVar _ | GEvar _ | GPatVar _ | GSort _ | GHole _ -> @@ -652,8 +652,8 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = try Inductiveops.find_inductive env (Evd.from_env env) b_typ with Not_found -> user_err (str "Cannot find the inductive associated to " ++ - Printer.pr_glob_constr b ++ str " in " ++ - Printer.pr_glob_constr rt ++ str ". try again with a cast") + Printer.pr_glob_constr_env env b ++ str " in " ++ + Printer.pr_glob_constr_env env rt ++ str ". try again with a cast") in let case_pats = build_constructors_of_type (fst ind) [] in assert (Int.equal (Array.length case_pats) 2); @@ -684,8 +684,8 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = try Inductiveops.find_inductive env (Evd.from_env env) b_typ with Not_found -> user_err (str "Cannot find the inductive associated to " ++ - Printer.pr_glob_constr b ++ str " in " ++ - Printer.pr_glob_constr rt ++ str ". try again with a cast") + Printer.pr_glob_constr_env env b ++ str " in " ++ + Printer.pr_glob_constr_env env rt ++ str ". try again with a cast") in let case_pats = build_constructors_of_type (fst ind) nal_as_glob_constr in assert (Int.equal (Array.length case_pats) 1); @@ -897,24 +897,24 @@ let same_raw_term rt1 rt2 = | GHole _, GHole _ -> true | _ -> false let decompose_raw_eq lhs rhs = - let rec decompose_raw_eq lhs rhs acc = - observe (str "decomposing eq for " ++ pr_glob_constr lhs ++ str " " ++ pr_glob_constr rhs); - let (rhd,lrhs) = glob_decompose_app rhs in - let (lhd,llhs) = glob_decompose_app lhs in - observe (str "lhd := " ++ pr_glob_constr lhd); - observe (str "rhd := " ++ pr_glob_constr rhd); + let _, env = Pfedit.get_current_context () in + let rec decompose_raw_eq lhs rhs acc = + observe (str "decomposing eq for " ++ pr_glob_constr_env env lhs ++ str " " ++ pr_glob_constr_env env rhs); + let (rhd,lrhs) = glob_decompose_app rhs in + let (lhd,llhs) = glob_decompose_app lhs in + observe (str "lhd := " ++ pr_glob_constr_env env lhd); + observe (str "rhd := " ++ pr_glob_constr_env env rhd); observe (str "llhs := " ++ int (List.length llhs)); observe (str "lrhs := " ++ int (List.length lrhs)); - let sllhs = List.length llhs in - let slrhs = List.length lrhs in - if same_raw_term lhd rhd && Int.equal sllhs slrhs + let sllhs = List.length llhs in + let slrhs = List.length lrhs in + if same_raw_term lhd rhd && Int.equal sllhs slrhs then (* let _ = assert false in *) List.fold_right2 decompose_raw_eq llhs lrhs acc else (lhs,rhs)::acc in decompose_raw_eq lhs rhs [] - exception Continue (* @@ -923,7 +923,7 @@ exception Continue eliminates some meaningless equalities, applies some rewrites...... *) let rec rebuild_cons env nb_args relname args crossed_types depth rt = - observe (str "rebuilding : " ++ pr_glob_constr rt); + observe (str "rebuilding : " ++ pr_glob_constr_env env rt); let open Context.Rel.Declaration in let open CAst in match DAst.get rt with @@ -967,7 +967,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = let id = match DAst.get id with GVar id -> id | _ -> assert false in begin try - observe (str "computing new type for eq : " ++ pr_glob_constr rt); + observe (str "computing new type for eq : " ++ pr_glob_constr_env env rt); let t' = try fst (Pretyping.understand env (Evd.from_env env) t)(*FIXME*) with e when CErrors.noncritical e -> raise Continue @@ -1012,7 +1012,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = let eq' = DAst.make ?loc:loc1 @@ GApp(DAst.make ?loc:loc2 @@GRef(jmeq,None),[ty;DAst.make ?loc:loc3 @@ GVar id;rt_typ;rt]) in - observe (str "computing new type for jmeq : " ++ pr_glob_constr eq'); + observe (str "computing new type for jmeq : " ++ pr_glob_constr_env env eq'); let eq'_as_constr,ctx = Pretyping.understand env (Evd.from_env env) eq' in observe (str " computing new type for jmeq : done") ; let new_args = @@ -1099,7 +1099,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = rebuild_cons env nb_args relname args crossed_types depth new_rt else raise Continue with Continue -> - observe (str "computing new type for prod : " ++ pr_glob_constr rt); + observe (str "computing new type for prod : " ++ pr_glob_constr_env env rt); let t',ctx = Pretyping.understand env (Evd.from_env env) t in let new_env = Environ.push_rel (LocalAssum (n,t')) env in let new_b,id_to_exclude = @@ -1115,7 +1115,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = | _ -> mkGProd(n,t,new_b),Id.Set.filter not_free_in_t id_to_exclude end | _ -> - observe (str "computing new type for prod : " ++ pr_glob_constr rt); + observe (str "computing new type for prod : " ++ pr_glob_constr_env env rt); let t',ctx = Pretyping.understand env (Evd.from_env env) t in let new_env = Environ.push_rel (LocalAssum (n,t')) env in let new_b,id_to_exclude = @@ -1134,7 +1134,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = begin let not_free_in_t id = not (is_free_in id t) in let new_crossed_types = t :: crossed_types in - observe (str "computing new type for lambda : " ++ pr_glob_constr rt); + observe (str "computing new type for lambda : " ++ pr_glob_constr_env env rt); let t',ctx = Pretyping.understand env (Evd.from_env env) t in match n with | Name id -> diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index dab094f91..9e22ad306 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -1,7 +1,8 @@ open CErrors +open Sorts open Util open Names -open Term +open Constr open EConstr open Pp open Indfun_common @@ -46,7 +47,7 @@ let functional_induction with_clean c princl pat = try find_Function_infos c' with Not_found -> user_err (str "Cannot find induction information on "++ - Printer.pr_leconstr (mkConst c') ) + Printer.pr_leconstr_env (Tacmach.pf_env g) sigma (mkConst c') ) in match Tacticals.elimination_sort_of_goal g with | InProp -> finfo.prop_lemma @@ -74,7 +75,7 @@ let functional_induction with_clean c princl pat = (* mkConst(const_of_id princ_name ),g (\* FIXME *\) *) with Not_found -> (* This one is neither defined ! *) user_err (str "Cannot find induction principle for " - ++Printer.pr_leconstr (mkConst c') ) + ++ Printer.pr_leconstr_env (Tacmach.pf_env g) sigma (mkConst c') ) in let princ = EConstr.of_constr princ in (princ,NoBindings,Tacmach.pf_unsafe_type_of g' princ,g') @@ -841,12 +842,13 @@ let rec get_args b t : Constrexpr.local_binder_expr list * let make_graph (f_ref:global_reference) = let c,c_body = match f_ref with - | ConstRef c -> - begin try c,Global.lookup_constant c - with Not_found -> - raise (UserError (None,str "Cannot find " ++ Printer.pr_leconstr (mkConst c)) ) - end - | _ -> raise (UserError (None, str "Not a function reference") ) + | ConstRef c -> + begin try c,Global.lookup_constant c + with Not_found -> + let sigma, env = Pfedit.get_current_context () in + raise (UserError (None,str "Cannot find " ++ Printer.pr_leconstr_env env sigma (mkConst c)) ) + end + | _ -> raise (UserError (None, str "Not a function reference") ) in (match Global.body_of_constant_body c_body with | None -> error "Cannot build a graph over an axiom!" diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index 61d207b95..8bf6e48fd 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -333,15 +333,17 @@ let discharge_Function (_,finfos) = } let pr_ocst c = - Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) c (mt ()) + let sigma, env = Pfedit.get_current_context () in + Option.fold_right (fun v acc -> Printer.pr_lconstr_env env sigma (mkConst v)) c (mt ()) let pr_info f_info = + let sigma, env = Pfedit.get_current_context () in str "function_constant := " ++ - Printer.pr_lconstr (mkConst f_info.function_constant)++ fnl () ++ + Printer.pr_lconstr_env env sigma (mkConst f_info.function_constant)++ fnl () ++ str "function_constant_type := " ++ (try - Printer.pr_lconstr - (fst (Global.type_of_global_in_context (Global.env ()) (ConstRef f_info.function_constant))) + Printer.pr_lconstr_env env sigma + (fst (Global.type_of_global_in_context env (ConstRef f_info.function_constant))) with e when CErrors.noncritical e -> mt ()) ++ fnl () ++ str "equation_lemma := " ++ pr_ocst f_info.equation_lemma ++ fnl () ++ str "completeness_lemma :=" ++ pr_ocst f_info.completeness_lemma ++ fnl () ++ @@ -349,7 +351,7 @@ let pr_info f_info = str "rect_lemma := " ++ pr_ocst f_info.rect_lemma ++ fnl () ++ str "rec_lemma := " ++ pr_ocst f_info.rec_lemma ++ fnl () ++ str "prop_lemma := " ++ pr_ocst f_info.prop_lemma ++ fnl () ++ - str "graph_ind := " ++ Printer.pr_lconstr (mkInd f_info.graph_ind) ++ fnl () + str "graph_ind := " ++ Printer.pr_lconstr_env env sigma (mkInd f_info.graph_ind) ++ fnl () let pr_table tb = let l = Cmap_env.fold (fun k v acc -> v::acc) tb [] in diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index 692a874d3..694c80051 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -851,7 +851,7 @@ let derive_correctness make_scheme functional_induction (funs: pconstant list) ( EConstr.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt in let type_of_lemma = nf_zeta type_of_lemma in - observe (str "type_of_lemma := " ++ Printer.pr_leconstr type_of_lemma); + observe (str "type_of_lemma := " ++ Printer.pr_leconstr_env env !evd type_of_lemma); type_of_lemma,type_info ) funs_constr diff --git a/plugins/funind/merge.ml b/plugins/funind/merge.ml index b372241d2..9e2774ff3 100644 --- a/plugins/funind/merge.ml +++ b/plugins/funind/merge.ml @@ -90,20 +90,28 @@ let next_ident_fresh (id:Id.t) = (* comment this line to see debug msgs *) let msg x = () ;; let pr_lconstr c = str "" (* uncomment this to see debugging *) -let prconstr c = msg (str" " ++ Printer.pr_lconstr c) -let prconstrnl c = msg (str" " ++ Printer.pr_lconstr c ++ str"\n") +let prconstr c = + let sigma, env = Pfedit.get_current_context () in + msg (str" " ++ Printer.pr_lconstr_env env sigma c) + +let prconstrnl c = + let sigma, env = Pfedit.get_current_context () in + msg (str" " ++ Printer.pr_lconstr_env env sigma c ++ str"\n") + let prlistconstr lc = List.iter prconstr lc let prstr s = msg(str s) let prNamedConstr s c = + let sigma, env = Pfedit.get_current_context () in begin msg(str ""); - msg(str(s^" {§ ") ++ Printer.pr_lconstr c ++ str " §} "); + msg(str(s^" {§ ") ++ Printer.pr_lconstr_env env sigma c ++ str " §} "); msg(str ""); end let prNamedRConstr s c = + let sigma, env = Pfedit.get_current_context () in begin msg(str ""); - msg(str(s^" {§ ") ++ Printer.pr_glob_constr c ++ str " §} "); + msg(str(s^" {§ ") ++ Printer.pr_glob_constr_env env c ++ str " §} "); msg(str ""); end let prNamedLConstr_aux lc = List.iter (prNamedConstr "\n") lc diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 2fdc3bc37..3089ec470 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -9,7 +9,6 @@ module CVars = Vars -open Term open Constr open EConstr open Vars @@ -54,6 +53,10 @@ let coq_constant m s = EConstr.of_constr @@ Universes.constr_of_global @@ let arith_Nat = ["Arith";"PeanoNat";"Nat"] let arith_Lt = ["Arith";"Lt"] +let pr_leconstr_rd = + let sigma, env = Pfedit.get_current_context () in + Printer.pr_leconstr_env env sigma + let coq_init_constant s = EConstr.of_constr ( Universes.constr_of_global @@ @@ -337,7 +340,8 @@ let check_not_nested sigma forbidden e = try check_not_nested e with UserError(_,p) -> - user_err ~hdr:"_" (str "on expr : " ++ Printer.pr_leconstr e ++ str " " ++ p) + let _, env = Pfedit.get_current_context () in + user_err ~hdr:"_" (str "on expr : " ++ Printer.pr_leconstr_env env sigma e ++ str " " ++ p) (* ['a info] contains the local information for traveling *) type 'a infos = @@ -455,7 +459,7 @@ let rec travel_aux jinfo continuation_tac (expr_info:constr infos) g = check_not_nested sigma (expr_info.f_id::expr_info.forbidden_ids) expr_info.info; jinfo.otherS () expr_info continuation_tac expr_info g with e when CErrors.noncritical e -> - user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr expr_info.info ++ str " can not contain a recursive call to " ++ Id.print expr_info.f_id) + user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr_env (pf_env g) sigma expr_info.info ++ str " can not contain a recursive call to " ++ Id.print expr_info.f_id) end | Lambda(n,t,b) -> begin @@ -463,7 +467,7 @@ let rec travel_aux jinfo continuation_tac (expr_info:constr infos) g = check_not_nested sigma (expr_info.f_id::expr_info.forbidden_ids) expr_info.info; jinfo.otherS () expr_info continuation_tac expr_info g with e when CErrors.noncritical e -> - user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr expr_info.info ++ str " can not contain a recursive call to " ++ Id.print expr_info.f_id) + user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr_env (pf_env g) sigma expr_info.info ++ str " can not contain a recursive call to " ++ Id.print expr_info.f_id) end | Case(ci,t,a,l) -> begin @@ -491,8 +495,8 @@ let rec travel_aux jinfo continuation_tac (expr_info:constr infos) g = jinfo.apP (f,args) expr_info continuation_tac in travel_args jinfo expr_info.is_main_branch new_continuation_tac new_infos g - | Case _ -> user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr expr_info.info ++ str " can not contain an applied match (See Limitation in Section 2.3 of refman)") - | _ -> anomaly (Pp.str "travel_aux : unexpected "++ Printer.pr_leconstr expr_info.info ++ Pp.str ".") + | Case _ -> user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr_env (pf_env g) sigma expr_info.info ++ str " can not contain an applied match (See Limitation in Section 2.3 of refman)") + | _ -> anomaly (Pp.str "travel_aux : unexpected "++ Printer.pr_leconstr_env (pf_env g) sigma expr_info.info ++ Pp.str ".") end | Cast(t,_,_) -> travel jinfo continuation_tac {expr_info with info=t} g | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ -> @@ -515,7 +519,7 @@ and travel_args jinfo is_final continuation_tac infos = {infos with info=arg;is_final=false} and travel jinfo continuation_tac expr_info = observe_tac - (str jinfo.message ++ Printer.pr_leconstr expr_info.info) + (str jinfo.message ++ pr_leconstr_rd expr_info.info) (travel_aux jinfo continuation_tac expr_info) (* Termination proof *) @@ -731,7 +735,7 @@ let terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos g = let destruct_tac,rev_to_thin_intro = mkDestructEq [expr_info.rec_arg_id] a' g in let to_thin_intro = List.rev rev_to_thin_intro in - observe_tac (str "treating cases (" ++ int (Array.length l) ++ str")" ++ spc () ++ Printer.pr_leconstr a') + observe_tac (str "treating cases (" ++ int (Array.length l) ++ str")" ++ spc () ++ Printer.pr_leconstr_env (pf_env g) sigma a') (try (tclTHENS destruct_tac @@ -740,7 +744,7 @@ let terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos g = with | UserError(Some "Refiner.thensn_tac3",_) | UserError(Some "Refiner.tclFAIL_s",_) -> - (observe_tac (str "is computable " ++ Printer.pr_leconstr new_info.info) (next_step continuation_tac {new_info with info = nf_betaiotazeta new_info.info} ) + (observe_tac (str "is computable " ++ Printer.pr_leconstr_env (pf_env g) sigma new_info.info) (next_step continuation_tac {new_info with info = nf_betaiotazeta new_info.info} ) )) g @@ -991,11 +995,11 @@ let rec intros_values_eq expr_info acc = let equation_others _ expr_info continuation_tac infos = if expr_info.is_final && expr_info.is_main_branch then - observe_tac (str "equation_others (cont_tac +intros) " ++ Printer.pr_leconstr expr_info.info) + observe_tac (str "equation_others (cont_tac +intros) " ++ pr_leconstr_rd expr_info.info) (tclTHEN (continuation_tac infos) - (observe_tac (str "intros_values_eq equation_others " ++ Printer.pr_leconstr expr_info.info) (intros_values_eq expr_info []))) - else observe_tac (str "equation_others (cont_tac) " ++ Printer.pr_leconstr expr_info.info) (continuation_tac infos) + (observe_tac (str "intros_values_eq equation_others " ++ pr_leconstr_rd expr_info.info) (intros_values_eq expr_info []))) + else observe_tac (str "equation_others (cont_tac) " ++ pr_leconstr_rd expr_info.info) (continuation_tac infos) let equation_app f_and_args expr_info continuation_tac infos = if expr_info.is_final && expr_info.is_main_branch @@ -1225,8 +1229,8 @@ let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_a let get_current_subgoals_types () = let p = Proof_global.give_me_the_proof () in - let { Evd.it=sgs ; sigma=sigma } = Proof.V82.subgoals p in - sigma, List.map (Goal.V82.abstract_type sigma) sgs + let sgs,_,_,_,sigma = Proof.proof p in + sigma, List.map (Goal.V82.abstract_type sigma) sgs exception EmptySubgoals let build_and_l sigma l = @@ -1419,7 +1423,7 @@ let com_terminate nb_args ctx hook = let start_proof ctx (tac_start:tactic) (tac_end:tactic) = - let (evmap, env) = Lemmas.get_current_context() in + let evmap, env = Pfedit.get_current_context () in Lemmas.start_proof thm_name (Global, false (* FIXME *), Proof Lemma) ~sign:(Environ.named_context_val env) ctx (EConstr.of_constr (compute_terminate_type nb_args fonctional_ref)) hook; @@ -1471,7 +1475,7 @@ let (com_eqn : int -> Id.t -> | ConstRef c -> is_opaque_constant c | _ -> anomaly ~label:"terminate_lemma" (Pp.str "not a constant.") in - let (evmap, env) = Lemmas.get_current_context() in + let evmap, env = Pfedit.get_current_context () in let evmap = Evd.from_ctx (Evd.evar_universe_context evmap) in let f_constr = constr_of_global f_ref in let equation_lemma_type = subst1 f_constr equation_lemma_type in diff --git a/plugins/ltac/extraargs.ml4 b/plugins/ltac/extraargs.ml4 index 89feea8dc..bb01aca55 100644 --- a/plugins/ltac/extraargs.ml4 +++ b/plugins/ltac/extraargs.ml4 @@ -133,7 +133,9 @@ let pr_occurrences = pr_occurrences () () () let pr_gen prc _prlc _prtac c = prc c -let pr_globc _prc _prlc _prtac (_,glob) = Printer.pr_glob_constr glob +let pr_globc _prc _prlc _prtac (_,glob) = + let _, env = Pfedit.get_current_context () in + Printer.pr_glob_constr_env env glob let interp_glob ist gl (t,_) = Tacmach.project gl , (ist,t) diff --git a/plugins/ltac/extratactics.ml4 b/plugins/ltac/extratactics.ml4 index 4b1555e55..71db919ef 100644 --- a/plugins/ltac/extratactics.ml4 +++ b/plugins/ltac/extratactics.ml4 @@ -315,7 +315,8 @@ let project_hint pri l2r r = in let ctx = Evd.universe_context_set sigma in let c = EConstr.to_constr sigma c in - let c = Declare.declare_definition ~internal:Declare.InternalTacticRequest id (c,ctx) in + let poly = Flags.use_polymorphic_flag () in + let c = Declare.declare_definition ~poly ~internal:Declare.InternalTacticRequest id (c,ctx) in let info = {Vernacexpr.hint_priority = pri; hint_pattern = None} in (info,false,true,Hints.PathAny, Hints.IsGlobRef (Globnames.ConstRef c)) diff --git a/plugins/ltac/g_auto.ml4 b/plugins/ltac/g_auto.ml4 index 5baa0d5c1..84e79d8ab 100644 --- a/plugins/ltac/g_auto.ml4 +++ b/plugins/ltac/g_auto.ml4 @@ -51,8 +51,12 @@ let eval_uconstrs ist cs = List.map (fun c -> map (Tacinterp.type_uconstr ~flags ist c)) cs let pr_auto_using_raw _ _ _ = Pptactic.pr_auto_using Ppconstr.pr_constr_expr -let pr_auto_using_glob _ _ _ = Pptactic.pr_auto_using (fun (c,_) -> Printer.pr_glob_constr c) -let pr_auto_using _ _ _ = Pptactic.pr_auto_using Printer.pr_closed_glob +let pr_auto_using_glob _ _ _ = Pptactic.pr_auto_using (fun (c,_) -> + let _, env = Pfedit.get_current_context () in + Printer.pr_glob_constr_env env c) +let pr_auto_using _ _ _ = Pptactic.pr_auto_using + (let sigma, env = Pfedit.get_current_context () in + Printer.pr_closed_glob_env env sigma) ARGUMENT EXTEND auto_using TYPED AS uconstr_list diff --git a/plugins/ltac/g_rewrite.ml4 b/plugins/ltac/g_rewrite.ml4 index b148d962e..91abe1019 100644 --- a/plugins/ltac/g_rewrite.ml4 +++ b/plugins/ltac/g_rewrite.ml4 @@ -31,8 +31,12 @@ type constr_expr_with_bindings = constr_expr with_bindings type glob_constr_with_bindings = Tacexpr.glob_constr_and_expr with_bindings type glob_constr_with_bindings_sign = interp_sign * Tacexpr.glob_constr_and_expr with_bindings -let pr_glob_constr_with_bindings_sign _ _ _ (ge : glob_constr_with_bindings_sign) = Printer.pr_glob_constr (fst (fst (snd ge))) -let pr_glob_constr_with_bindings _ _ _ (ge : glob_constr_with_bindings) = Printer.pr_glob_constr (fst (fst ge)) +let pr_glob_constr_with_bindings_sign _ _ _ (ge : glob_constr_with_bindings_sign) = + let _, env = Pfedit.get_current_context () in + Printer.pr_glob_constr_env env (fst (fst (snd ge))) +let pr_glob_constr_with_bindings _ _ _ (ge : glob_constr_with_bindings) = + let _, env = Pfedit.get_current_context () in + Printer.pr_glob_constr_env env (fst (fst ge)) let pr_constr_expr_with_bindings prc _ _ (ge : constr_expr_with_bindings) = prc (fst ge) let interp_glob_constr_with_bindings ist gl c = Tacmach.project gl , (ist, c) let glob_glob_constr_with_bindings ist l = Tacintern.intern_constr_with_bindings ist l @@ -272,5 +276,7 @@ TACTIC EXTEND setoid_transitivity END VERNAC COMMAND EXTEND PrintRewriteHintDb CLASSIFIED AS QUERY - [ "Print" "Rewrite" "HintDb" preident(s) ] -> [ Feedback.msg_notice (Autorewrite.print_rewrite_hintdb s) ] + [ "Print" "Rewrite" "HintDb" preident(s) ] -> + [ let sigma, env = Pfedit.get_current_context () in + Feedback.msg_notice (Autorewrite.print_rewrite_hintdb env sigma s) ] END diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index 38460c669..d70751245 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -84,6 +84,14 @@ type 'a extra_genarg_printer = (tolerability -> Val.t -> Pp.t) -> 'a -> Pp.t +let string_of_genarg_arg (ArgumentType arg) = + let rec aux : type a b c. (a, b, c) genarg_type -> string = function + | ListArg t -> aux t ^ "_list" + | OptArg t -> aux t ^ "_opt" + | PairArg (t1, t2) -> assert false (* No parsing/printing rule for it *) + | ExtraArg s -> ArgT.repr s in + aux arg + let keyword x = tag_keyword (str x) let primitive x = tag_primitive (str x) @@ -536,15 +544,24 @@ let pr_goal_selector ~toplevel s = let pr_funvar n = spc () ++ Name.print n - let pr_let_clause k pr (na,(bl,t)) = + let pr_let_clause k pr_gen pr_arg (na,(bl,t)) = + let pr = function + | TacGeneric arg -> + let name = string_of_genarg_arg (genarg_tag arg) in + if name = "unit" || name = "int" then + (* Hard-wired parsing rules *) + pr_gen arg + else + str name ++ str ":" ++ surround (pr_gen arg) + | _ -> pr_arg (TacArg (Loc.tag t)) in hov 0 (keyword k ++ spc () ++ pr_lname na ++ prlist pr_funvar bl ++ - str " :=" ++ brk (1,1) ++ pr (TacArg (Loc.tag t))) + str " :=" ++ brk (1,1) ++ pr t) - let pr_let_clauses recflag pr = function + let pr_let_clauses recflag pr_gen pr = function | hd::tl -> hv 0 - (pr_let_clause (if recflag then "let rec" else "let") pr hd ++ - prlist (fun t -> spc () ++ pr_let_clause "with" pr t) tl) + (pr_let_clause (if recflag then "let rec" else "let") pr_gen pr hd ++ + prlist (fun t -> spc () ++ pr_let_clause "with" pr_gen pr t) tl) | [] -> anomaly (Pp.str "LetIn must declare at least one binding.") let pr_seq_body pr tl = @@ -858,7 +875,7 @@ let pr_goal_selector ~toplevel s = let llc = List.map (fun (id,t) -> (id,extract_binders t)) llc in v 0 (hv 0 ( - pr_let_clauses recflag (pr_tac ltop) llc + pr_let_clauses recflag pr.pr_generic (pr_tac ltop) llc ++ spc () ++ keyword "in" ) ++ fnl () ++ pr_tac (llet,E) u), llet @@ -1003,7 +1020,7 @@ let pr_goal_selector ~toplevel s = | TacAtom (loc,t) -> pr_with_comments ?loc (hov 1 (pr_atom pr strip_prod_binders tag_atom t)), ltatom | TacArg(_,Tacexp e) -> - pr.pr_tactic (latom,E) e, latom + pr_tac inherited e, latom | TacArg(_,ConstrMayEval (ConstrTerm c)) -> keyword "constr:" ++ pr.pr_constr c, latom | TacArg(_,ConstrMayEval c) -> @@ -1226,6 +1243,15 @@ let make_constr_printer f c = let lift f a = Genprint.PrinterBasic (fun () -> f a) + +let pr_glob_constr_pptac c = + let _, env = Pfedit.get_current_context () in + pr_glob_constr_env env c + +let pr_lglob_constr_pptac c = + let _, env = Pfedit.get_current_context () in + pr_lglob_constr_env env c + let () = let pr_bool b = if b then str "true" else str "false" in let pr_unit _ = str "()" in @@ -1240,7 +1266,7 @@ let () = 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_glob_constr_pptac c)) pr_intro_pattern_env; Genprint.register_print0 wit_clause_dft_concl @@ -1251,45 +1277,45 @@ let () = Genprint.register_print0 wit_constr Ppconstr.pr_constr_expr - (fun (c, _) -> Printer.pr_glob_constr c) + (fun (c, _) -> pr_glob_constr_pptac c) (make_constr_printer Printer.pr_econstr_n_env) ; Genprint.register_print0 wit_uconstr Ppconstr.pr_constr_expr - (fun (c,_) -> Printer.pr_glob_constr c) + (fun (c, _) -> pr_glob_constr_pptac c) (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) + (fun (c, _) -> pr_glob_constr_pptac c) (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_and_constr_expr pr_glob_constr_pptac, pr_and_constr_expr pr_lglob_constr_pptac, pr_or_var (pr_and_short_name pr_evaluable_reference), pr_pat_and_constr_expr pr_glob_constr_pptac)) 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)) + (Miscprint.pr_bindings_no_with (pr_and_constr_expr pr_glob_constr_pptac) (pr_and_constr_expr pr_lglob_constr_pptac)) 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)) + (pr_with_bindings (pr_and_constr_expr pr_glob_constr_pptac) (pr_and_constr_expr pr_lglob_constr_pptac)) 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 (pr_and_constr_expr pr_glob_constr_pptac) (pr_and_constr_expr pr_lglob_constr_pptac)) 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)) + (pr_destruction_arg (pr_and_constr_expr pr_glob_constr_pptac) (pr_and_constr_expr pr_lglob_constr_pptac)) pr_destruction_arg_env ; Genprint.register_print0 Stdarg.wit_int int int (lift int); diff --git a/plugins/ltac/tacsubst.ml b/plugins/ltac/tacsubst.ml index 180fb2db4..918d1faeb 100644 --- a/plugins/ltac/tacsubst.ml +++ b/plugins/ltac/tacsubst.ml @@ -91,9 +91,10 @@ let subst_global_reference subst = let subst_global ref = let ref',t' = subst_global subst ref in if not (is_global ref' t') then - Feedback.msg_warning (strbrk "The reference " ++ pr_global ref ++ str " is not " ++ - str " expanded to \"" ++ pr_lconstr t' ++ str "\", but to " ++ - pr_global ref') ; + (let sigma, env = Pfedit.get_current_context () in + Feedback.msg_warning (strbrk "The reference " ++ pr_global ref ++ str " is not " ++ + str " expanded to \"" ++ pr_lconstr_env env sigma t' ++ str "\", but to " ++ + pr_global ref')); ref' in subst_or_var (subst_located subst_global) diff --git a/plugins/ltac/tactic_debug.ml b/plugins/ltac/tactic_debug.ml index a669692fc..2dd7c9a74 100644 --- a/plugins/ltac/tactic_debug.ml +++ b/plugins/ltac/tactic_debug.ml @@ -20,7 +20,9 @@ let prmatchpatt env sigma hyp = Pptactic.pr_match_pattern (Printer.pr_constr_pattern_env env sigma) hyp let prmatchrl rl = Pptactic.pr_match_rule false (Pptactic.pr_glob_tactic (Global.env())) - (fun (_,p) -> Printer.pr_constr_pattern p) rl + (fun (_,p) -> + let sigma, env = Pfedit.get_current_context () in + Printer.pr_constr_pattern_env env sigma p) rl (* This module intends to be a beginning of debugger for tactic expressions. Currently, it is quite simple and we can hope to have, in the future, a more @@ -369,7 +371,8 @@ let explain_ltac_call_trace last trace loc = strbrk " (with " ++ prlist_with_sep pr_comma (fun (id,c) -> - Id.print id ++ str ":=" ++ Printer.pr_lconstr_under_binders c) + let sigma, env = Pfedit.get_current_context () in + Id.print id ++ str ":=" ++ Printer.pr_lconstr_under_binders_env env sigma c) (List.rev (Id.Map.bindings vars)) ++ str ")" else mt()) in diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index 218342efe..cb54cac3f 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -984,7 +984,9 @@ struct let parse_expr sigma parse_constant parse_exp ops_spec env term = if debug - then Feedback.msg_debug (Pp.str "parse_expr: " ++ Printer.pr_leconstr term); + then ( + let _, env = Pfedit.get_current_context () in + Feedback.msg_debug (Pp.str "parse_expr: " ++ Printer.pr_leconstr_env env sigma term)); (* let constant_or_variable env term = @@ -1103,9 +1105,10 @@ struct | _ -> raise ParseError - let rconstant sigma term = + let rconstant sigma term = + let _, env = Pfedit.get_current_context () in if debug - then Feedback.msg_debug (Pp.str "rconstant: " ++ Printer.pr_leconstr term ++ fnl ()); + then Feedback.msg_debug (Pp.str "rconstant: " ++ Printer.pr_leconstr_env env sigma term ++ fnl ()); let res = rconstant sigma term in if debug then (Printf.printf "rconstant -> %a\n" pp_Rcst res ; flush stdout) ; @@ -1145,9 +1148,9 @@ struct let parse_arith parse_op parse_expr env cstr gl = let sigma = gl.sigma in - if debug - then Feedback.msg_debug (Pp.str "parse_arith: " ++ Printer.pr_leconstr cstr ++ fnl ()); - match EConstr.kind sigma cstr with + if debug + then Feedback.msg_debug (Pp.str "parse_arith: " ++ Printer.pr_leconstr_env gl.env sigma cstr ++ fnl ()); + match EConstr.kind sigma cstr with | Term.App(op,args) -> let (op,lhs,rhs) = parse_op gl (op,args) in let (e1,env) = parse_expr sigma env lhs in @@ -1908,7 +1911,7 @@ let micromega_tauto negate normalise unsat deduce spec prover env polys1 polys2 let formula_typ = (EConstr.mkApp(Lazy.force coq_Cstr, [|spec.coeff|])) in let ff = dump_formula formula_typ (dump_cstr spec.typ spec.dump_coeff) ff in - Feedback.msg_notice (Printer.pr_leconstr ff); + Feedback.msg_notice (Printer.pr_leconstr_env gl.env gl.sigma ff); Printf.fprintf stdout "cnf : %a\n" (pp_cnf (fun o _ -> ())) cnf_ff end; @@ -1932,9 +1935,9 @@ let micromega_tauto negate normalise unsat deduce spec prover env polys1 polys2 Feedback.msg_notice (Pp.str "\nAFormula\n") ; let formula_typ = (EConstr.mkApp( Lazy.force coq_Cstr,[| spec.coeff|])) in let ff' = dump_formula formula_typ - (dump_cstr spec.typ spec.dump_coeff) ff' in - Feedback.msg_notice (Printer.pr_leconstr ff'); - Printf.fprintf stdout "cnf : %a\n" (pp_cnf (fun o _ -> ())) cnf_ff' + (dump_cstr spec.typ spec.dump_coeff) ff' in + Feedback.msg_notice (Printer.pr_leconstr_env gl.env gl.sigma ff'); + Printf.fprintf stdout "cnf : %a\n" (pp_cnf (fun o _ -> ())) cnf_ff' end; (* Even if it does not work, this does not mean it is not provable diff --git a/plugins/quote/quote.ml b/plugins/quote/quote.ml index 96bf31b11..0ea8904f2 100644 --- a/plugins/quote/quote.ml +++ b/plugins/quote/quote.ml @@ -104,7 +104,7 @@ open CErrors open Util open Names -open Term +open Constr open EConstr open Pattern open Patternops diff --git a/plugins/romega/const_omega.ml b/plugins/romega/const_omega.ml index 5397b0065..32a1c07b2 100644 --- a/plugins/romega/const_omega.ml +++ b/plugins/romega/const_omega.ml @@ -7,7 +7,6 @@ *************************************************************************) open Names -open Term open Constr let module_refl_name = "ReflOmegaCore" diff --git a/plugins/romega/refl_omega.ml b/plugins/romega/refl_omega.ml index 430b608f4..54ff44fbd 100644 --- a/plugins/romega/refl_omega.ml +++ b/plugins/romega/refl_omega.ml @@ -183,8 +183,9 @@ let print_env_reification env = let rec loop c i = function [] -> str " ===============================\n\n" | t :: l -> + let sigma, env = Pfedit.get_current_context () in let s = Printf.sprintf "(%c%02d)" c i in - spc () ++ str s ++ str " := " ++ Printer.pr_lconstr t ++ fnl () ++ + spc () ++ str s ++ str " := " ++ Printer.pr_lconstr_env env sigma t ++ fnl () ++ loop c (succ i) l in let prop_info = str "ENVIRONMENT OF PROPOSITIONS :" ++ fnl () ++ loop 'P' 0 env.props in diff --git a/plugins/setoid_ring/g_newring.ml4 b/plugins/setoid_ring/g_newring.ml4 index 05ab8ab32..a7d6d5bb2 100644 --- a/plugins/setoid_ring/g_newring.ml4 +++ b/plugins/setoid_ring/g_newring.ml4 @@ -82,10 +82,11 @@ VERNAC COMMAND EXTEND AddSetoidRing CLASSIFIED AS SIDEFF | [ "Print" "Rings" ] => [Vernac_classifier.classify_as_query] -> [ Feedback.msg_notice (strbrk "The following ring structures have been declared:"); Spmap.iter (fun fn fi -> + let sigma, env = Pfedit.get_current_context () in Feedback.msg_notice (hov 2 (Ppconstr.pr_id (Libnames.basename fn)++spc()++ - str"with carrier "++ pr_constr fi.ring_carrier++spc()++ - str"and equivalence relation "++ pr_constr fi.ring_req)) + str"with carrier "++ pr_constr_env env sigma fi.ring_carrier++spc()++ + str"and equivalence relation "++ pr_constr_env env sigma fi.ring_req)) ) !from_name ] END @@ -117,10 +118,11 @@ VERNAC COMMAND EXTEND AddSetoidField CLASSIFIED AS SIDEFF | [ "Print" "Fields" ] => [Vernac_classifier.classify_as_query] -> [ Feedback.msg_notice (strbrk "The following field structures have been declared:"); Spmap.iter (fun fn fi -> + let sigma, env = Pfedit.get_current_context () in Feedback.msg_notice (hov 2 (Ppconstr.pr_id (Libnames.basename fn)++spc()++ - str"with carrier "++ pr_constr fi.field_carrier++spc()++ - str"and equivalence relation "++ pr_constr fi.field_req)) + str"with carrier "++ pr_constr_env env sigma fi.field_carrier++spc()++ + str"and equivalence relation "++ pr_constr_env env sigma fi.field_req)) ) !field_from_name ] END diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index 9e4b896f8..1c3bdb958 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -344,8 +344,6 @@ let _ = add_map "ring" (****************************************************************************) (* Ring database *) -let pr_constr c = pr_econstr c - module Cmap = Map.Make(Constr) let from_carrier = Summary.ref Cmap.empty ~name:"ring-tac-carrier-table" @@ -368,7 +366,7 @@ let find_ring_structure env sigma l = with Not_found -> CErrors.user_err ~hdr:"ring" (str"cannot find a declared ring structure over"++ - spc()++str"\""++pr_constr ty++str"\"")) + spc() ++ str"\"" ++ pr_econstr_env env sigma ty ++ str"\"")) | [] -> assert false let add_entry (sp,_kn) e = @@ -529,19 +527,19 @@ let ring_equality env evd (r,add,mul,opp,req) = op_morph r add mul opp req add_m_lem mul_m_lem opp_m_lem in Flags.if_verbose Feedback.msg_info - (str"Using setoid \""++pr_constr req++str"\""++spc()++ - str"and morphisms \""++pr_constr add_m_lem ++ - str"\","++spc()++ str"\""++pr_constr mul_m_lem++ - str"\""++spc()++str"and \""++pr_constr opp_m_lem++ + (str"Using setoid \""++ pr_econstr_env env !evd req++str"\""++spc()++ + str"and morphisms \""++pr_econstr_env env !evd add_m_lem ++ + str"\","++spc()++ str"\""++pr_econstr_env env !evd mul_m_lem++ + str"\""++spc()++str"and \""++pr_econstr_env env !evd opp_m_lem++ str"\""); op_morph) | None -> (Flags.if_verbose Feedback.msg_info - (str"Using setoid \""++pr_constr req ++str"\"" ++ spc() ++ - str"and morphisms \""++pr_constr add_m_lem ++ + (str"Using setoid \""++pr_econstr_env env !evd req ++str"\"" ++ spc() ++ + str"and morphisms \""++pr_econstr_env env !evd add_m_lem ++ str"\""++spc()++str"and \""++ - pr_constr mul_m_lem++str"\""); + pr_econstr_env env !evd mul_m_lem++str"\""); op_smorph r add mul req add_m_lem mul_m_lem) in (setoid,op_morph) @@ -861,7 +859,7 @@ let find_field_structure env sigma l = with Not_found -> CErrors.user_err ~hdr:"field" (str"cannot find a declared field structure over"++ - spc()++str"\""++pr_constr ty++str"\"")) + spc()++str"\""++pr_econstr_env env sigma ty++str"\"")) | [] -> assert false let add_field_entry (sp,_kn) e = diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index c1d7e6278..83b454769 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -240,7 +240,7 @@ let interp_refine ist gl rc = in let sigma, c = Pretyping.understand_ltac flags (pf_env gl) (project gl) vars kind rc in (* ppdebug(lazy(str"sigma@interp_refine=" ++ pr_evar_map None sigma)); *) - ppdebug(lazy(str"c@interp_refine=" ++ Printer.pr_econstr c)); + ppdebug(lazy(str"c@interp_refine=" ++ Printer.pr_econstr_env (pf_env gl) sigma c)); (sigma, (sigma, c)) @@ -539,7 +539,7 @@ module Intset = Evar.Set let pf_abs_evars_pirrel gl (sigma, c0) = pp(lazy(str"==PF_ABS_EVARS_PIRREL==")); - pp(lazy(str"c0= " ++ Printer.pr_constr c0)); + pp(lazy(str"c0= " ++ Printer.pr_constr_env (pf_env gl) sigma c0)); let sigma0 = project gl in let c0 = nf_evar sigma0 (nf_evar sigma c0) in let nenv = env_size (pf_env gl) in @@ -563,7 +563,7 @@ let pf_abs_evars_pirrel gl (sigma, c0) = | _ -> Constr.fold put evlist c in let evlist = put [] c0 in if evlist = [] then 0, c0 else - let pr_constr t = Printer.pr_econstr (Reductionops.nf_beta (project gl) (EConstr.of_constr t)) in + let pr_constr t = Printer.pr_econstr_env (pf_env gl) sigma (Reductionops.nf_beta (project gl) (EConstr.of_constr t)) in pp(lazy(str"evlist=" ++ pr_list (fun () -> str";") (fun (k,_) -> str(Evd.string_of_existential k)) evlist)); let evplist = @@ -959,7 +959,7 @@ let applyn ~with_evars ?beta ?(with_shelve=false) n t gl = loop (meta_declare m (EConstr.Unsafe.to_constr ty) sigma) bo ((EConstr.mkMeta m)::args) (n-1) | _ -> assert false in loop sigma t [] n in - pp(lazy(str"Refiner.refiner " ++ Printer.pr_econstr t)); + pp(lazy(str"Refiner.refiner " ++ Printer.pr_econstr_env (pf_env gl) (project gl) t)); Tacmach.refine_no_check t gl let refine_with ?(first_goes_last=false) ?beta ?(with_evars=true) oc gl = @@ -973,7 +973,7 @@ let refine_with ?(first_goes_last=false) ?beta ?(with_evars=true) oc gl = compose_lam (let xs,y = List.chop (n-1) l in y @ xs) (mkApp (compose_lam l c, Array.of_list (mkRel 1 :: mkRels n))) in - pp(lazy(str"after: " ++ Printer.pr_constr oc)); + pp(lazy(str"after: " ++ Printer.pr_constr_env (pf_env gl) (project gl) oc)); try applyn ~with_evars ~with_shelve:true ?beta n (EConstr.of_constr oc) gl with e when CErrors.noncritical e -> raise dependent_apply_error @@ -1202,7 +1202,7 @@ let genclrtac cl cs clr = let gentac ist gen gl = (* ppdebug(lazy(str"sigma@gentac=" ++ pr_evar_map None (project gl))); *) let conv, _, cl, c, clr, ucst,gl = pf_interp_gen_aux ist gl false gen in - ppdebug(lazy(str"c@gentac=" ++ pr_econstr c)); + ppdebug(lazy(str"c@gentac=" ++ pr_econstr_env (pf_env gl) (project gl) c)); let gl = pf_merge_uc ucst gl in if conv then tclTHEN (Proofview.V82.of_tactic (convert_concl cl)) (cleartac clr) gl diff --git a/plugins/ssr/ssrelim.ml b/plugins/ssr/ssrelim.ml index 26b5c5767..4e0b44a44 100644 --- a/plugins/ssr/ssrelim.ml +++ b/plugins/ssr/ssrelim.ml @@ -46,7 +46,7 @@ let analyze_eliminator elimty env sigma = if not (EConstr.eq_constr sigma t t') then loop ctx t' else errorstrm Pp.(str"The eliminator has the wrong shape."++spc()++ str"A (applied) bound variable was expected as the conclusion of "++ - str"the eliminator's"++Pp.cut()++str"type:"++spc()++pr_econstr elimty) in + str"the eliminator's"++Pp.cut()++str"type:"++spc()++pr_econstr_env env' sigma elimty) in let ctx, pred_id, elim_is_dep, n_pred_args,concl = loop [] elimty in let n_elim_args = Context.Rel.nhyps ctx in let is_rec_elim = @@ -126,7 +126,7 @@ let ssrelim ?(ind=ref None) ?(is_case=false) ?ist deps what ?elim eqid elim_intr ppdebug(lazy Pp.(str"matching: " ++ pr_occ occ ++ pp_pattern p)); let (c,ucst), cl = fill_occ_pattern ~raise_NoMatch:true env sigma0 (EConstr.Unsafe.to_constr cl) p occ h in - ppdebug(lazy Pp.(str" got: " ++ pr_constr c)); + ppdebug(lazy Pp.(str" got: " ++ pr_constr_env env sigma0 c)); c, EConstr.of_constr cl, ucst in let mkTpat gl t = (* takes a term, refreshes it and makes a T pattern *) let n, t, _, ucst = pf_abs_evars orig_gl (project gl, fire_subst gl t) in @@ -239,8 +239,8 @@ let ssrelim ?(ind=ref None) ?(is_case=false) ?ist deps what ?elim eqid elim_intr | Some (c, _, _,gl) -> true, gl | None -> errorstrm Pp.(str"Unable to apply the eliminator to the term"++ - spc()++pr_econstr c++spc()++str"or to unify it's type with"++ - pr_econstr inf_arg_ty) in + spc()++pr_econstr_env env (project gl) c++spc()++str"or to unify it's type with"++ + pr_econstr_env env (project gl) inf_arg_ty) in ppdebug(lazy Pp.(str"c_is_head_p= " ++ bool c_is_head_p)); let gl, predty = pfe_type_of gl pred in (* Patterns for the inductive types indexes to be bound in pred are computed diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml index e82f222b9..bd9633afb 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -77,7 +77,7 @@ let interp_congrarg_at ist gl n rf ty m = if i + n > m then None else try let rt = mkRApp congrn (args1 @ mkRApp rf (mkRHoles i) :: args2) in - ppdebug(lazy Pp.(str"rt=" ++ Printer.pr_glob_constr rt)); + ppdebug(lazy Pp.(str"rt=" ++ Printer.pr_glob_constr_env (pf_env gl) rt)); Some (interp_refine ist gl rt) with _ -> loop (i + 1) in loop 0 @@ -86,7 +86,7 @@ let pattern_id = mk_internal_id "pattern value" let congrtac ((n, t), ty) ist gl = ppdebug(lazy (Pp.str"===congr===")); - ppdebug(lazy Pp.(str"concl=" ++ Printer.pr_econstr (Tacmach.pf_concl gl))); + ppdebug(lazy Pp.(str"concl=" ++ Printer.pr_econstr_env (pf_env gl) (project gl) (Tacmach.pf_concl gl))); let sigma, _ as it = interp_term ist gl t in let gl = pf_merge_uc_of sigma gl in let _, f, _, _ucst = pf_abs_evars gl it in @@ -109,7 +109,7 @@ let congrtac ((n, t), ty) ist gl = let newssrcongrtac arg ist gl = ppdebug(lazy Pp.(str"===newcongr===")); - ppdebug(lazy Pp.(str"concl=" ++ Printer.pr_econstr (pf_concl gl))); + ppdebug(lazy Pp.(str"concl=" ++ Printer.pr_econstr_env (pf_env gl) (project gl) (pf_concl gl))); (* utils *) let fs gl t = Reductionops.nf_evar (project gl) t in let tclMATCH_GOAL (c, gl_c) proj t_ok t_fail gl = @@ -247,7 +247,7 @@ let unfoldintac occ rdx t (kt,_) gl = try find_T env c h ~k:(fun env c _ _ -> EConstr.Unsafe.to_constr (body env t (EConstr.of_constr c))) with NoMatch when easy -> c | NoMatch | NoProgress -> errorstrm Pp.(str"No occurrence of " - ++ pr_constr_pat (EConstr.Unsafe.to_constr t) ++ spc() ++ str "in " ++ Printer.pr_constr c)), + ++ pr_constr_pat (EConstr.Unsafe.to_constr t) ++ spc() ++ str "in " ++ Printer.pr_constr_env env sigma c)), (fun () -> try end_T () with | NoMatch when easy -> fake_pmatcher_end () | NoMatch -> anomaly "unfoldintac") @@ -267,13 +267,13 @@ let unfoldintac occ rdx t (kt,_) gl = | Proj _ when same_proj sigma0 c t -> body env t c | Const f -> aux (body env c c) | App (f, a) -> aux (EConstr.mkApp (body env f f, a)) - | _ -> errorstrm Pp.(str "The term "++pr_constr orig_c++ - str" contains no " ++ pr_econstr t ++ str" even after unfolding") + | _ -> errorstrm Pp.(str "The term "++ pr_constr_env env sigma orig_c++ + str" contains no " ++ pr_econstr_env env sigma t ++ str" even after unfolding") in EConstr.Unsafe.to_constr @@ aux (EConstr.of_constr c) else try EConstr.Unsafe.to_constr @@ body env t (fs (unify_HO env sigma (EConstr.of_constr c) t) t) with _ -> errorstrm Pp.(str "The term " ++ - pr_constr c ++spc()++ str "does not unify with " ++ pr_constr_pat (EConstr.Unsafe.to_constr t))), + pr_constr_env env sigma c ++spc()++ str "does not unify with " ++ pr_constr_pat (EConstr.Unsafe.to_constr t))), fake_pmatcher_end in let concl = let concl0 = EConstr.Unsafe.to_constr concl0 in @@ -342,7 +342,7 @@ let pirrel_rewrite pred rdx rdx_ty new_rdx dir (sigma, c) c_ty gl = let sort = elimination_sort_of_goal gl in let elim, gl = pf_fresh_global (Indrec.lookup_eliminator ind sort) gl in if dir = R2L then elim, gl else (* taken from Coq's rewrite *) - let elim, _ = Term.destConst elim in + let elim, _ = destConst elim in let mp,dp,l = Constant.repr3 (Constant.make1 (Constant.canonical elim)) in let l' = Label.of_id (Nameops.add_suffix (Label.to_id l) "_r") in let c1' = Global.constant_of_delta_kn (Constant.canonical (Constant.make3 mp dp l')) in @@ -352,7 +352,7 @@ let pirrel_rewrite pred rdx rdx_ty new_rdx dir (sigma, c) c_ty gl = (* We check the proof is well typed *) let sigma, proof_ty = try Typing.type_of env sigma proof with _ -> raise PRtype_error in - ppdebug(lazy Pp.(str"pirrel_rewrite proof term of type: " ++ pr_econstr proof_ty)); + ppdebug(lazy Pp.(str"pirrel_rewrite proof term of type: " ++ pr_econstr_env env sigma proof_ty)); try refine_with ~first_goes_last:(not !ssroldreworder) ~with_evars:false (sigma, proof) gl with _ -> @@ -374,8 +374,8 @@ let pirrel_rewrite pred rdx rdx_ty new_rdx dir (sigma, c) c_ty gl = if open_evs <> [] then Some name else None) (List.combine (Array.to_list args) names) | _ -> anomaly "rewrite rule not an application" in - errorstrm Pp.(Himsg.explain_refiner_error (Logic.UnresolvedBindings miss)++ - (Pp.fnl()++str"Rule's type:" ++ spc() ++ pr_econstr hd_ty)) + errorstrm Pp.(Himsg.explain_refiner_error env sigma (Logic.UnresolvedBindings miss)++ + (Pp.fnl()++str"Rule's type:" ++ spc() ++ pr_econstr_env env sigma hd_ty)) ;; let is_construct_ref sigma c r = @@ -391,12 +391,12 @@ let rwcltac cl rdx dir sr gl = let gl = pf_unsafe_merge_uc ucst gl in let rdxt = Retyping.get_type_of (pf_env gl) (fst sr) rdx in (* ppdebug(lazy(str"sigma@rwcltac=" ++ pr_evar_map None (fst sr))); *) - ppdebug(lazy Pp.(str"r@rwcltac=" ++ pr_econstr (snd sr))); + ppdebug(lazy Pp.(str"r@rwcltac=" ++ pr_econstr_env (pf_env gl) (project gl) (snd sr))); let cvtac, rwtac, gl = if EConstr.Vars.closed0 (project gl) r' then let env, sigma, c, c_eq = pf_env gl, fst sr, snd sr, Coqlib.build_coq_eq () in let sigma, c_ty = Typing.type_of env sigma c in - ppdebug(lazy Pp.(str"c_ty@rwcltac=" ++ pr_econstr c_ty)); + ppdebug(lazy Pp.(str"c_ty@rwcltac=" ++ pr_econstr_env env sigma c_ty)); match EConstr.kind_of_type sigma (Reductionops.whd_all env sigma c_ty) with | AtomicType(e, a) when is_ind_ref sigma e c_eq -> let new_rdx = if dir = L2R then a.(2) else a.(1) in @@ -411,7 +411,7 @@ let rwcltac cl rdx dir sr gl = let r3, _, r3t = try EConstr.destCast (project gl) r2 with _ -> errorstrm Pp.(str "no cast from " ++ pr_constr_pat (EConstr.Unsafe.to_constr (snd sr)) - ++ str " to " ++ pr_econstr r2) in + ++ str " to " ++ pr_econstr_env (pf_env gl) (project gl) r2) in let cl' = EConstr.mkNamedProd rule_id (EConstr.it_mkProd_or_LetIn r3t dc) (EConstr.Vars.lift 1 cl) in let cl'' = EConstr.mkNamedProd pattern_id rdxt cl' in let itacs = [introid pattern_id; introid rule_id] in @@ -605,7 +605,7 @@ let ssrinstancesofrule ist dir arg gl = sigma, pats @ [pat] in let rpats = List.fold_left (rpat env0 sigma0) (r_sigma,[]) rules in mk_tpattern_matcher ~all_instances:true ~raise_NoMatch:true sigma0 None ~upats_origin rpats in - let print env p c _ = Feedback.msg_info Pp.(hov 1 (str"instance:" ++ spc() ++ pr_constr p ++ spc() ++ str "matches:" ++ spc() ++ pr_constr c)); c in + let print env p c _ = Feedback.msg_info Pp.(hov 1 (str"instance:" ++ spc() ++ pr_constr_env env r_sigma p ++ spc() ++ str "matches:" ++ spc() ++ pr_constr_env env r_sigma c)); c in Feedback.msg_info Pp.(str"BEGIN INSTANCES"); try while true do diff --git a/plugins/ssr/ssrfwd.ml b/plugins/ssr/ssrfwd.ml index 29e96ec59..5c1b399a8 100644 --- a/plugins/ssr/ssrfwd.ml +++ b/plugins/ssr/ssrfwd.ml @@ -8,11 +8,12 @@ (* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) +open Pp open Names +open Constr open Tacmach open Ssrmatching_plugin.Ssrmatching - open Ssrprinters open Ssrcommon open Ssrtacticals @@ -30,10 +31,6 @@ let ssrposetac ist (id, (_, t)) gl = let sigma, t, ucst, _ = pf_abs_ssrterm ist gl t in posetac id t (pf_merge_uc ucst gl) -open Pp -open Term -open Constr - let ssrsettac ist id ((_, (pat, pty)), (_, occ)) gl = let pat = interp_cpattern ist gl pat (Option.map snd pty) in let cl, sigma, env = pf_concl gl, project gl, pf_env gl in @@ -72,13 +69,14 @@ let examine_abstract id gl = let gl, tid = pfe_type_of gl id in let abstract, gl = pf_mkSsrConst "abstract" gl in let sigma = project gl in + let env = pf_env gl in if not (EConstr.isApp sigma tid) || not (EConstr.eq_constr sigma (fst(EConstr.destApp sigma tid)) abstract) then - errorstrm(strbrk"not an abstract constant: "++pr_econstr id); + errorstrm(strbrk"not an abstract constant: "++ pr_econstr_env env sigma id); let _, args_id = EConstr.destApp sigma tid in if Array.length args_id <> 3 then - errorstrm(strbrk"not a proper abstract constant: "++pr_econstr id); + errorstrm(strbrk"not a proper abstract constant: "++ pr_econstr_env env sigma id); if not (is_Evar_or_CastedMeta sigma args_id.(2)) then - errorstrm(strbrk"abstract constant "++pr_econstr id++str" already used"); + errorstrm(strbrk"abstract constant "++ pr_econstr_env env sigma id++str" already used"); tid, args_id let pf_find_abstract_proof check_lock gl abstract_n = @@ -94,7 +92,7 @@ let pf_find_abstract_proof check_lock gl abstract_n = | _ -> l) (project gl) [] in match l with | [e] -> e - | _ -> errorstrm(strbrk"abstract constant "++pr_constr abstract_n++ + | _ -> errorstrm(strbrk"abstract constant "++ pr_constr_env (pf_env gl) (project gl) abstract_n ++ strbrk" not found in the evar map exactly once. "++ strbrk"Did you tamper with it?") @@ -205,7 +203,7 @@ let havetac ist let assert_is_conv gl = try Proofview.V82.of_tactic (convert_concl (EConstr.it_mkProd_or_LetIn concl ctx)) gl with _ -> errorstrm (str "Given proof term is not of type " ++ - pr_econstr (EConstr.mkArrow (EConstr.mkVar (Id.of_string "_")) concl)) in + pr_econstr_env (pf_env gl) (project gl) (EConstr.mkArrow (EConstr.mkVar (Id.of_string "_")) concl)) in gl, ty, Tacticals.tclTHEN assert_is_conv (Proofview.V82.of_tactic (Tactics.apply t)), id, itac_c | FwdHave, false, false -> let skols = List.flatten (List.map (function @@ -271,7 +269,7 @@ let ssrabstract ist gens (*last*) gl = let gl, proof = let pf_unify_HO gl a b = try pf_unify_HO gl a b - with _ -> errorstrm(strbrk"The abstract variable "++pr_econstr id++ + with _ -> errorstrm(strbrk"The abstract variable "++ pr_econstr_env env (project gl) id++ strbrk" cannot abstract this goal. Did you generalize it?") in let find_hole p t = match EConstr.kind (project gl) t with @@ -290,7 +288,7 @@ let ssrabstract ist gens (*last*) gl = | App(hd, [|left; right|]) when Term.Constr.equal hd prod -> find_hole (mkApp (proj1,[|left;right;p|])) left *) - | _ -> errorstrm(strbrk"abstract constant "++pr_econstr abstract_n++ + | _ -> errorstrm(strbrk"abstract constant "++ pr_econstr_env env (project gl) abstract_n++ strbrk" has an unexpected shape. Did you tamper with it?") in find_hole @@ -361,14 +359,14 @@ let wlogtac ist (((clr0, pats),_),_) (gens, ((_, ct))) hint suff ghave gl = | Sort _, [] -> EConstr.Vars.subst_vars s ct | LetIn(Name id as n,b,ty,c), _::g -> EConstr.mkLetIn (n,b,ty,var2rel c g (id::s)) | Prod(Name id as n,ty,c), _::g -> EConstr.mkProd (n,ty,var2rel c g (id::s)) - | _ -> CErrors.anomaly(str"SSR: wlog: var2rel: " ++ pr_econstr c) in + | _ -> CErrors.anomaly(str"SSR: wlog: var2rel: " ++ pr_econstr_env env sigma c) in let c = var2rel c gens [] in let rec pired c = function | [] -> c | t::ts as args -> match EConstr.kind sigma c with | Prod(_,_,c) -> pired (EConstr.Vars.subst1 t c) ts | LetIn(id,b,ty,c) -> EConstr.mkLetIn (id,b,ty,pired c args) - | _ -> CErrors.anomaly(str"SSR: wlog: pired: " ++ pr_econstr c) in + | _ -> CErrors.anomaly(str"SSR: wlog: pired: " ++ pr_econstr_env env sigma c) in c, args, pired c args, pf_merge_uc uc gl in let tacipat pats = introstac ~ist pats in let tacigens = @@ -396,8 +394,8 @@ let wlogtac ist (((clr0, pats),_),_) (gens, ((_, ct))) hint suff ghave gl = | Some id -> if pats = [] then Tacticals.tclIDTAC else let args = Array.of_list args in - ppdebug(lazy(str"specialized="++pr_econstr EConstr.(mkApp (mkVar id,args)))); - ppdebug(lazy(str"specialized_ty="++pr_econstr ct)); + ppdebug(lazy(str"specialized="++ pr_econstr_env (pf_env gl) (project gl) EConstr.(mkApp (mkVar id,args)))); + ppdebug(lazy(str"specialized_ty="++ pr_econstr_env (pf_env gl) (project gl) ct)); Tacticals.tclTHENS (basecuttac "ssr_have" ct) [Proofview.V82.of_tactic (Tactics.apply EConstr.(mkApp (mkVar id,args))); Tacticals.tclIDTAC] in "ssr_have", diff --git a/plugins/ssr/ssripats.ml b/plugins/ssr/ssripats.ml index 023778fdb..6c325cce4 100644 --- a/plugins/ssr/ssripats.ml +++ b/plugins/ssr/ssripats.ml @@ -272,7 +272,7 @@ let (introstac : ?ist:Tacinterp.interp_sign -> ssripats -> Tacmach.tactic), let elim_intro_tac ipats ?ist what eqid ssrelim is_rec clr gl = (* Utils of local interest only *) let iD s ?t gl = let t = match t with None -> pf_concl gl | Some x -> x in - ppdebug(lazy Pp.(str s ++ pr_econstr t)); Tacticals.tclIDTAC gl in + ppdebug(lazy Pp.(str s ++ pr_econstr_env (pf_env gl) (project gl) t)); Tacticals.tclIDTAC gl in let protectC, gl = pf_mkSsrConst "protect_term" gl in let eq, gl = pf_fresh_global (Coqlib.build_coq_eq ()) gl in let eq = EConstr.of_constr eq in diff --git a/plugins/ssr/ssrparser.ml4 b/plugins/ssr/ssrparser.ml4 index 7b591fead..46403aef3 100644 --- a/plugins/ssr/ssrparser.ml4 +++ b/plugins/ssr/ssrparser.ml4 @@ -1131,7 +1131,7 @@ let pr_fwd_guarded prval prval' = function | (fk, h), (_, (_, Some c)) -> pr_gen_fwd prval pr_constr_expr prl_constr_expr fk (format_constr_expr h c) | (fk, h), (_, (c, None)) -> - pr_gen_fwd prval' pr_glob_constr prl_glob_constr fk (format_glob_constr h c) + pr_gen_fwd prval' pr_glob_constr_env prl_glob_constr fk (format_glob_constr h c) let pr_unguarded prc prlc = prlc diff --git a/plugins/ssr/ssrprinters.ml b/plugins/ssr/ssrprinters.ml index e865ef706..4b2fab6d1 100644 --- a/plugins/ssr/ssrprinters.ml +++ b/plugins/ssr/ssrprinters.ml @@ -24,7 +24,7 @@ let pp_concat hd ?(sep=str", ") = function [] -> hd | x :: xs -> hd ++ List.fold_left (fun acc x -> acc ++ sep ++ x) x xs let pp_term gl t = - let t = Reductionops.nf_evar (project gl) t in pr_econstr t + let t = Reductionops.nf_evar (project gl) t in pr_econstr_env (pf_env gl) (project gl) t (* FIXME *) (* terms are pre constr, the kind is parsing/printing flag to distinguish diff --git a/plugins/ssr/ssrvernac.ml4 b/plugins/ssr/ssrvernac.ml4 index 36dce37ae..cd614fee9 100644 --- a/plugins/ssr/ssrvernac.ml4 +++ b/plugins/ssr/ssrvernac.ml4 @@ -343,7 +343,7 @@ let coerce_search_pattern_to_sort hpat = let hpat' = if np = na then hpat else mkPApp hpat (np - na) [||] in let warn () = Feedback.msg_warning (str "Listing only lemmas with conclusion matching " ++ - pr_constr_pattern hpat') in + pr_constr_pattern_env env sigma hpat') in if EConstr.isSort sigma ht then begin warn (); true, hpat' end else let filter_head, coe_path = try @@ -359,7 +359,7 @@ let coerce_search_pattern_to_sort hpat = let n_imps = Option.get (Classops.hide_coercion coe_ref) in mkPApp (Pattern.PRef coe_ref) n_imps [|hp|] with _ -> - errorstrm (str "need explicit coercion " ++ pr_constr coe ++ spc () + errorstrm (str "need explicit coercion " ++ pr_constr_env env sigma coe ++ spc () ++ str "to interpret head search pattern as type") in filter_head, List.fold_left coerce hpat' coe_path @@ -468,10 +468,12 @@ let pr_raw_ssrhintref prc _ _ = let open CAst in function prc c ++ str "|" ++ int (List.length args) | c -> prc c -let pr_rawhintref c = match DAst.get c with +let pr_rawhintref c = + let _, env = Pfedit.get_current_context () in + match DAst.get c with | GApp (f, args) when isRHoles args -> - pr_glob_constr f ++ str "|" ++ int (List.length args) - | _ -> pr_glob_constr c + pr_glob_constr_env env f ++ str "|" ++ int (List.length args) + | _ -> pr_glob_constr_env env c let pr_glob_ssrhintref _ _ _ (c, _) = pr_rawhintref c diff --git a/plugins/ssrmatching/ssrmatching.ml4 b/plugins/ssrmatching/ssrmatching.ml4 index d5c9e4988..276b7c8ab 100644 --- a/plugins/ssrmatching/ssrmatching.ml4 +++ b/plugins/ssrmatching/ssrmatching.ml4 @@ -100,7 +100,6 @@ let pr_guarded guard prc c = let s = Pp.string_of_ppcmds (prc c) ^ "$" in if guard s (skip_wschars s 0) then pr_paren prc c else prc c (* More sensible names for constr printers *) -let pr_constr = pr_constr let prl_glob_constr c = pr_lglob_constr_env (Global.env ()) c let pr_glob_constr c = pr_glob_constr_env (Global.env ()) c let prl_constr_expr = pr_lconstr_expr @@ -427,7 +426,8 @@ let hole_var = mkVar (Id.of_string "_") let pr_constr_pat c0 = let rec wipe_evar c = if isEvar c then hole_var else map wipe_evar c in - pr_constr (wipe_evar c0) + let sigma, env = Pfedit.get_current_context () in + pr_constr_env env sigma (wipe_evar c0) (* Turn (new) evars into metas *) let evars_for_FO ~hack env sigma0 (ise0:evar_map) c0 = @@ -1215,7 +1215,7 @@ let eval_pattern ?raise_NoMatch env0 sigma0 concl0 pattern occ do_subst = let pop_evar sigma e p = let { Evd.evar_body = e_body } as e_def = Evd.find sigma e in let e_body = match e_body with Evar_defined c -> c - | _ -> errorstrm (str "Matching the pattern " ++ pr_constr p ++ + | _ -> errorstrm (str "Matching the pattern " ++ pr_constr_env env0 sigma0 p ++ str " did not instantiate ?" ++ int (Evar.repr e) ++ spc () ++ str "Does the variable bound by the \"in\" construct occur "++ str "in the pattern?") in @@ -1417,7 +1417,8 @@ let ssrinstancesof ist arg gl = let find, conclude = mk_tpattern_matcher ~all_instances:true ~raise_NoMatch:true sigma None (etpat,[tpat]) in - let print env p c _ = ppnl (hov 1 (str"instance:" ++ spc() ++ pr_constr p ++ spc() ++ str "matches:" ++ spc() ++ pr_constr c)); c in + let print env p c _ = ppnl (hov 1 (str"instance:" ++ spc() ++ pr_constr_env (pf_env gl) (gl.sigma) p ++ spc() + ++ str "matches:" ++ spc() ++ pr_constr_env (pf_env gl) (gl.sigma) c)); c in ppnl (str"BEGIN INSTANCES"); try while true do diff --git a/pretyping/cases.mli b/pretyping/cases.mli index 3a139b7b0..43dbc3105 100644 --- a/pretyping/cases.mli +++ b/pretyping/cases.mli @@ -13,8 +13,8 @@ open Environ open EConstr open Inductiveops open Glob_term -open Evarutil open Ltac_pretype +open Evardefine (** {5 Compilation of pattern-matching } *) @@ -116,7 +116,7 @@ type 'a pattern_matching_problem = val compile : 'a pattern_matching_problem -> unsafe_judgment val prepare_predicate : ?loc:Loc.t -> - (Evarutil.type_constraint -> + (type_constraint -> Environ.env -> Evd.evar_map ref -> ltac_var_map -> glob_constr -> unsafe_judgment) -> Environ.env -> Evd.evar_map -> diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 681eb17d3..18e0c31dd 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -9,7 +9,6 @@ open CErrors open Util open Names -open Term open Constr open Termops open Environ @@ -49,7 +48,7 @@ let _ = Goptions.declare_bool_option { "data.id.type" etc... *) let impossible_default_case () = let c, ctx = Universes.fresh_global_instance (Global.env()) (Globnames.ConstRef Coqlib.id) in - let (_, u) = Term.destConst c in + let (_, u) = Constr.destConst c in Some (c, Constr.mkConstU (Coqlib.type_of_id, u), ctx) let coq_unit_judge = diff --git a/pretyping/evardefine.ml b/pretyping/evardefine.ml index 18dbbea1b..b646a37f8 100644 --- a/pretyping/evardefine.ml +++ b/pretyping/evardefine.ml @@ -6,10 +6,10 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Sorts open Util open Pp open Names -open Term open Constr open Termops open EConstr diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index fba154291..e6d1e59b3 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -6,10 +6,10 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Sorts open Util open CErrors open Names -open Term open Constr open Environ open Termops diff --git a/engine/geninterp.ml b/pretyping/geninterp.ml index 768ef3cfd..768ef3cfd 100644 --- a/engine/geninterp.ml +++ b/pretyping/geninterp.ml diff --git a/engine/geninterp.mli b/pretyping/geninterp.mli index ae0b26e59..ae0b26e59 100644 --- a/engine/geninterp.mli +++ b/pretyping/geninterp.mli diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index eb2b435bf..b2735ee22 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -17,8 +17,8 @@ open Environ open Evd open EConstr open Glob_term -open Evarutil open Ltac_pretype +open Evardefine (** An auxiliary function for searching for fixpoint guard indexes *) diff --git a/pretyping/pretyping.mllib b/pretyping/pretyping.mllib index 9904b7354..1da5b4567 100644 --- a/pretyping/pretyping.mllib +++ b/pretyping/pretyping.mllib @@ -1,3 +1,4 @@ +Geninterp Ltac_pretype Locusops Pretype_errors diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index e6d8a0af2..9ff9a75b3 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -213,7 +213,7 @@ let compute_canonical_projections warn (con,ind) = let sign = List.map (on_snd EConstr.Unsafe.to_constr) sign in let t = EConstr.Unsafe.to_constr t in let lt = List.rev_map snd sign in - let args = snd (Term.decompose_app t) in + let args = snd (decompose_app t) in let { s_EXPECTEDPARAM = p; s_PROJ = lpj; s_PROJKIND = kl } = lookup_structure ind in let params, projs = List.chop p args in diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index 0f6452de6..bce5710d6 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -396,7 +396,7 @@ let tag_var = tag Tag.variable extract_prod_binders c | { loc; v = CProdN ([[_,Name id],bk,t], { v = CCases (LetPatternStyle,None, [{ v = CRef (Ident (_,id'),None)},None,None],[(_,([_,[p]],b))])} ) } - when Id.equal id id' && not (Id.Set.mem id (Topconstr.free_vars_of_constr_expr b)) -> + when Id.equal id id' && not (Id.Set.mem id (free_vars_of_constr_expr b)) -> let bl,c = extract_prod_binders b in CLocalPattern (loc, (p,None)) :: bl, c | { loc; v = CProdN ((nal,bk,t)::bl,c) } -> @@ -412,7 +412,7 @@ let tag_var = tag Tag.variable extract_lam_binders c | CLambdaN ([[_,Name id],bk,t], { v = CCases (LetPatternStyle,None, [{ v = CRef (Ident (_,id'),None)},None,None],[(_,([_,[p]],b))])} ) - when Id.equal id id' && not (Id.Set.mem id (Topconstr.free_vars_of_constr_expr b)) -> + when Id.equal id id' && not (Id.Set.mem id (free_vars_of_constr_expr b)) -> let bl,c = extract_lam_binders b in CLocalPattern (ce.loc,(p,None)) :: bl, c | CLambdaN ((nal,bk,t)::bl,c) -> @@ -430,7 +430,7 @@ let tag_var = tag Tag.variable let rename na na' t c = match (na,na') with | (_,Name id), (_,Name id') -> - (na',t,Topconstr.replace_vars_constr_expr (Id.Map.singleton id id') c) + (na',t,replace_vars_constr_expr (Id.Map.singleton id id') c) | (_,Name id), (_,Anonymous) -> (na,t,c) | _ -> (na',t,c) diff --git a/printing/pputils.ml b/printing/pputils.ml index 3cc7a3e6b..12d5338ad 100644 --- a/printing/pputils.ml +++ b/printing/pputils.ml @@ -103,6 +103,9 @@ let pr_red_expr (pr_constr,pr_lconstr,pr_ref,pr_pattern) keyword = function | CbvNative o -> keyword "native_compute" ++ pr_opt (pr_with_occurrences (pr_union pr_ref pr_pattern) keyword) o +let pr_red_expr_env env sigma (pr_constr,pr_lconstr,pr_ref,pr_pattern) = + pr_red_expr (pr_constr env sigma, pr_lconstr env sigma, pr_ref, pr_pattern env sigma) + let pr_or_by_notation f = function | AN v -> f v | ByNotation (_,(s,sc)) -> qs s ++ pr_opt (fun sc -> str "%" ++ str sc) sc diff --git a/printing/pputils.mli b/printing/pputils.mli index 1f4fa1390..f7f586b77 100644 --- a/printing/pputils.mli +++ b/printing/pputils.mli @@ -21,8 +21,16 @@ val pr_with_occurrences : val pr_short_red_flag : ('a -> Pp.t) -> 'a glob_red_flag -> Pp.t val pr_red_flag : ('a -> Pp.t) -> 'a glob_red_flag -> Pp.t + val pr_red_expr : ('a -> Pp.t) * ('a -> Pp.t) * ('b -> Pp.t) * ('c -> Pp.t) -> + (string -> Pp.t) -> ('a,'b,'c) red_expr_gen -> Pp.t + +val pr_red_expr_env : Environ.env -> Evd.evar_map -> + (Environ.env -> Evd.evar_map -> 'a -> Pp.t) * + (Environ.env -> Evd.evar_map -> 'a -> Pp.t) * + ('b -> Pp.t) * + (Environ.env -> Evd.evar_map -> 'c -> Pp.t) -> (string -> Pp.t) -> ('a,'b,'c) red_expr_gen -> Pp.t diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml index 143f9ddcc..e897b1938 100644 --- a/printing/ppvernac.ml +++ b/printing/ppvernac.ml @@ -447,7 +447,7 @@ open Decl_kinds | PrintGrammar ent -> keyword "Print Grammar" ++ spc() ++ str ent | PrintLoadPath dir -> - keyword "Print LoadPath" ++ pr_opt pr_dirpath dir + keyword "Print LoadPath" ++ pr_opt DirPath.print dir | PrintModules -> keyword "Print Modules" | PrintMLLoadPath -> @@ -518,7 +518,7 @@ open Decl_kinds in keyword cmd ++ spc() ++ pr_smart_global qid | PrintNamespace dp -> - keyword "Print Namespace" ++ pr_dirpath dp + keyword "Print Namespace" ++ DirPath.print dp | PrintStrategy None -> keyword "Print Strategies" | PrintStrategy (Some qid) -> @@ -964,7 +964,7 @@ open Decl_kinds keyword "LoadPath" ++ spc() ++ qs s ++ (match d with | None -> mt() - | Some dir -> spc() ++ keyword "as" ++ spc() ++ pr_dirpath dir)) + | Some dir -> spc() ++ keyword "as" ++ spc() ++ DirPath.print dir)) ) | VernacRemoveLoadPath s -> return (keyword "Remove LoadPath" ++ qs s) diff --git a/printing/prettyp.ml b/printing/prettyp.ml index acbd2d5d2..8fc00ed96 100644 --- a/printing/prettyp.ml +++ b/printing/prettyp.ml @@ -15,7 +15,6 @@ open CErrors open Util open Names open Nameops -open Term open Termops open Declarations open Environ @@ -35,13 +34,13 @@ module NamedDecl = Context.Named.Declaration type object_pr = { print_inductive : MutInd.t -> Pp.t; print_constant_with_infos : Constant.t -> Pp.t; - print_section_variable : variable -> Pp.t; - print_syntactic_def : KerName.t -> Pp.t; + print_section_variable : env -> Evd.evar_map -> variable -> Pp.t; + print_syntactic_def : env -> KerName.t -> Pp.t; print_module : bool -> ModPath.t -> Pp.t; print_modtype : ModPath.t -> Pp.t; - print_named_decl : Context.Named.Declaration.t -> Pp.t; - print_library_entry : bool -> (object_name * Lib.node) -> Pp.t option; - print_context : bool -> int option -> Lib.library_segment -> Pp.t; + print_named_decl : env -> Evd.evar_map -> Context.Named.Declaration.t -> Pp.t; + print_library_entry : env -> Evd.evar_map -> bool -> (object_name * Lib.node) -> Pp.t option; + print_context : env -> Evd.evar_map -> bool -> int option -> Lib.library_segment -> Pp.t; print_typed_value_in_env : Environ.env -> Evd.evar_map -> EConstr.constr * EConstr.types -> Pp.t; print_eval : Reductionops.reduction_function -> env -> Evd.evar_map -> Constrexpr.constr_expr -> EConstr.unsafe_judgment -> Pp.t; } @@ -139,7 +138,7 @@ let print_renames_list prefix l = let need_expansion impl ref = let typ, _ = Global.type_of_global_in_context (Global.env ()) ref in - let ctx = prod_assum typ in + let ctx = Term.prod_assum typ in let nprods = List.count is_local_assum ctx in not (List.is_empty impl) && List.length impl >= nprods && let _,lastimpl = List.chop nprods impl in @@ -366,7 +365,7 @@ let pr_located_qualid = function | DirModule (dir,_) -> "Module", dir | DirClosedSection dir -> "Closed Section", dir in - str s ++ spc () ++ pr_dirpath dir + str s ++ spc () ++ DirPath.print dir | ModuleType mp -> str "Module Type" ++ spc () ++ pr_path (Nametab.path_of_modtype mp) | Other (obj, info) -> info.name obj @@ -487,25 +486,25 @@ let gallina_print_typed_value_in_env env sigma (trm,typ) = the pretty-print of a proposition (P:(nat->nat)->Prop)(P [u]u) synthesizes the type nat of the abstraction on u *) -let print_named_def name body typ = - let pbody = pr_lconstr body in - let ptyp = pr_ltype typ in - let pbody = if isCast body then surround pbody else pbody in +let print_named_def env sigma name body typ = + let pbody = pr_lconstr_env env sigma body in + let ptyp = pr_ltype_env env sigma typ in + let pbody = if Constr.isCast body then surround pbody else pbody in (str "*** [" ++ str name ++ str " " ++ hov 0 (str ":=" ++ brk (1,2) ++ pbody ++ spc () ++ str ":" ++ brk (1,2) ++ ptyp) ++ str "]") -let print_named_assum name typ = - str "*** [" ++ str name ++ str " : " ++ pr_ltype typ ++ str "]" +let print_named_assum env sigma name typ = + str "*** [" ++ str name ++ str " : " ++ pr_ltype_env env sigma typ ++ str "]" -let gallina_print_named_decl = +let gallina_print_named_decl env sigma = let open Context.Named.Declaration in function | LocalAssum (id, typ) -> - print_named_assum (Id.to_string id) typ + print_named_assum env sigma (Id.to_string id) typ | LocalDef (id, body, typ) -> - print_named_def (Id.to_string id) body typ + print_named_def env sigma (Id.to_string id) body typ let assumptions_for_print lna = List.fold_right (fun na env -> add_name na env) lna empty_names_context @@ -524,11 +523,11 @@ let gallina_print_inductive sp = print_inductive_implicit_args sp mipv @ print_inductive_argument_scopes sp mipv) -let print_named_decl id = - gallina_print_named_decl (Global.lookup_named id) ++ fnl () +let print_named_decl env sigma id = + gallina_print_named_decl env sigma (Global.lookup_named id) ++ fnl () -let gallina_print_section_variable id = - print_named_decl id ++ +let gallina_print_section_variable env sigma id = + print_named_decl env sigma id ++ with_line_skip (print_name_infos (VarRef id)) let print_body env evd = function @@ -601,7 +600,7 @@ let gallina_print_constant_with_infos sp = print_constant true " = " sp ++ with_line_skip (print_name_infos (ConstRef sp)) -let gallina_print_syntactic_def kn = +let gallina_print_syntactic_def env kn = let qid = Nametab.shortest_qualid_of_syndef Id.Set.empty kn and (vars,a) = Syntax_def.search_syntactic_definition kn in let c = Notation_ops.glob_constr_of_notation_constr a in @@ -612,16 +611,16 @@ let gallina_print_syntactic_def kn = spc () ++ str ":=") ++ spc () ++ Constrextern.without_specific_symbols - [Notation.SynDefRule kn] pr_glob_constr c) + [Notation.SynDefRule kn] (pr_glob_constr_env env) c) -let gallina_print_leaf_entry with_values ((sp,kn as oname),lobj) = +let gallina_print_leaf_entry env sigma with_values ((sp,kn as oname),lobj) = let sep = if with_values then " = " else " : " and tag = object_tag lobj in match (oname,tag) with | (_,"VARIABLE") -> (* Outside sections, VARIABLES still exist but only with universes constraints *) - (try Some(print_named_decl (basename sp)) with Not_found -> None) + (try Some(print_named_decl env sigma (basename sp)) with Not_found -> None) | (_,"CONSTANT") -> Some (print_constant with_values sep (Constant.make1 kn)) | (_,"INDUCTIVE") -> @@ -637,26 +636,26 @@ let gallina_print_leaf_entry with_values ((sp,kn as oname),lobj) = (* To deal with forgotten cases... *) | (_,s) -> None -let gallina_print_library_entry with_values ent = +let gallina_print_library_entry env sigma with_values ent = let pr_name (sp,_) = Id.print (basename sp) in match ent with | (oname,Lib.Leaf lobj) -> - gallina_print_leaf_entry with_values (oname,lobj) + gallina_print_leaf_entry env sigma with_values (oname,lobj) | (oname,Lib.OpenedSection (dir,_)) -> Some (str " >>>>>>> Section " ++ pr_name oname) | (oname,Lib.ClosedSection _) -> Some (str " >>>>>>> Closed Section " ++ pr_name oname) | (_,Lib.CompilingLibrary (dir,_)) -> - Some (str " >>>>>>> Library " ++ pr_dirpath dir) + Some (str " >>>>>>> Library " ++ DirPath.print dir) | (oname,Lib.OpenedModule _) -> Some (str " >>>>>>> Module " ++ pr_name oname) | (oname,Lib.ClosedModule _) -> Some (str " >>>>>>> Closed Module " ++ pr_name oname) -let gallina_print_context with_values = +let gallina_print_context env sigma with_values = let rec prec n = function | h::rest when Option.is_empty n || Option.get n > 0 -> - (match gallina_print_library_entry with_values h with + (match gallina_print_library_entry env sigma with_values h with | None -> prec n rest | Some pp -> prec (Option.map ((+) (-1)) n) rest ++ pp ++ fnl ()) | _ -> mt () @@ -718,10 +717,10 @@ let print_safe_judgment env sigma j = (*********************) (* *) -let print_full_context () = print_context true None (Lib.contents ()) -let print_full_context_typ () = print_context false None (Lib.contents ()) +let print_full_context env sigma = print_context env sigma true None (Lib.contents ()) +let print_full_context_typ env sigma = print_context env sigma false None (Lib.contents ()) -let print_full_pure_context () = +let print_full_pure_context env sigma = let rec prec = function | ((_,kn),Lib.Leaf lobj)::rest -> let pp = match object_tag lobj with @@ -733,15 +732,15 @@ let print_full_pure_context () = match cb.const_body with | Undef _ -> str "Parameter " ++ - print_basename con ++ str " : " ++ cut () ++ pr_ltype typ + print_basename con ++ str " : " ++ cut () ++ pr_ltype_env env sigma typ | OpaqueDef lc -> str "Theorem " ++ print_basename con ++ cut () ++ - str " : " ++ pr_ltype typ ++ str "." ++ fnl () ++ - str "Proof " ++ pr_lconstr (Opaqueproof.force_proof (Global.opaque_tables ()) lc) + str " : " ++ pr_ltype_env env sigma typ ++ str "." ++ fnl () ++ + str "Proof " ++ pr_lconstr_env env sigma (Opaqueproof.force_proof (Global.opaque_tables ()) lc) | Def c -> str "Definition " ++ print_basename con ++ cut () ++ - str " : " ++ pr_ltype typ ++ cut () ++ str " := " ++ - pr_lconstr (Mod_subst.force_constr c)) + str " : " ++ pr_ltype_env env sigma typ ++ cut () ++ str " := " ++ + pr_lconstr_env env sigma (Mod_subst.force_constr c)) ++ str "." ++ fnl () ++ fnl () | "INDUCTIVE" -> let mind = Global.mind_of_delta_kn kn in @@ -787,18 +786,18 @@ let read_sec_context r = let cxt = Lib.contents () in List.rev (get_cxt [] cxt) -let print_sec_context sec = - print_context true None (read_sec_context sec) +let print_sec_context env sigma sec = + print_context env sigma true None (read_sec_context sec) -let print_sec_context_typ sec = - print_context false None (read_sec_context sec) +let print_sec_context_typ env sigma sec = + print_context env sigma false None (read_sec_context sec) -let print_any_name = function +let print_any_name env sigma = function | Term (ConstRef sp) -> print_constant_with_infos sp | Term (IndRef (sp,_)) -> print_inductive sp | Term (ConstructRef ((sp,_),_)) -> print_inductive sp - | Term (VarRef sp) -> print_section_variable sp - | Syntactic kn -> print_syntactic_def kn + | Term (VarRef sp) -> print_section_variable env sigma sp + | Syntactic kn -> print_syntactic_def env kn | Dir (DirModule(dirpath,(mp,_))) -> print_module (printable_body dirpath) mp | Dir _ -> mt () | ModuleType mp -> print_modtype mp @@ -807,22 +806,21 @@ let print_any_name = function try (* Var locale de but, pas var de section... donc pas d'implicits *) let dir,str = repr_qualid qid in if not (DirPath.is_empty dir) then raise Not_found; - str |> Global.lookup_named |> print_named_decl + str |> Global.lookup_named |> print_named_decl env sigma with Not_found -> user_err ~hdr:"print_name" (pr_qualid qid ++ spc () ++ str "not a defined object.") -let print_name = function +let print_name env sigma = function | ByNotation (loc,(ntn,sc)) -> - print_any_name + print_any_name env sigma (Term (Notation.interp_notation_as_global_reference ?loc (fun _ -> true) ntn sc)) | AN ref -> - print_any_name (locate_any_name ref) + print_any_name env sigma (locate_any_name ref) -let print_opaque_name qid = - let env = Global.env () in +let print_opaque_name env sigma qid = match Nametab.global qid with | ConstRef cst -> let cb = Global.lookup_constant cst in @@ -840,9 +838,9 @@ let print_opaque_name qid = let open EConstr in print_typed_value (mkConstruct cstr, ty) | VarRef id -> - env |> lookup_named id |> print_named_decl + env |> lookup_named id |> print_named_decl env sigma -let print_about_any ?loc k = +let print_about_any ?loc env sigma k = match k with | Term ref -> let rb = Reductionops.ReductionBehaviour.print ref in @@ -858,23 +856,23 @@ let print_about_any ?loc k = | [],Notation_term.NRef ref -> Dumpglob.add_glob ?loc ref | _ -> () in v 0 ( - print_syntactic_def kn ++ fnl () ++ + print_syntactic_def env kn ++ fnl () ++ hov 0 (str "Expands to: " ++ pr_located_qualid k)) | Dir _ | ModuleType _ | Undefined _ -> hov 0 (pr_located_qualid k) | Other (obj, info) -> hov 0 (info.about obj) -let print_about = function +let print_about env sigma = function | ByNotation (loc,(ntn,sc)) -> - print_about_any ?loc + print_about_any ?loc env sigma (Term (Notation.interp_notation_as_global_reference ?loc (fun _ -> true) ntn sc)) | AN ref -> - print_about_any ?loc:(loc_of_reference ref) (locate_any_name ref) + print_about_any ?loc:(loc_of_reference ref) env sigma (locate_any_name ref) (* for debug *) -let inspect depth = - print_context false (Some depth) (Lib.contents ()) +let inspect env sigma depth = + print_context env sigma false (Some depth) (Lib.contents ()) (*************************************************************************) @@ -882,18 +880,20 @@ let inspect depth = open Classops -let print_coercion_value v = pr_lconstr (get_coercion_value v) +let print_coercion_value env sigma v = pr_lconstr_env env sigma (get_coercion_value v) let print_class i = let cl,_ = class_info_from_index i in pr_class cl let print_path ((i,j),p) = + let sigma, env = Pfedit.get_current_context () in hov 2 ( - str"[" ++ hov 0 (prlist_with_sep pr_semicolon print_coercion_value p) ++ + str"[" ++ hov 0 (prlist_with_sep pr_semicolon (print_coercion_value env sigma) p) ++ str"] : ") ++ print_class i ++ str" >-> " ++ print_class j +(* XXX: This is suspicious!!! *) let _ = Classops.install_path_printer print_path let print_graph () = @@ -902,8 +902,8 @@ let print_graph () = let print_classes () = pr_sequence pr_class (classes()) -let print_coercions () = - pr_sequence print_coercion_value (coercions()) +let print_coercions env sigma = + pr_sequence (print_coercion_value env sigma) (coercions()) let index_of_class cl = try @@ -925,11 +925,11 @@ let print_path_between cls clt = in print_path ((i,j),p) -let print_canonical_projections () = +let print_canonical_projections env sigma = prlist_with_sep fnl (fun ((r1,r2),o) -> pr_cs_pattern r2 ++ str " <- " ++ - pr_global r1 ++ str " ( " ++ pr_lconstr o.o_DEF ++ str " )") + pr_global r1 ++ str " ( " ++ pr_lconstr_env env sigma o.o_DEF ++ str " )") (canonical_projections ()) (*************************************************************************) diff --git a/printing/prettyp.mli b/printing/prettyp.mli index 31fd766ea..89099a043 100644 --- a/printing/prettyp.mli +++ b/printing/prettyp.mli @@ -18,37 +18,37 @@ open Misctypes val assumptions_for_print : Name.t list -> Termops.names_context val print_closed_sections : bool ref -val print_context : bool -> int option -> Lib.library_segment -> Pp.t -val print_library_entry : bool -> (object_name * Lib.node) -> Pp.t option -val print_full_context : unit -> Pp.t -val print_full_context_typ : unit -> Pp.t -val print_full_pure_context : unit -> Pp.t -val print_sec_context : reference -> Pp.t -val print_sec_context_typ : reference -> Pp.t +val print_context : env -> Evd.evar_map -> bool -> int option -> Lib.library_segment -> Pp.t +val print_library_entry : env -> Evd.evar_map -> bool -> (object_name * Lib.node) -> Pp.t option +val print_full_context : env -> Evd.evar_map -> Pp.t +val print_full_context_typ : env -> Evd.evar_map -> Pp.t +val print_full_pure_context : env -> Evd.evar_map -> Pp.t +val print_sec_context : env -> Evd.evar_map -> reference -> Pp.t +val print_sec_context_typ : env -> Evd.evar_map -> reference -> Pp.t val print_judgment : env -> Evd.evar_map -> EConstr.unsafe_judgment -> Pp.t val print_safe_judgment : env -> Evd.evar_map -> Safe_typing.judgment -> Pp.t val print_eval : reduction_function -> env -> Evd.evar_map -> Constrexpr.constr_expr -> EConstr.unsafe_judgment -> Pp.t -val print_name : reference or_by_notation -> Pp.t -val print_opaque_name : reference -> Pp.t -val print_about : reference or_by_notation -> Pp.t +val print_name : env -> Evd.evar_map -> reference or_by_notation -> Pp.t +val print_opaque_name : env -> Evd.evar_map -> reference -> Pp.t +val print_about : env -> Evd.evar_map -> reference or_by_notation -> Pp.t val print_impargs : reference or_by_notation -> Pp.t (** Pretty-printing functions for classes and coercions *) val print_graph : unit -> Pp.t val print_classes : unit -> Pp.t -val print_coercions : unit -> Pp.t +val print_coercions : env -> Evd.evar_map -> Pp.t val print_path_between : Classops.cl_typ -> Classops.cl_typ -> Pp.t -val print_canonical_projections : unit -> Pp.t +val print_canonical_projections : env -> Evd.evar_map -> Pp.t (** Pretty-printing functions for type classes and instances *) val print_typeclasses : unit -> Pp.t val print_instances : global_reference -> Pp.t val print_all_instances : unit -> Pp.t -val inspect : int -> Pp.t +val inspect : env -> Evd.evar_map -> int -> Pp.t (** {5 Locate} *) @@ -82,15 +82,15 @@ val print_located_other : string -> reference -> Pp.t type object_pr = { print_inductive : MutInd.t -> Pp.t; print_constant_with_infos : Constant.t -> Pp.t; - print_section_variable : variable -> Pp.t; - print_syntactic_def : KerName.t -> Pp.t; + print_section_variable : env -> Evd.evar_map -> variable -> Pp.t; + print_syntactic_def : env -> KerName.t -> Pp.t; print_module : bool -> ModPath.t -> Pp.t; print_modtype : ModPath.t -> Pp.t; - print_named_decl : Context.Named.Declaration.t -> Pp.t; - print_library_entry : bool -> (object_name * Lib.node) -> Pp.t option; - print_context : bool -> int option -> Lib.library_segment -> Pp.t; + print_named_decl : env -> Evd.evar_map -> Context.Named.Declaration.t -> Pp.t; + print_library_entry : env -> Evd.evar_map -> bool -> (object_name * Lib.node) -> Pp.t option; + print_context : env -> Evd.evar_map -> bool -> int option -> Lib.library_segment -> Pp.t; print_typed_value_in_env : Environ.env -> Evd.evar_map -> EConstr.constr * EConstr.types -> Pp.t; - print_eval : reduction_function -> env -> Evd.evar_map -> Constrexpr.constr_expr -> EConstr.unsafe_judgment -> Pp.t + print_eval : Reductionops.reduction_function -> env -> Evd.evar_map -> Constrexpr.constr_expr -> EConstr.unsafe_judgment -> Pp.t; } val set_object_pr : object_pr -> unit diff --git a/printing/printer.ml b/printing/printer.ml index 075b03b7d..d7bb0460d 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -10,7 +10,6 @@ open Pp open CErrors open Util open Names -open Term open Constr open Environ open Globnames @@ -26,9 +25,6 @@ module RelDecl = Context.Rel.Declaration module NamedDecl = Context.Named.Declaration module CompactedDecl = Context.Compacted.Declaration -let get_current_context () = - Pfedit.get_current_context () - let enable_unfocused_goal_printing = ref false let enable_goal_tags_printing = ref false let enable_goal_names_printing = ref false @@ -104,10 +100,10 @@ let pr_econstr_env env sigma c = pr_econstr_core false env sigma c (* NB do not remove the eta-redexes! Global.env() has side-effects... *) let pr_lconstr t = - let (sigma, env) = get_current_context () in + let (sigma, env) = Pfedit.get_current_context () in pr_lconstr_env env sigma t let pr_constr t = - let (sigma, env) = get_current_context () in + let (sigma, env) = Pfedit.get_current_context () in pr_constr_env env sigma t let pr_open_lconstr (_,c) = pr_lconstr c @@ -127,10 +123,10 @@ let pr_constr_under_binders_env = pr_constr_under_binders_env_gen pr_econstr_env let pr_lconstr_under_binders_env = pr_constr_under_binders_env_gen pr_leconstr_env let pr_constr_under_binders c = - let (sigma, env) = get_current_context () in + let (sigma, env) = Pfedit.get_current_context () in pr_constr_under_binders_env env sigma c let pr_lconstr_under_binders c = - let (sigma, env) = get_current_context () in + let (sigma, env) = Pfedit.get_current_context () in pr_lconstr_under_binders_env env sigma c let pr_etype_core goal_concl_style env sigma t = @@ -142,10 +138,10 @@ let pr_ltype_env env sigma c = pr_letype_core false env sigma (EConstr.of_constr let pr_type_env env sigma c = pr_etype_core false env sigma (EConstr.of_constr c) let pr_ltype t = - let (sigma, env) = get_current_context () in + let (sigma, env) = Pfedit.get_current_context () in pr_ltype_env env sigma t let pr_type t = - let (sigma, env) = get_current_context () in + let (sigma, env) = Pfedit.get_current_context () in pr_type_env env sigma t let pr_etype_env env sigma c = pr_etype_core false env sigma c @@ -156,7 +152,7 @@ let pr_ljudge_env env sigma j = (pr_leconstr_env env sigma j.uj_val, pr_leconstr_env env sigma j.uj_type) let pr_ljudge j = - let (sigma, env) = get_current_context () in + let (sigma, env) = Pfedit.get_current_context () in pr_ljudge_env env sigma j let pr_lglob_constr_env env c = @@ -165,10 +161,10 @@ let pr_glob_constr_env env c = pr_constr_expr (extern_glob_constr (Termops.vars_of_env env) c) let pr_lglob_constr c = - let (sigma, env) = get_current_context () in + let (sigma, env) = Pfedit.get_current_context () in pr_lglob_constr_env env c let pr_glob_constr c = - let (sigma, env) = get_current_context () in + let (sigma, env) = Pfedit.get_current_context () in pr_glob_constr_env env c let pr_closed_glob_n_env env sigma n c = @@ -176,7 +172,7 @@ let pr_closed_glob_n_env env sigma n c = let pr_closed_glob_env env sigma c = pr_constr_expr (extern_closed_glob false env sigma c) let pr_closed_glob c = - let (sigma, env) = get_current_context () in + let (sigma, env) = Pfedit.get_current_context () in pr_closed_glob_env env sigma c let pr_lconstr_pattern_env env sigma c = @@ -188,10 +184,10 @@ let pr_cases_pattern t = pr_cases_pattern_expr (extern_cases_pattern Names.Id.Set.empty t) let pr_lconstr_pattern t = - let (sigma, env) = get_current_context () in + let (sigma, env) = Pfedit.get_current_context () in pr_lconstr_pattern_env env sigma t let pr_constr_pattern t = - let (sigma, env) = get_current_context () in + let (sigma, env) = Pfedit.get_current_context () in pr_constr_pattern_env env sigma t let pr_sort sigma s = pr_glob_sort (extern_sort sigma s) @@ -253,11 +249,11 @@ let safe_gen f env sigma c = let safe_pr_lconstr_env = safe_gen pr_lconstr_env let safe_pr_constr_env = safe_gen pr_constr_env let safe_pr_lconstr t = - let (sigma, env) = get_current_context () in + let (sigma, env) = Pfedit.get_current_context () in safe_pr_lconstr_env env sigma t let safe_pr_constr t = - let (sigma, env) = get_current_context () in + let (sigma, env) = Pfedit.get_current_context () in safe_pr_constr_env env sigma t let pr_universe_ctx sigma c = @@ -788,7 +784,7 @@ let pr_goal x = !printer_pr.pr_goal x (* End abstraction layer *) (**********************************************************************) -let pr_open_subgoals ?(proof=Proof_global.give_me_the_proof ()) () = +let pr_open_subgoals ~proof = (* spiwack: it shouldn't be the job of the printer to look up stuff in the [evar_map], I did stuff that way because it was more straightforward, but seriously, [Proof.proof] should return @@ -826,15 +822,13 @@ let pr_open_subgoals ?(proof=Proof_global.give_me_the_proof ()) () = pr_subgoals ~pr_first:true None bsigma seeds shelf [] unfocused_if_needed bgoals_focused end -let pr_nth_open_subgoal n = - let pf = Proof_global.give_me_the_proof () in - let { it=gls ; sigma=sigma } = Proof.V82.subgoals pf in +let pr_nth_open_subgoal ~proof n = + let gls,_,_,_,sigma = Proof.proof proof in pr_subgoal n sigma gls -let pr_goal_by_id id = - let p = Proof_global.give_me_the_proof () in +let pr_goal_by_id ~proof id = try - Proof.in_proof p (fun sigma -> + Proof.in_proof proof (fun sigma -> let g = Evd.evar_key id sigma in pr_selected_subgoal (pr_id id) sigma g) with Not_found -> user_err Pp.(str "No such goal.") @@ -916,7 +910,7 @@ let pr_assumptionset env s = with e when CErrors.noncritical e -> mt () in let safe_pr_ltype_relctx (rctx, typ) = - let sigma, env = get_current_context () in + let sigma, env = Pfedit.get_current_context () in let env = Environ.push_rel_context rctx env in try str " " ++ pr_ltype_env env sigma typ with e when CErrors.noncritical e -> mt () diff --git a/printing/printer.mli b/printing/printer.mli index fbba14ede..e014baa2c 100644 --- a/printing/printer.mli +++ b/printing/printer.mli @@ -27,10 +27,12 @@ val enable_goal_names_printing : bool ref val pr_lconstr_env : env -> evar_map -> constr -> Pp.t val pr_lconstr : constr -> Pp.t +[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_lconstr_goal_style_env : env -> evar_map -> constr -> Pp.t val pr_constr_env : env -> evar_map -> constr -> Pp.t val pr_constr : constr -> Pp.t +[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] 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 @@ -41,14 +43,18 @@ val pr_constr_n_env : env -> evar_map -> Notation_term.tolerability -> co val safe_pr_lconstr_env : env -> evar_map -> constr -> Pp.t val safe_pr_lconstr : constr -> Pp.t +[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val safe_pr_constr_env : env -> evar_map -> constr -> Pp.t val safe_pr_constr : constr -> Pp.t +[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_econstr_env : env -> evar_map -> EConstr.t -> Pp.t val pr_econstr : EConstr.t -> Pp.t +[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_leconstr_env : env -> evar_map -> EConstr.t -> Pp.t val pr_leconstr : EConstr.t -> Pp.t +[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_econstr_n_env : env -> evar_map -> Notation_term.tolerability -> EConstr.t -> Pp.t @@ -57,41 +63,53 @@ val pr_letype_env : env -> evar_map -> EConstr.types -> Pp.t val pr_open_constr_env : env -> evar_map -> open_constr -> Pp.t val pr_open_constr : open_constr -> Pp.t +[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_open_lconstr_env : env -> evar_map -> open_constr -> Pp.t val pr_open_lconstr : open_constr -> Pp.t +[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_constr_under_binders_env : env -> evar_map -> constr_under_binders -> Pp.t val pr_constr_under_binders : constr_under_binders -> Pp.t +[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_lconstr_under_binders_env : env -> evar_map -> constr_under_binders -> Pp.t val pr_lconstr_under_binders : constr_under_binders -> Pp.t +[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_goal_concl_style_env : env -> evar_map -> EConstr.types -> Pp.t val pr_ltype_env : env -> evar_map -> types -> Pp.t val pr_ltype : types -> Pp.t +[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_type_env : env -> evar_map -> types -> Pp.t val pr_type : types -> Pp.t +[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] 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 +[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_ljudge_env : env -> evar_map -> EConstr.unsafe_judgment -> Pp.t * Pp.t val pr_ljudge : EConstr.unsafe_judgment -> Pp.t * Pp.t +[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_lglob_constr_env : env -> 'a glob_constr_g -> Pp.t val pr_lglob_constr : 'a glob_constr_g -> Pp.t +[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_glob_constr_env : env -> 'a glob_constr_g -> Pp.t val pr_glob_constr : 'a glob_constr_g -> Pp.t +[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_lconstr_pattern_env : env -> evar_map -> constr_pattern -> Pp.t val pr_lconstr_pattern : constr_pattern -> Pp.t +[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_constr_pattern_env : env -> evar_map -> constr_pattern -> Pp.t val pr_constr_pattern : constr_pattern -> Pp.t +[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_cases_pattern : cases_pattern -> Pp.t @@ -166,8 +184,8 @@ val pr_subgoals : ?pr_first:bool -> Pp.t option -> evar_map -> evar l val pr_subgoal : int -> evar_map -> goal list -> Pp.t val pr_concl : int -> evar_map -> goal -> Pp.t -val pr_open_subgoals : ?proof:Proof.proof -> unit -> Pp.t -val pr_nth_open_subgoal : int -> Pp.t +val pr_open_subgoals : proof:Proof.proof -> Pp.t +val pr_nth_open_subgoal : proof:Proof.proof -> int -> Pp.t val pr_evar : evar_map -> (evar * evar_info) -> Pp.t val pr_evars_int : evar_map -> int -> evar_info Evar.Map.t -> Pp.t val pr_evars : evar_map -> evar_info Evar.Map.t -> Pp.t @@ -200,13 +218,13 @@ module ContextObjectMap : CMap.ExtS val pr_assumptionset : env -> types ContextObjectMap.t -> Pp.t -val pr_goal_by_id : Id.t -> Pp.t +val pr_goal_by_id : proof:Proof.proof -> Id.t -> 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; pr_subgoal : int -> evar_map -> goal list -> Pp.t; pr_goal : goal sigma -> Pp.t; -};; +} val set_printer_pr : printer_pr -> unit diff --git a/printing/printmod.ml b/printing/printmod.ml index 0abca0160..13a03e9b4 100644 --- a/printing/printmod.ml +++ b/printing/printmod.ml @@ -374,9 +374,12 @@ let rec print_typ_expr env mp locals mty = | MEwith(me,WithDef(idl,(c, _)))-> let env' = None in (* TODO: build a proper environment if env <> None *) let s = String.concat "." (List.map Id.to_string idl) in + (* XXX: What should env and sigma be here? *) + let env = Global.env () in + let sigma = Evd.empty in hov 2 (print_typ_expr env' mp locals me ++ spc() ++ str "with" ++ spc() ++ def "Definition"++ spc() ++ str s ++ spc() ++ str ":="++ spc() - ++ Printer.pr_lconstr c) + ++ Printer.pr_lconstr_env env sigma c) | MEwith(me,WithMod(idl,mp'))-> let s = String.concat "." (List.map Id.to_string idl) in hov 2 (print_typ_expr env mp locals me ++ spc() ++ str "with" ++ spc() ++ diff --git a/proofs/logic.ml b/proofs/logic.ml index 13a4e4ce3..a9ad606a0 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -11,7 +11,6 @@ open CErrors open Util open Names open Nameops -open Term open Constr open Vars open Termops diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index 2d4aba17c..c526ae000 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -51,9 +51,8 @@ end let get_nth_V82_goal i = let p = Proof_global.give_me_the_proof () in - let { it=goals ; sigma = sigma; } = Proof.V82.subgoals p in - try - { it=(List.nth goals (i-1)) ; sigma=sigma; } + let goals,_,_,_,sigma = Proof.proof p in + try { it = List.nth goals (i-1) ; sigma } with Failure _ -> raise NoSuchGoal let get_goal_context_gen i = diff --git a/proofs/proof.ml b/proofs/proof.ml index e24d57f08..413b5fdd7 100644 --- a/proofs/proof.ml +++ b/proofs/proof.ml @@ -163,6 +163,7 @@ let map_structured_proof pfts process_goal: 'a pre_goals = let rec unroll_focus pv = function | (_,_,ctx)::stk -> unroll_focus (Proofview.unfocus ctx pv) stk | [] -> pv + (* spiwack: a proof is considered completed even if its still focused, if the focus doesn't hide any goal. Unfocusing is handled in {!return}. *) @@ -391,10 +392,12 @@ let pr_proof p = (*** Compatibility layer with <=v8.2 ***) module V82 = struct let subgoals p = - Proofview.V82.goals p.proofview + let it, sigma = Proofview.proofview p.proofview in + Evd.{ it; sigma } let background_subgoals p = - Proofview.V82.goals (unroll_focus p.proofview p.focus_stack) + let it, sigma = Proofview.proofview (unroll_focus p.proofview p.focus_stack) in + Evd.{ it; sigma } let top_goal p = let { Evd.it=gls ; sigma=sigma; } = diff --git a/proofs/proof.mli b/proofs/proof.mli index 48aed8225..5756d06b6 100644 --- a/proofs/proof.mli +++ b/proofs/proof.mli @@ -65,7 +65,6 @@ val map_structured_proof : proof -> (Evd.evar_map -> Goal.goal -> 'a) -> ('a pre (*** General proof functions ***) - val start : Evd.evar_map -> (Environ.env * EConstr.types) list -> proof val dependent_start : Proofview.telescope -> proof val initial_goals : proof -> (EConstr.constr * EConstr.types) list @@ -187,6 +186,7 @@ val pr_proof : proof -> Pp.t (*** Compatibility layer with <=v8.2 ***) module V82 : sig val subgoals : proof -> Goal.goal list Evd.sigma + [@@ocaml.deprecated "Use the first and fifth argument of [Proof.proof]"] (* All the subgoals of the proof, including those which are not focused. *) val background_subgoals : proof -> Goal.goal list Evd.sigma diff --git a/stm/asyncTaskQueue.ml b/stm/asyncTaskQueue.ml index e2bce1a96..4662c5543 100644 --- a/stm/asyncTaskQueue.ml +++ b/stm/asyncTaskQueue.ml @@ -14,13 +14,15 @@ let stm_pr_err pp = Format.eprintf "%s] @[%a@]\n%!" (System.process_id ()) Pp.pp let stm_prerr_endline s = if !Flags.debug then begin stm_pr_err (str s) end else () -type 'a worker_status = [ `Fresh | `Old of 'a ] +type cancel_switch = bool ref module type Task = sig type task type competence + type worker_status = Fresh | Old of competence + (* Marshallable *) type request type response @@ -29,15 +31,14 @@ module type Task = sig val extra_env : unit -> string array (* run by the master, on a thread *) - val request_of_task : competence worker_status -> task -> request option - val task_match : competence worker_status -> task -> bool - val use_response : - competence worker_status -> task -> response -> - [ `Stay of competence * task list | `End ] + val request_of_task : worker_status -> task -> request option + val task_match : worker_status -> task -> bool + val use_response : worker_status -> task -> response -> + [ `Stay of competence * task list | `End ] val on_marshal_error : string -> task -> unit val on_task_cancellation_or_expiration_or_slave_death : task option -> unit val forward_feedback : Feedback.feedback -> unit - + (* run by the worker *) val perform : request -> response @@ -47,8 +48,6 @@ module type Task = sig end -type expiration = bool ref - module Make(T : Task) () = struct exception Die @@ -66,38 +65,38 @@ module Make(T : Task) () = struct Response res exception MarshalError of string - + let marshal_to_channel oc data = Marshal.to_channel oc data []; flush oc - + let marshal_err s = raise (MarshalError s) - + let marshal_request oc (req : request) = try marshal_to_channel oc req with Failure s | Invalid_argument s | Sys_error s -> marshal_err ("marshal_request: "^s) - + let unmarshal_request ic = try (CThread.thread_friendly_input_value ic : request) with Failure s | Invalid_argument s | Sys_error s -> marshal_err ("unmarshal_request: "^s) - + let marshal_response oc (res : response) = try marshal_to_channel oc res with Failure s | Invalid_argument s | Sys_error s -> marshal_err ("marshal_response: "^s) - + let unmarshal_response ic = try (CThread.thread_friendly_input_value ic : response) with Failure s | Invalid_argument s | Sys_error s -> marshal_err ("unmarshal_response: "^s) - + let marshal_more_data oc (res : more_data) = try marshal_to_channel oc res with Failure s | Invalid_argument s | Sys_error s -> marshal_err ("marshal_more_data: "^s) - + let unmarshal_more_data ic = try (CThread.thread_friendly_input_value ic : more_data) with Failure s | Invalid_argument s | Sys_error s -> @@ -112,7 +111,7 @@ module Make(T : Task) () = struct module Model = struct type process = Worker.process - type extra = (T.task * expiration) TQueue.t + type extra = (T.task * cancel_switch) TQueue.t let spawn id = let name = Printf.sprintf "%s:%d" !T.name id in @@ -140,7 +139,7 @@ module Make(T : Task) () = struct let { WorkerPool.extra = queue; exit; cancelled } = cpanel in let exit () = report_status ~id "Dead"; exit () in let last_task = ref None in - let worker_age = ref `Fresh in + let worker_age = ref T.Fresh in let got_token = ref false in let giveback_exec_token () = if !got_token then (CoqworkmgrApi.giveback 1; got_token := false) in @@ -213,7 +212,7 @@ module Make(T : Task) () = struct | `Stay(competence, new_tasks) -> last_task := None; giveback_exec_token (); - worker_age := `Old competence; + worker_age := T.Old competence; add_tasks new_tasks in continue () @@ -236,7 +235,7 @@ module Make(T : Task) () = struct type queue = { active : Pool.pool; - queue : (T.task * expiration) TQueue.t; + queue : (T.task * cancel_switch) TQueue.t; cleaner : Thread.t option; } @@ -252,16 +251,16 @@ module Make(T : Task) () = struct queue; cleaner = if size > 0 then Some (Thread.create cleaner queue) else None; } - + let destroy { active; queue } = Pool.destroy active; TQueue.destroy queue let broadcast { queue } = TQueue.broadcast queue - let enqueue_task { queue; active } (t, _ as item) = + let enqueue_task { queue; active } t ~cancel_switch = stm_prerr_endline ("Enqueue task "^T.name_of_task t); - TQueue.push queue item + TQueue.push queue (t, cancel_switch) let cancel_worker { active } n = Pool.cancel n active @@ -339,14 +338,14 @@ module Make(T : Task) () = struct let clear { queue; active } = assert(Pool.is_empty active); (* We allow that only if no slaves *) TQueue.clear queue - + let snapshot { queue; active } = List.map fst (TQueue.wait_until_n_are_waiting_then_snapshot (Pool.n_workers active) queue) let with_n_workers n f = - let q = create n in + let q = create n in try let rc = f q in destroy q; rc with e -> let e = CErrors.push e in destroy q; iraise e diff --git a/stm/asyncTaskQueue.mli b/stm/asyncTaskQueue.mli index 1044e668b..ccd643deb 100644 --- a/stm/asyncTaskQueue.mli +++ b/stm/asyncTaskQueue.mli @@ -6,79 +6,211 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -type 'a worker_status = [ `Fresh | `Old of 'a ] +(** This file provides an API for defining and managing a queue of + tasks to be done by external workers. + A queue of items of type [task] is maintained, then for each task, + a request is generated, then sent to a worker using marshalling. + + The workers will then eventually return a result, using marshalling + again: + ____ ____ ____ ________ + | T1 | T2 | T3 | => [request ] => | Worker | + |____|____|____| <= [response] <= |________| + | Master Proc. | + \--------------/ + + Thus [request] and [response] must be safely marshallable. + + Operations for managing the task queue are provide, see below + for more details. + + *) + +(** The [Task] module type defines an abstract message-processing + queue. *) module type Task = sig + (** Main description of a task. Elements are stored in the "master" + process, and then converted into a request. + *) type task + + (** [competence] stores the information about what kind of work a + worker has completed / has available. *) type competence - (* Marshallable *) + (** A worker_status is: + + - [`Fresh] when a worker is born. + + - [`Old of competence]: When a worker ends a job it can either die + (and be replaced by a fresh new worker) or hang there as an [`Old] + worker. In such case some data can be carried by the [`Old] + constructor, typically used to implement [request_of_task]. + + This allows to implement both one-shot workers and "persistent" + ones. E.g. par: is implement using workers that don't + "reboot". Proof workers do reboot mainly because the vm has some + C state that cannot be cleared, so you have a real memory leak if + you don't reboot the worker. *) + type worker_status = Fresh | Old of competence + + (** Type of input and output data for workers. + + The data must be marshallable as it send through the network + using [Marshal] . *) type request type response - val name : string ref (* UID of the task kind, for -toploop *) + (** UID of the task kind, for -toploop *) + val name : string ref + (** Extra arguments of the task kind, for -toploop *) val extra_env : unit -> string array - (* run by the master, on a thread *) - val request_of_task : competence worker_status -> task -> request option - val task_match : competence worker_status -> task -> bool - val use_response : - competence worker_status -> task -> response -> - [ `Stay of competence * task list | `End ] + (** {5} Master API, it is run by the master, on a thread *) + + (** [request_of_task status t] takes the [status] of the worker + and a task [t] and creates the corresponding [Some request] to be + sent to the worker or it is not valid anymore [None]. *) + val request_of_task : worker_status -> task -> request option + + (** [task_match status tid] Allows to discard tasks based on the + worker status. *) + val task_match : worker_status -> task -> bool + + (** [use_response status t out] + + For a response [out] to a task [t] with [status] we can choose + to end the worker of to keep it alive with some data and + immediately inject extra tasks in the queue. + + For example, the proof worker runs a proof and finds an error, + the response signals that, e.g. + + [ReponseError {state = 34; msg = "oops"}] + + When the manager uses such a response he can tell the worker to + stay there and inject into the queue an extra task requesting + state 33 (to implement efficient proof repair). *) + val use_response : worker_status -> task -> response -> + [ `Stay of competence * task list | `End ] + + (** [on_marshal_error err_msg tid] notifies of marshaling failure. *) val on_marshal_error : string -> task -> unit + + (** [on_task_cancellation_or_expiration_or_slave_death tid] + + These functions are meant to parametrize the worker manager on + the actions to be taken when things go wrong or are cancelled + (you can kill a worker in CoqIDE, or using kill -9...) + + E.g. master can decide to inhabit the (delegate) Future.t with a + closure (to be run in master), i.e. make the document still + checkable. This is what I do for marshaling errors. *) val on_task_cancellation_or_expiration_or_slave_death : task option -> unit + + (** [forward_feedback fb] sends fb to all the workers. *) val forward_feedback : Feedback.feedback -> unit - - (* run by the worker *) + + (** {5} Worker API, it is run by worker, on a different fresh + process *) + + (** [perform in] synchronously processes a request [in] *) val perform : request -> response - (* debugging *) + (** debugging *) val name_of_task : task -> string val name_of_request : request -> string end -type expiration = bool ref +(** [cancel_switch] to be flipped to true by anyone to signal the task + is not relevant anymore. When the STM performs an undo/edit-at, it + crawls the document and flips these flags (the Qed node carries a + pointer to the flag IIRC). +*) +type cancel_switch = bool ref +(** Client-side functor. [MakeQueue T] creates a task queue for task [T] *) module MakeQueue(T : Task) () : sig + (** [queue] is the abstract queue type. *) type queue - (* Number of workers, 0 = lazy local *) + (** [create n] will initialize the queue with [n] workers. If [n] is + 0, the queue won't spawn any process, working in a lazy local + manner. [not imposed by the this API] *) val create : int -> queue + + (** [destroy q] Deallocates [q], cancelling all pending tasks. *) val destroy : queue -> unit + (** [n_workers q] returns the number of workers of [q] *) val n_workers : queue -> int - val enqueue_task : queue -> T.task * expiration -> unit + (** [enqueue_task q t ~cancel_switch] schedules [t] for execution in + [q]. [cancel_switch] can be flipped to true to cancel the task. *) + val enqueue_task : queue -> T.task -> cancel_switch:cancel_switch -> unit - (* blocking function that waits for the task queue to be empty *) + (** [join q] blocks until the task queue is empty *) val join : queue -> unit + + (** [cancel_all q] Cancels all tasks *) val cancel_all : queue -> unit + (** [cancel_worker q wid] cancels a particular worker [wid] *) val cancel_worker : queue -> WorkerPool.worker_id -> unit + (** [set_order q cmp] reorders [q] using ordering [cmp] *) val set_order : queue -> (T.task -> T.task -> int) -> unit + (** [broadcast q] + + This is nasty. Workers can be picky, e.g. pick tasks only when + they are "on screen". Of course the screen is scrolled, and that + changes the potential choice of workers to pick up a task or + not. + + This function wakes up the workers (the managers) that give a + look (again) to the tasks in the queue. + + The STM calls it when the perspective (as in PIDE) changes. + + A problem here is that why task_match has access to the + competence data in order to decide if the task is palatable to + the worker or not... such data is local to the worker (manager). + The perspective is global, so it does not quite fit this + picture. This API to make all managers reconsider the tasks in + the queue is the best I could came up with. + + This API is crucial to Coqoon (or any other UI that invokes + Stm.finish eagerly but wants the workers to "focus" on the visible + part of the document). + *) val broadcast : queue -> unit - (* Take a snapshot (non destructive but waits until all workers are - * enqueued) *) + (** [snapshot q] Takes a snapshot (non destructive but waits until + all workers are enqueued) *) val snapshot : queue -> T.task list - (* Clears the queue, only if the worker prool is empty *) - val clear : queue -> unit - - (* create a queue, run the function, destroy the queue. - * the user should call join *) + (** [clear q] Clears [q], only if the worker prool is empty *) + val clear : queue -> unit + + (** [with_n_workers n f] create a queue, run the function, destroy + the queue. The user should call join *) val with_n_workers : int -> (queue -> 'a) -> 'a end +(** Server-side functor. [MakeWorker T] creates the server task + dispatcher. *) module MakeWorker(T : Task) () : sig - val main_loop : unit -> unit + (** [init_stdout ()] is called at [Coqtop.toploop_init] time. *) val init_stdout : unit -> unit - + + (** [main_loop ()] is called at [Coqtop.toploop_run] time. *) + val main_loop : unit -> unit + end diff --git a/stm/stm.ml b/stm/stm.ml index 864fff9e0..12f414f39 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -48,7 +48,7 @@ let state_computed, state_computed_hook = Hook.make let state_ready, state_ready_hook = Hook.make ~default:(fun state_id -> ()) () -let forward_feedback, forward_feedback_hook = +let forward_feedback, forward_feedback_hook = let m = Mutex.create () in Hook.make ~default:(function | { doc_id = did; span_id = id; route; contents } -> @@ -108,7 +108,6 @@ module Vcs_ = Vcs.Make(Stateid.Self) type future_proof = Proof_global.closed_proof_output Future.computation type proof_mode = string type depth = int -type cancel_switch = bool ref type branch_type = [ `Master | `Proof of proof_mode * depth @@ -122,14 +121,14 @@ type cmd_t = { cids : Names.Id.t list; cblock : proof_block_name option; cqueue : [ `MainQueue - | `TacQueue of solving_tac * anon_abstracting_tac * cancel_switch - | `QueryQueue of cancel_switch + | `TacQueue of solving_tac * anon_abstracting_tac * AsyncTaskQueue.cancel_switch + | `QueryQueue of AsyncTaskQueue.cancel_switch | `SkipQueue ] } type fork_t = aast * Vcs_.Branch.t * Vernacexpr.opacity_guarantee * Names.Id.t list type qed_t = { qast : aast; keep : vernac_qed_type; - mutable fproof : (future_proof * cancel_switch) option; + mutable fproof : (future_proof * AsyncTaskQueue.cancel_switch) option; brname : Vcs_.Branch.t; brinfo : branch_type Vcs_.branch_info } @@ -318,7 +317,7 @@ module VCS : sig (* cuts from start -> stop, raising Expired if some nodes are not there *) val slice : block_start:id -> block_stop:id -> vcs val nodes_in_slice : block_start:id -> block_stop:id -> Stateid.t list - + val create_proof_task_box : id list -> qed:id -> block_start:id -> unit val create_proof_block : static_block_declaration -> string -> unit val box_of : id -> box list @@ -367,7 +366,7 @@ end = struct (* {{{ *) | Noop -> " " | Alias (id,_) -> sprintf "Alias(%s)" (Stateid.to_string id) | Qed { qast } -> Pp.string_of_ppcmds (pr_ast qast) in - let is_green id = + let is_green id = match get_info vcs id with | Some { state = Valid _ } -> true | _ -> false in @@ -435,7 +434,7 @@ end = struct (* {{{ *) let outerboxes boxes = List.filter (fun b -> not (List.exists (fun b1 -> - not (same_box b1 b) && contains b1 b) boxes) + not (same_box b1 b) && contains b1 b) boxes) ) boxes in let rec rec_print b = boxes := CList.remove same_box b !boxes; @@ -565,7 +564,7 @@ end = struct (* {{{ *) let id = new_node () in merge id ~ours:(Sideff action) ~into:b Branch.master) (List.filter (fun b -> not (Branch.equal b Branch.master)) (branches ())) - + let visit id = Vcs_aux.visit !vcs id let nodes_in_slice ~block_start ~block_stop = @@ -664,7 +663,7 @@ end = struct (* {{{ *) val command : now:bool -> (unit -> unit) -> unit end = struct - + let m = Mutex.create () let c = Condition.create () let job = ref None @@ -972,7 +971,7 @@ let get_script prf = find ((x.expr, (VCS.get_info id).n_goals)::acc) view.next | `Sideff (CherryPickEnv, id) -> find acc id | `Cmd {cast = x; ctac} when ctac -> (* skip non-tactics *) - find ((x.expr, (VCS.get_info id).n_goals)::acc) view.next + find ((x.expr, (VCS.get_info id).n_goals)::acc) view.next | `Cmd _ -> find acc view.next | `Alias (id,_) -> find acc id | `Fork _ -> find acc view.next @@ -1138,7 +1137,7 @@ end = struct (* {{{ *) let m = match e with VernacUndoTo m -> m | _ -> 0 in let id = VCS.get_branch_pos (VCS.current_branch ()) in let vcs = - match (VCS.get_info id).vcs_backup with + match (VCS.get_info id).vcs_backup with | None, _ -> anomaly Pp.(str"Backtrack: tip with no vcs_backup.") | Some vcs, _ -> vcs in let cb, _ = @@ -1191,7 +1190,7 @@ let record_pb_time ?loc proof_name time = Aux_file.record_in_aux_at proof_name proof_build_time; hints := Aux_file.set !hints proof_name proof_build_time end - + exception RemoteException of Pp.t let _ = CErrors.register_handler (function | RemoteException ppcmd -> ppcmd @@ -1248,7 +1247,7 @@ let is_block_name_enabled name = | `Only l -> List.mem name l let detect_proof_block id name = - let name = match name with None -> "indent" | Some x -> x in + let name = match name with None -> "indent" | Some x -> x in if is_block_name_enabled name && (Flags.async_proofs_is_master () || Flags.async_proofs_is_worker ()) then ( @@ -1271,7 +1270,7 @@ let detect_proof_block id name = (* Unused module warning doesn't understand [module rec] *) [@@@ocaml.warning "-60"] module rec ProofTask : sig - + type competence = Stateid.t list type task_build_proof = { t_exn_info : Stateid.t * Stateid.t; @@ -1294,8 +1293,8 @@ module rec ProofTask : sig include AsyncTaskQueue.Task with type task := task - and type competence := competence - and type request := request + and type competence := competence + and type request := request val build_proof_here : ?loc:Loc.t -> @@ -1304,7 +1303,7 @@ module rec ProofTask : sig Proof_global.closed_proof_output Future.computation (* If set, only tasks overlapping with this list are processed *) - val set_perspective : Stateid.t list -> unit + val set_perspective : Stateid.t list -> unit end = struct (* {{{ *) @@ -1326,10 +1325,12 @@ end = struct (* {{{ *) | BuildProof of task_build_proof | States of Stateid.t list + type worker_status = Fresh | Old of competence + type request = | ReqBuildProof of (Future.UUID.t,VCS.vcs) Stateid.request * bool * competence | ReqStates of Stateid.t list - + type error = { e_error_at : Stateid.t; e_safe_id : Stateid.t; @@ -1349,10 +1350,10 @@ end = struct (* {{{ *) let task_match age t = match age, t with - | `Fresh, BuildProof { t_states } -> + | Fresh, BuildProof { t_states } -> not !Flags.async_proofs_full || List.exists (fun x -> CList.mem_f Stateid.equal x !perspective) t_states - | `Old my_states, States l -> + | Old my_states, States l -> List.for_all (fun x -> CList.mem_f Stateid.equal x my_states) l | _ -> false @@ -1368,7 +1369,7 @@ end = struct (* {{{ *) | BuildProof { t_exn_info;t_start;t_stop;t_loc;t_uuid;t_name;t_states;t_drop } -> - assert(age = `Fresh); + assert(age = Fresh); try Some (ReqBuildProof ({ Stateid.exn_info = t_exn_info; stop = t_stop; @@ -1378,11 +1379,11 @@ end = struct (* {{{ *) name = t_name }, t_drop, t_states)) with VCS.Expired -> None - let use_response (s : competence AsyncTaskQueue.worker_status) t r = + let use_response (s : worker_status) t r = match s, t, r with - | `Old c, States _, RespStates l -> + | Old c, States _, RespStates l -> List.iter (fun (id,s) -> State.assign id s) l; `End - | `Fresh, BuildProof { t_assign; t_loc; t_name; t_states; t_drop }, + | Fresh, BuildProof { t_assign; t_loc; t_name; t_states; t_drop }, RespBuiltProof (pl, time) -> feedback (InProgress ~-1); t_assign (`Val pl); @@ -1390,7 +1391,7 @@ end = struct (* {{{ *) if !Flags.async_proofs_full || t_drop then `Stay(t_states,[States t_states]) else `End - | `Fresh, BuildProof { t_assign; t_loc; t_name; t_states }, + | Fresh, BuildProof { t_assign; t_loc; t_name; t_states }, RespError { e_error_at; e_safe_id = valid; e_msg; e_safe_states } -> feedback (InProgress ~-1); let info = Stateid.add ~valid Exninfo.null e_error_at in @@ -1477,7 +1478,7 @@ end = struct (* {{{ *) | VtProofStep _, _ -> true | _ -> false in - let initial = + let initial = let rec aux id = try match VCS.visit id with { next } -> aux next with VCS.Expired -> id in @@ -1490,7 +1491,7 @@ end = struct (* {{{ *) then Some (prev, State.get_cached prev, step) else None with VCS.Expired -> None in - let this = + let this = if State.is_cached_and_valid id then Some (State.get_cached id) else None in match prev, this with | _, None -> None @@ -1532,11 +1533,11 @@ and Slaves : sig val build_proof : ?loc:Loc.t -> drop_pt:bool -> exn_info:(Stateid.t * Stateid.t) -> block_start:Stateid.t -> block_stop:Stateid.t -> - name:string -> future_proof * cancel_switch + name:string -> future_proof * AsyncTaskQueue.cancel_switch (* blocking function that waits for the task queue to be empty *) val wait_all_done : unit -> unit - + (* initialize the whole machinery (optional) *) val init : unit -> unit @@ -1558,7 +1559,7 @@ and Slaves : sig end = struct (* {{{ *) module TaskQueue = AsyncTaskQueue.MakeQueue(ProofTask) () - + let queue = ref None let init () = if Flags.async_proofs_is_master () then @@ -1613,8 +1614,8 @@ end = struct (* {{{ *) | Some (_, cur) -> match VCS.visit cur with | { step = `Cmd { cast = { loc } } } - | { step = `Fork (( { loc }, _, _, _), _) } - | { step = `Qed ( { qast = { loc } }, _) } + | { step = `Fork (( { loc }, _, _, _), _) } + | { step = `Qed ( { qast = { loc } }, _) } | { step = `Sideff (ReplayCommand { loc }, _) } -> let start, stop = Option.cata Loc.unloc (0,0) loc in msg_error Pp.( @@ -1664,7 +1665,7 @@ end = struct (* {{{ *) u.(bucket) <- uc; p.(bucket) <- pr; u, Univ.ContextSet.union cst extra, false - + let check_task name l i = match check_task_aux "" name l i with | `OK _ | `OK_ADMITTED -> true @@ -1709,11 +1710,11 @@ end = struct (* {{{ *) t_exn_info; t_start = block_start; t_stop = block_stop; t_drop = drop_pt; t_assign = assign; t_loc = loc; t_uuid; t_name = pname; t_states = VCS.nodes_in_slice ~block_start ~block_stop }) in - TaskQueue.enqueue_task (Option.get !queue) (task,cancel_switch); + TaskQueue.enqueue_task (Option.get !queue) task ~cancel_switch; f, cancel_switch end else ProofTask.build_proof_here ?loc ~drop_pt t_exn_info block_stop, cancel_switch - else + else let f, t_assign = Future.create_delegate ~name:pname (State.exn_on id ~valid) in let t_uuid = Future.uuid f in feedback (InProgress 1); @@ -1721,7 +1722,7 @@ end = struct (* {{{ *) t_exn_info; t_start = block_start; t_stop = block_stop; t_assign; t_drop = drop_pt; t_loc = loc; t_uuid; t_name = pname; t_states = VCS.nodes_in_slice ~block_start ~block_stop }) in - TaskQueue.enqueue_task (Option.get !queue) (task,cancel_switch); + TaskQueue.enqueue_task (Option.get !queue) task ~cancel_switch; f, cancel_switch let wait_all_done () = TaskQueue.join (Option.get !queue) @@ -1735,7 +1736,7 @@ end = struct (* {{{ *) let reqs = CList.map_filter ProofTask.(fun x -> - match request_of_task `Fresh x with + match request_of_task Fresh x with | Some (ReqBuildProof (r, b, _)) -> Some(r, b) | _ -> None) tasks in @@ -1756,14 +1757,14 @@ and TacTask : sig t_ast : int * aast; t_goal : Goal.goal; t_kill : unit -> unit; - t_name : string } + t_name : string } include AsyncTaskQueue.Task with type task := task end = struct (* {{{ *) type output = (Constr.constr * UState.t) option - + let forward_feedback msg = Hooks.(call forward_feedback msg) type task = { @@ -1773,7 +1774,7 @@ end = struct (* {{{ *) t_ast : int * aast; t_goal : Goal.goal; t_kill : unit -> unit; - t_name : string } + t_name : string } type request = { r_state : Stateid.t; @@ -1791,6 +1792,8 @@ end = struct (* {{{ *) let name = ref "tacworker" let extra_env () = [||] type competence = unit + type worker_status = Fresh | Old of competence + let task_match _ _ = true (* run by the master, on a thread *) @@ -1799,13 +1802,13 @@ end = struct (* {{{ *) r_state = t_state; r_state_fb = t_state_fb; r_document = - if age <> `Fresh then None + if age <> Fresh then None else Some (VCS.slice ~block_start:t_state ~block_stop:t_state); r_ast = t_ast; r_goal = t_goal; r_name = t_name } with VCS.Expired -> None - + let use_response _ { t_assign; t_state; t_state_fb; t_kill } resp = match resp with | RespBuiltSubProof o -> t_assign (`Val (Some o)); `Stay ((),[]) @@ -1818,7 +1821,7 @@ end = struct (* {{{ *) t_assign (`Exn e); t_kill (); `Stay ((),[]) - + let on_marshal_error err { t_name } = stm_pr_err ("Fatal marshal error: " ^ t_name ); flush_all (); exit 1 @@ -1826,7 +1829,7 @@ end = struct (* {{{ *) let on_task_cancellation_or_expiration_or_slave_death = function | Some { t_kill } -> t_kill () | _ -> () - + let command_focus = Proof.new_focus_kind () let focus_cond = Proof.no_cond command_focus @@ -1871,21 +1874,20 @@ end = struct (* {{{ *) let name_of_task { t_name } = t_name let name_of_request { r_name } = r_name - + end (* }}} *) and Partac : sig val vernac_interp : - solve:bool -> abstract:bool -> cancel_switch -> - int -> Stateid.t -> Stateid.t -> aast -> - unit + solve:bool -> abstract:bool -> cancel_switch:AsyncTaskQueue.cancel_switch -> + int -> Stateid.t -> Stateid.t -> aast -> unit end = struct (* {{{ *) - + module TaskQueue = AsyncTaskQueue.MakeQueue(TacTask) () - let vernac_interp ~solve ~abstract cancel nworkers safe_id id + let vernac_interp ~solve ~abstract ~cancel_switch nworkers safe_id id { indentation; verbose; loc; expr = e; strlen } = let e, time, fail = @@ -1909,10 +1911,10 @@ end = struct (* {{{ *) let t_ast = (i, { indentation; verbose; loc; expr = e; strlen }) in let t_name = Goal.uid g in TaskQueue.enqueue_task queue - ({ t_state = safe_id; t_state_fb = id; + { t_state = safe_id; t_state_fb = id; t_assign = assign; t_ast; t_goal = g; t_name; - t_kill = (fun () -> if solve then TaskQueue.cancel_all queue) }, - cancel); + t_kill = (fun () -> if solve then TaskQueue.cancel_all queue) } + ~cancel_switch; g,f) 1 goals in TaskQueue.join queue; @@ -1931,9 +1933,10 @@ end = struct (* {{{ *) let open Notations in match Future.join f with | Some (pt, uc) -> + let sigma, env = Pfedit.get_current_context () in stm_pperr_endline (fun () -> hov 0 ( str"g=" ++ int (Evar.repr gid) ++ spc () ++ - str"t=" ++ (Printer.pr_constr pt) ++ spc () ++ + str"t=" ++ (Printer.pr_constr_env env sigma pt) ++ spc () ++ str"uc=" ++ Termops.pr_evar_universe_context uc)); (if abstract then Tactics.tclABSTRACT None else (fun x -> x)) (V82.tactic (Refiner.tclPUSHEVARUNIVCONTEXT uc) <*> @@ -1943,7 +1946,7 @@ end = struct (* {{{ *) end) in Proof.run_tactic (Global.env()) assign_tac p)))) ()) - + end (* }}} *) and QueryTask : sig @@ -1952,10 +1955,10 @@ and QueryTask : sig include AsyncTaskQueue.Task with type task := task end = struct (* {{{ *) - + type task = { t_where : Stateid.t; t_for : Stateid.t ; t_what : aast } - + type request = { r_where : Stateid.t ; r_for : Stateid.t ; r_what : aast; r_doc : VCS.vcs } type response = unit @@ -1963,6 +1966,8 @@ end = struct (* {{{ *) let name = ref "queryworker" let extra_env _ = [||] type competence = unit + type worker_status = Fresh | Old of competence + let task_match _ _ = true let request_of_task _ { t_where; t_what; t_for } = @@ -1972,7 +1977,7 @@ end = struct (* {{{ *) r_doc = VCS.slice ~block_start:t_where ~block_stop:t_where; r_what = t_what } with VCS.Expired -> None - + let use_response _ _ _ = `End let on_marshal_error _ _ = @@ -1980,7 +1985,7 @@ end = struct (* {{{ *) flush_all (); exit 1 let on_task_cancellation_or_expiration_or_slave_death _ = () - + let forward_feedback msg = Hooks.(call forward_feedback msg) let perform { r_where; r_doc; r_what; r_for } = @@ -2000,16 +2005,16 @@ end = struct (* {{{ *) let e = CErrors.push e in let msg = iprint e in feedback ~id:r_for (Message (Error, None, msg)) - + let name_of_task { t_what } = string_of_ppcmds (pr_ast t_what) let name_of_request { r_what } = string_of_ppcmds (pr_ast r_what) end (* }}} *) -and Query : sig +and Query : sig val init : unit -> unit - val vernac_interp : cancel_switch -> Stateid.t -> Stateid.t -> aast -> unit + val vernac_interp : cancel_switch:AsyncTaskQueue.cancel_switch -> Stateid.t -> Stateid.t -> aast -> unit end = struct (* {{{ *) @@ -2017,10 +2022,10 @@ end = struct (* {{{ *) let queue = ref None - let vernac_interp switch prev id q = + let vernac_interp ~cancel_switch prev id q = assert(TaskQueue.n_workers (Option.get !queue) > 0); TaskQueue.enqueue_task (Option.get !queue) - QueryTask.({ t_where = prev; t_for = id; t_what = q }, switch) + QueryTask.({ t_where = prev; t_for = id; t_what = q }) ~cancel_switch let init () = queue := Some (TaskQueue.create (if !Flags.async_proofs_full then 1 else 0)) @@ -2049,7 +2054,7 @@ let delegate name = get_hint_bp_time name >= !Flags.async_proofs_delegation_threshold || VCS.is_vio_doc () || !Flags.async_proofs_full - + let warn_deprecated_nested_proofs = CWarnings.create ~name:"deprecated-nested-proofs" ~category:"deprecated" (fun () -> @@ -2175,7 +2180,7 @@ let log_processing_sync id name reason = log_string Printf.(sprintf let wall_clock_last_fork = ref 0.0 let known_state ?(redefine_qed=false) ~cache id = - + let error_absorbing_tactic id blockname exn = (* We keep the static/dynamic part of block detection separate, since the static part could be performed earlier. As of today there is @@ -2277,17 +2282,17 @@ let known_state ?(redefine_qed=false) ~cache id = ), cache, true | `Cmd { cast = x; cqueue = `SkipQueue } -> (fun () -> reach view.next), cache, true - | `Cmd { cast = x; cqueue = `TacQueue (solve,abstract,cancel); cblock } -> + | `Cmd { cast = x; cqueue = `TacQueue (solve,abstract,cancel_switch); cblock } -> (fun () -> resilient_tactic id cblock (fun () -> reach ~cache:`Shallow view.next; - Partac.vernac_interp ~solve ~abstract - cancel !Flags.async_proofs_n_tacworkers view.next id x) + Partac.vernac_interp ~solve ~abstract ~cancel_switch + !Flags.async_proofs_n_tacworkers view.next id x) ), cache, true - | `Cmd { cast = x; cqueue = `QueryQueue cancel } + | `Cmd { cast = x; cqueue = `QueryQueue cancel_switch } when Flags.async_proofs_is_master () -> (fun () -> reach view.next; - Query.vernac_interp cancel view.next id x + Query.vernac_interp ~cancel_switch view.next id x ), cache, false | `Cmd { cast = x; ceff = eff; ctac = true; cblock } -> (fun () -> resilient_tactic id cblock (fun () -> @@ -2376,7 +2381,7 @@ let known_state ?(redefine_qed=false) ~cache id = end; Proof_global.discard_all () ), (if redefine_qed then `No else `Yes), true - | `Sync (name, `Immediate) -> (fun () -> + | `Sync (name, `Immediate) -> (fun () -> reach eop; let st = Vernacstate.freeze_interp_state `No in ignore(stm_vernac_interp id st x); @@ -2831,7 +2836,7 @@ let process_transaction ?(newtip=Stateid.fresh ()) ?(part_of_script=true) let get_ast ~doc id = match VCS.visit id with | { step = `Cmd { cast = { loc; expr } } } - | { step = `Fork (({ loc; expr }, _, _, _), _) } + | { step = `Fork (({ loc; expr }, _, _, _), _) } | { step = `Qed ({ qast = { loc; expr } }, _) } -> Some (Loc.tag ?loc expr) | _ -> None diff --git a/tactics/auto.ml b/tactics/auto.ml index d0424eb89..fa8435d1f 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -388,7 +388,7 @@ and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t;poly=poly;db= Tacticals.New.tclPROGRESS (reduce (Unfold [AllOccurrences,c]) Locusops.onConcl) else Tacticals.New.tclFAIL 0 (str"Unbound reference") end - | Extern tacast -> + | Extern tacast -> conclPattern concl p tacast in let pr_hint () = @@ -396,7 +396,8 @@ and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t;poly=poly;db= | None -> mt () | Some n -> str " (in " ++ str n ++ str ")" in - pr_hint t ++ origin + let sigma, env = Pfedit.get_current_context () in + pr_hint env sigma t ++ origin in tclLOG dbg pr_hint (run_hint t tactic) diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index e68087f14..de98f6382 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -9,7 +9,6 @@ open Equality open Names open Pp -open Term open Constr open Termops open CErrors @@ -74,12 +73,12 @@ let find_matches bas pat = let res = HintDN.search_pattern base pat in List.map snd res -let print_rewrite_hintdb bas = +let print_rewrite_hintdb env sigma bas = (str "Database " ++ str bas ++ fnl () ++ prlist_with_sep fnl (fun h -> str (if h.rew_l2r then "rewrite -> " else "rewrite <- ") ++ - Printer.pr_lconstr h.rew_lemma ++ str " of type " ++ Printer.pr_lconstr h.rew_type ++ + Printer.pr_lconstr_env env sigma h.rew_lemma ++ str " of type " ++ Printer.pr_lconstr_env env sigma h.rew_type ++ Option.cata (fun tac -> str " then use tactic " ++ Pputils.pr_glb_generic (Global.env()) tac) (mt ()) h.rew_tac) (find_rewrites bas)) diff --git a/tactics/autorewrite.mli b/tactics/autorewrite.mli index d2b5e070b..44acf3c01 100644 --- a/tactics/autorewrite.mli +++ b/tactics/autorewrite.mli @@ -40,7 +40,7 @@ val auto_multi_rewrite : ?conds:conditions -> string list -> Locus.clause -> uni val auto_multi_rewrite_with : ?conds:conditions -> unit Proofview.tactic -> string list -> Locus.clause -> unit Proofview.tactic -val print_rewrite_hintdb : string -> Pp.t +val print_rewrite_hintdb : Environ.env -> Evd.evar_map -> string -> Pp.t open Clenv diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index b98b10315..cee6d4bea 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -464,15 +464,16 @@ and e_my_find_search db_list local_db secvars hdc complete only_classes sigma co in let tac = run_hint t tac in let tac = if complete then Tacticals.New.tclCOMPLETE tac else tac in + let _, env = Pfedit.get_current_context () in let pp = match p with | Some pat when get_typeclasses_filtered_unification () -> - str " with pattern " ++ Printer.pr_constr_pattern pat + str " with pattern " ++ Printer.pr_constr_pattern_env env sigma pat | _ -> mt () in match repr_hint t with - | Extern _ -> (tac, b, true, name, lazy (pr_hint t ++ pp)) - | _ -> (tac, b, false, name, lazy (pr_hint t ++ pp)) + | Extern _ -> (tac, b, true, name, lazy (pr_hint env sigma t ++ pp)) + | _ -> (tac, b, false, name, lazy (pr_hint env sigma t ++ pp)) in List.map tac_of_hint hintl and e_trivial_resolve db_list local_db secvars only_classes sigma concl = diff --git a/tactics/eauto.ml b/tactics/eauto.ml index 239661498..f5c6ab879 100644 --- a/tactics/eauto.ml +++ b/tactics/eauto.ml @@ -178,7 +178,8 @@ and e_my_find_search sigma db_list local_db secvars hdc concl = | Extern tacast -> conclPattern concl p tacast in let tac = run_hint t tac in - (tac, lazy (pr_hint t))) + let sigma, env = Pfedit.get_current_context () in + (tac, lazy (pr_hint env sigma t))) in List.map tac_of_hint hintl diff --git a/tactics/hints.ml b/tactics/hints.ml index c7c53b393..70e84013b 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -1392,14 +1392,14 @@ let make_db_list dbnames = (* Functions for printing the hints *) (**************************************************************************) -let pr_hint_elt (c, _, _) = pr_econstr c +let pr_hint_elt env sigma (c, _, _) = pr_econstr_env env sigma c -let pr_hint h = match h.obj with - | Res_pf (c, _) -> (str"simple apply " ++ pr_hint_elt c) - | ERes_pf (c, _) -> (str"simple eapply " ++ pr_hint_elt c) - | Give_exact (c, _) -> (str"exact " ++ pr_hint_elt c) +let pr_hint env sigma h = match h.obj with + | Res_pf (c, _) -> (str"simple apply " ++ pr_hint_elt env sigma c) + | ERes_pf (c, _) -> (str"simple eapply " ++ pr_hint_elt env sigma c) + | Give_exact (c, _) -> (str"exact " ++ pr_hint_elt env sigma c) | Res_pf_THEN_trivial_fail (c, _) -> - (str"simple apply " ++ pr_hint_elt c ++ str" ; trivial") + (str"simple apply " ++ pr_hint_elt env sigma c ++ str" ; trivial") | Unfold_nth c -> (str"unfold " ++ pr_evaluable_reference c) | Extern tac -> let env = @@ -1410,21 +1410,21 @@ let pr_hint h = match h.obj with in (str "(*external*) " ++ Pputils.pr_glb_generic env tac) -let pr_id_hint (id, v) = - let pr_pat p = str", pattern " ++ pr_lconstr_pattern p in - (pr_hint v.code ++ str"(level " ++ int v.pri ++ pr_opt_no_spc pr_pat v.pat +let pr_id_hint env sigma (id, v) = + let pr_pat p = str", pattern " ++ pr_lconstr_pattern_env env sigma p in + (pr_hint env sigma v.code ++ str"(level " ++ int v.pri ++ pr_opt_no_spc pr_pat v.pat ++ str", id " ++ int id ++ str ")" ++ spc ()) -let pr_hint_list hintlist = - (str " " ++ hov 0 (prlist pr_id_hint hintlist) ++ fnl ()) +let pr_hint_list env sigma hintlist = + (str " " ++ hov 0 (prlist (pr_id_hint env sigma) hintlist) ++ fnl ()) -let pr_hints_db (name,db,hintlist) = +let pr_hints_db env sigma (name,db,hintlist) = (str "In the database " ++ str name ++ str ":" ++ if List.is_empty hintlist then (str " nothing" ++ fnl ()) - else (fnl () ++ pr_hint_list hintlist)) + else (fnl () ++ pr_hint_list env sigma hintlist)) (* Print all hints associated to head c in any database *) -let pr_hint_list_for_head c = +let pr_hint_list_for_head env sigma c = let dbs = current_db () in let validate (name, db) = let hints = List.map (fun v -> 0, v) (Hint_db.map_all ~secvars:Id.Pred.full c db) in @@ -1436,13 +1436,13 @@ let pr_hint_list_for_head c = else hov 0 (str"For " ++ pr_global c ++ str" -> " ++ fnl () ++ - hov 0 (prlist pr_hints_db valid_dbs)) + hov 0 (prlist (pr_hints_db env sigma) valid_dbs)) let pr_hint_ref ref = pr_hint_list_for_head ref (* Print all hints associated to head id in any database *) -let pr_hint_term sigma cl = +let pr_hint_term env sigma cl = try let dbs = current_db () in let valid_dbs = @@ -1460,18 +1460,19 @@ let pr_hint_term sigma cl = (str "No hint applicable for current goal") else (str "Applicable Hints :" ++ fnl () ++ - hov 0 (prlist pr_hints_db valid_dbs)) + hov 0 (prlist (pr_hints_db env sigma) valid_dbs)) with Match_failure _ | Failure _ -> (str "No hint applicable for current goal") (* print all hints that apply to the concl of the current goal *) let pr_applicable_hint () = + let env = Global.env () in let pts = Proof_global.give_me_the_proof () in - let glss = Proof.V82.subgoals pts in - match glss.Evd.it with + let glss,_,_,_,sigma = Proof.proof pts in + match glss with | [] -> CErrors.user_err Pp.(str "No focused goal.") | g::_ -> - pr_hint_term glss.Evd.sigma (Goal.V82.concl glss.Evd.sigma g) + pr_hint_term env sigma (Goal.V82.concl sigma g) let pp_hint_mode = function | ModeInput -> str"+" @@ -1479,9 +1480,9 @@ let pp_hint_mode = function | ModeOutput -> str"-" (* displays the whole hint database db *) -let pr_hint_db db = +let pr_hint_db_env env sigma db = let pr_mode = prvect_with_sep spc pp_hint_mode in - let pr_modes l = + let pr_modes l = if List.is_empty l then mt () else str" (modes " ++ prlist_with_sep pr_comma pr_mode l ++ str")" in @@ -1491,7 +1492,7 @@ let pr_hint_db db = | None -> str "For any goal" | Some head -> str "For " ++ pr_global head ++ pr_modes modes in - let hints = pr_hint_list (List.map (fun x -> (0, x)) hintlist) in + let hints = pr_hint_list env sigma (List.map (fun x -> (0, x)) hintlist) in let hint_descr = hov 0 (goal_descr ++ str " -> " ++ hints) in accu ++ hint_descr in @@ -1506,17 +1507,21 @@ let pr_hint_db db = hov 2 (str"Cut: " ++ pp_hints_path (Hint_db.cut db)) ++ fnl () ++ content -let pr_hint_db_by_name dbname = +let pr_hint_db db = + let sigma, env = Pfedit.get_current_context () in + pr_hint_db_env env sigma db + +let pr_hint_db_by_name env sigma dbname = try - let db = searchtable_map dbname in pr_hint_db db + let db = searchtable_map dbname in pr_hint_db_env env sigma db with Not_found -> error_no_such_hint_database dbname (* displays all the hints of all databases *) -let pr_searchtable () = +let pr_searchtable env sigma = let fold name db accu = accu ++ str "In the database " ++ str name ++ str ":" ++ fnl () ++ - pr_hint_db db ++ fnl () + pr_hint_db_env env sigma db ++ fnl () in Hintdbmap.fold fold !searchtable (mt ()) @@ -1534,10 +1539,13 @@ let warn_non_imported_hint = strbrk "Hint used but not imported: " ++ hint ++ print_mp mp) let warn h x = - let hint = pr_hint h in - let (mp, _, _) = KerName.repr h.uid in - warn_non_imported_hint (hint,mp); - Proofview.tclUNIT x + let open Proofview in + tclBIND tclENV (fun env -> + tclBIND tclEVARMAP (fun sigma -> + let hint = pr_hint env sigma h in + let (mp, _, _) = KerName.repr h.uid in + warn_non_imported_hint (hint,mp); + Proofview.tclUNIT x)) let run_hint tac k = match !warn_hint with | `LAX -> k tac.obj diff --git a/tactics/hints.mli b/tactics/hints.mli index 22df29b80..cbf204981 100644 --- a/tactics/hints.mli +++ b/tactics/hints.mli @@ -260,14 +260,15 @@ val rewrite_db : hint_db_name (** Printing hints *) -val pr_searchtable : unit -> Pp.t +val pr_searchtable : env -> evar_map -> Pp.t val pr_applicable_hint : unit -> Pp.t -val pr_hint_ref : global_reference -> Pp.t -val pr_hint_db_by_name : hint_db_name -> Pp.t +val pr_hint_ref : env -> evar_map -> global_reference -> Pp.t +val pr_hint_db_by_name : env -> evar_map -> hint_db_name -> Pp.t +val pr_hint_db_env : env -> evar_map -> Hint_db.t -> Pp.t val pr_hint_db : Hint_db.t -> Pp.t -val pr_hint : hint -> Pp.t +[@@ocaml.deprecated "please used pr_hint_db_env"] +val pr_hint : env -> evar_map -> hint -> Pp.t (** Hook for changing the initialization of auto *) - val add_hints_init : (unit -> unit) -> unit diff --git a/tactics/hipattern.ml b/tactics/hipattern.ml index 75fae6647..8e851375a 100644 --- a/tactics/hipattern.ml +++ b/tactics/hipattern.ml @@ -160,7 +160,7 @@ let test_strict_disjunction n lc = let open Term in Array.for_all_i (fun i c -> match (prod_assum (snd (decompose_prod_n_assum n c))) with - | [LocalAssum (_,c)] -> isRel c && Int.equal (destRel c) (n - i) + | [LocalAssum (_,c)] -> Constr.isRel c && Int.equal (Constr.destRel c) (n - i) | _ -> false) 0 lc let match_with_disjunction ?(strict=false) ?(onlybinary=false) sigma t = diff --git a/tactics/inv.ml b/tactics/inv.ml index 8648dfb90..46b10bf33 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -282,10 +282,11 @@ let generalizeRewriteIntros as_mode tac depids id = let error_too_many_names pats = let loc = Loc.merge_opt (fst (List.hd pats)) (fst (List.last pats)) in Proofview.tclENV >>= fun env -> + Proofview.tclEVARMAP >>= fun sigma -> tclZEROMSG ?loc ( str "Unexpected " ++ str (String.plural (List.length pats) "introduction pattern") ++ - str ": " ++ pr_enum (Miscprint.pr_intro_pattern (fun c -> Printer.pr_constr (EConstr.Unsafe.to_constr (snd (c env Evd.empty))))) pats ++ + str ": " ++ pr_enum (Miscprint.pr_intro_pattern (fun c -> Printer.pr_constr_env env sigma (EConstr.Unsafe.to_constr (snd (c env Evd.empty))))) pats ++ str ".") let get_names (allow_conj,issimple) (loc, pat as x) = match pat with diff --git a/tactics/leminv.ml b/tactics/leminv.ml index cc9d98f6f..62f3866de 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -215,7 +215,7 @@ let inversion_scheme env sigma t sort dep_option inv_op = invEnv ~init:Context.Named.empty end in let avoid = ref Id.Set.empty in - let { sigma=sigma } = Proof.V82.subgoals pf in + let _,_,_,_,sigma = Proof.proof pf in let sigma = Evd.nf_constraints sigma in let rec fill_holes c = match EConstr.kind sigma c with diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 15c25b346..e072bd95f 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -945,10 +945,14 @@ let reduction_clause redexp cl = (None, bind_red_expr_occurrences occs nbcl redexp)) cl let reduce redexp cl = - let trace () = + let trace env sigma = let open Printer in - let pr = (pr_econstr, pr_leconstr, pr_evaluable_reference, pr_constr_pattern) in - Pp.(hov 2 (Pputils.pr_red_expr pr str redexp)) + let pr = (pr_econstr_env, pr_leconstr_env, pr_evaluable_reference, pr_constr_pattern_env) in + Pp.(hov 2 (Pputils.pr_red_expr_env env sigma pr str redexp)) + in + let trace () = + let sigma, env = Pfedit.get_current_context () in + trace env sigma in Proofview.Trace.name_tactic trace begin Proofview.Goal.enter begin fun gl -> @@ -3128,11 +3132,11 @@ let expand_hyp id = Tacticals.New.tclTRY (unfold_body id) <*> clear [id] let warn_unused_intro_pattern env sigma = CWarnings.create ~name:"unused-intro-pattern" ~category:"tactics" - (fun names -> - strbrk"Unused introduction " ++ str (String.plural (List.length names) "pattern") - ++ str": " ++ prlist_with_sep spc - (Miscprint.pr_intro_pattern - (fun c -> Printer.pr_econstr (snd (c env sigma)))) names) + (fun names -> + strbrk"Unused introduction " ++ str (String.plural (List.length names) "pattern") ++ + str": " ++ prlist_with_sep spc + (Miscprint.pr_intro_pattern + (fun c -> Printer.pr_econstr_env env sigma (snd (c env sigma)))) names) let check_unused_names env sigma names = if not (List.is_empty names) then diff --git a/test-suite/Makefile b/test-suite/Makefile index 7a204bfd8..f169f86e8 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -174,7 +174,7 @@ summary.log: # if not on travis we can get the log files (they're just there for a # local build, and downloadable on GitLab) report: summary.log - $(HIDE)./save-logs.sh + $(HIDE)bash save-logs.sh $(HIDE)if [ -n "${TRAVIS}" ]; then find logs/ -name '*.log' -not -name 'summary.log' -exec 'bash' '-c' 'echo "travis_fold:start:coq.logs.$$(echo '{}' | sed s,/,.,g)"' ';' -exec cat '{}' ';' -exec 'bash' '-c' 'echo "travis_fold:end:coq.logs.$$(echo '{}' | sed s,/,.,g)"' ';'; fi $(HIDE)if [ -n "${APPVEYOR}" ]; then find logs/ -name '*.log' -not -name 'summary.log' -exec 'bash' '-c' 'echo {}' ';' -exec cat '{}' ';' -exec 'bash' '-c' 'echo' ';'; fi $(HIDE)if grep -q -F 'Error!' summary.log ; then echo FAILURES; grep -F 'Error!' summary.log; false; else echo NO FAILURES; fi @@ -528,7 +528,7 @@ coq-makefile/%.log : coq-makefile/%/run.sh $(HIDE)(\ export COQBIN=$(BIN);\ cd coq-makefile/$* && \ - ./run.sh 2>&1; \ + bash run.sh 2>&1; \ if [ $$? = 0 ]; then \ echo $(log_success); \ echo " $<...Ok"; \ diff --git a/test-suite/bugs/closed/5215.v b/test-suite/bugs/closed/5215.v new file mode 100644 index 000000000..ecf529159 --- /dev/null +++ b/test-suite/bugs/closed/5215.v @@ -0,0 +1,286 @@ +Require Import Coq.Logic.FunctionalExtensionality. +Require Import Coq.Program.Tactics. + +Global Set Primitive Projections. + +Global Set Universe Polymorphism. + +Global Unset Universe Minimization ToSet. + +Class Category : Type := +{ + Obj : Type; + Hom : Obj -> Obj -> Type; + compose : forall {a b c : Obj}, (Hom a b) -> (Hom b c) -> (Hom a c); + id : forall {a : Obj}, Hom a a; +}. + +Arguments Obj {_}, _. +Arguments id {_ _}, {_} _, _ _. +Arguments Hom {_} _ _, _ _ _. +Arguments compose {_} {_ _ _} _ _, _ {_ _ _} _ _, _ _ _ _ _ _. + +Coercion Obj : Category >-> Sortclass. + +Definition Opposite (C : Category) : Category := +{| + + Obj := Obj C; + Hom := fun a b => Hom b a; + compose := + fun a b c (f : Hom b a) (g : Hom c b) => compose C c b a g f; + id := fun c => id C c; +|}. + +Record Functor (C C' : Category) : Type := +{ + FO : C -> C'; + FA : forall {a b}, Hom a b -> Hom (FO a) (FO b); +}. + +Arguments FO {_ _} _ _. +Arguments FA {_ _} _ {_ _} _, {_ _} _ _ _ _. + +Section Opposite_Functor. + Context {C D : Category} (F : Functor C D). + + Program Definition Opposite_Functor : (Functor (Opposite C) (Opposite D)) := + {| + FO := FO F; + FA := fun _ _ h => FA F h; + |}. + +End Opposite_Functor. + +Section Functor_Compose. + Context {C C' C'' : Category} (F : Functor C C') (F' : Functor C' C''). + + Program Definition Functor_compose : Functor C C'' := + {| + FO := fun c => FO F' (FO F c); + FA := fun c d f => FA F' (FA F f) + |}. + +End Functor_Compose. + +Section Algebras. + Context {C : Category} (T : Functor C C). + Record Algebra : Type := + { + Alg_Carrier : C; + Constructors : Hom (FO T Alg_Carrier) Alg_Carrier + }. + + Record Algebra_Hom (alg alg' : Algebra) : Type := + { + Alg_map : Hom (Alg_Carrier alg) (Alg_Carrier alg'); + + Alg_map_com : compose (FA T Alg_map) (Constructors alg') + = compose (Constructors alg) Alg_map + }. + + Arguments Alg_map {_ _} _. + Arguments Alg_map_com {_ _} _. + Program Definition Algebra_Hom_compose + {alg alg' alg'' : Algebra} + (h : Algebra_Hom alg alg') + (h' : Algebra_Hom alg' alg'') + : Algebra_Hom alg alg'' + := + {| + Alg_map := compose (Alg_map h) (Alg_map h') + |}. + + Next Obligation. Proof. Admitted. + + Lemma Algebra_Hom_eq_simplify (alg alg' : Algebra) + (ah ah' : Algebra_Hom alg alg') + : (Alg_map ah) = (Alg_map ah') -> ah = ah'. + Proof. Admitted. + + Program Definition Algebra_Hom_id (alg : Algebra) : Algebra_Hom alg alg := + {| + Alg_map := id + |}. + + Next Obligation. Admitted. + + Definition Algebra_Cat : Category := + {| + Obj := Algebra; + Hom := Algebra_Hom; + compose := @Algebra_Hom_compose; + id := Algebra_Hom_id; + |}. + +End Algebras. + +Arguments Alg_Carrier {_ _} _. +Arguments Constructors {_ _} _. +Arguments Algebra_Hom {_ _} _ _. +Arguments Alg_map {_ _ _ _} _. +Arguments Alg_map_com {_ _ _ _} _. +Arguments Algebra_Hom_id {_ _} _. + +Section CoAlgebras. + Context {C : Category}. + + Definition CoAlgebra (T : Functor C C) := + @Algebra (Opposite C) (Opposite_Functor T). + + Definition CoAlgebra_Hom {T : Functor C C} := + @Algebra_Hom (Opposite C) (Opposite_Functor T). + + Definition CoAlgebra_Hom_id {T : Functor C C} := + @Algebra_Hom_id (Opposite C) (Opposite_Functor T). + + Definition CoAlgebra_Cat (T : Functor C C) := + @Algebra_Cat (Opposite C) (Opposite_Functor T). + +End CoAlgebras. + +Program Definition Type_Cat : Category := +{| + Obj := Type; + Hom := (fun A B => A -> B); + compose := fun A B C (g : A -> B) (h : B -> C) => fun (x : A) => h (g x); + id := fun A => fun x => x +|}. + +Local Obligation Tactic := idtac. + +Program Definition Prod_Cat (C C' : Category) : Category := +{| + Obj := C * C'; + Hom := + fun a b => + ((Hom (fst a) (fst b)) * (Hom (snd a) (snd b)))%type; + compose := + fun a b c f g => + ((compose (fst f) (fst g)), (compose (snd f)(snd g))); + id := fun c => (id, id) +|}. + +Class Terminal (C : Category) : Type := +{ + terminal : C; + t_morph : forall (d : Obj), Hom d terminal; + t_morph_unique : forall (d : Obj) (f g : (Hom d terminal)), f = g +}. + +Arguments terminal {_} _. +Arguments t_morph {_} _ _. +Arguments t_morph_unique {_} _ _ _ _. + +Coercion terminal : Terminal >-> Obj. + +Definition Initial (C : Category) := Terminal (Opposite C). +Existing Class Initial. + +Record Product {C : Category} (c d : C) : Type := +{ + product : C; + Pi_1 : Hom product c; + Pi_2 : Hom product d; + Prod_morph_ex : forall (p' : Obj) (r1 : Hom p' c) (r2 : Hom p' d), (Hom p' product); +}. + +Arguments Product _ _ _, {_} _ _. + +Arguments Pi_1 {_ _ _ _}, {_ _ _} _. +Arguments Pi_2 {_ _ _ _}, {_ _ _} _. +Arguments Prod_morph_ex {_ _ _} _ _ _ _. + +Coercion product : Product >-> Obj. + +Definition Has_Products (C : Category) : Type := forall a b, Product a b. + +Existing Class Has_Products. + +Program Definition Prod_Func (C : Category) {HP : Has_Products C} + : Functor (Prod_Cat C C) C := +{| + FO := fun x => HP (fst x) (snd x); + FA := fun a b f => Prod_morph_ex _ _ (compose Pi_1 (fst f)) (compose Pi_2 (snd f)) +|}. + +Arguments Prod_Func _ _, _ {_}. + +Definition Sum (C : Category) := @Product (Opposite C). + +Arguments Sum _ _ _, {_} _ _. + +Definition Has_Sums (C : Category) : Type := forall (a b : C), (Sum a b). + +Existing Class Has_Sums. + +Program Definition sum_Sum (A B : Type) : (@Sum Type_Cat A B) := +{| + product := (A + B)%type; + Prod_morph_ex := + fun (p' : Type) + (r1 : A -> p') + (r2 : B -> p') + (X : A + B) => + match X return p' with + | inl a => r1 a + | inr b => r2 b + end +|}. +Next Obligation. simpl; auto. Defined. +Next Obligation. simpl; auto. Defined. + +Program Instance Type_Cat_Has_Sums : Has_Sums Type_Cat := sum_Sum. + +Definition Sum_Func {C : Category} {HS : Has_Sums C} : + Functor (Prod_Cat C C) C := Opposite_Functor (Prod_Func (Opposite C) HS). + +Arguments Sum_Func _ _, _ {_}. + +Program Instance unit_Type_term : Terminal Type_Cat := +{ + terminal := unit; + t_morph := fun _ _=> tt +}. + +Next Obligation. Proof. Admitted. + +Program Definition term_id : Functor Type_Cat (Prod_Cat Type_Cat Type_Cat) := +{| + FO := fun a => (@terminal Type_Cat _, a); + FA := fun a b f => (@id _ (@terminal Type_Cat _), f) +|}. + +Definition S_nat_func : Functor Type_Cat Type_Cat := + Functor_compose term_id (Sum_Func Type_Cat _). + +Definition S_nat_alg_cat := Algebra_Cat S_nat_func. + +CoInductive CoNat : Set := + | CoO : CoNat + | CoS : CoNat -> CoNat +. + +Definition S_nat_coalg_cat := @CoAlgebra_Cat Type_Cat S_nat_func. + +Set Printing Universes. +Program Definition CoNat_alg_term : Initial S_nat_coalg_cat := +{| + terminal := _; + t_morph := _ +|}. + +Next Obligation. Admitted. +Next Obligation. Admitted. + +Axiom Admit : False. + +Next Obligation. +Proof. + intros d f g. + assert(H1 := (@Alg_map_com _ _ _ _ f)). clear. + assert (inl tt = inr tt) by (exfalso; apply Admit). + discriminate. + all: exfalso; apply Admit. + Show Universes. +Qed. diff --git a/test-suite/bugs/closed/5215_2.v b/test-suite/bugs/closed/5215_2.v new file mode 100644 index 000000000..399947f00 --- /dev/null +++ b/test-suite/bugs/closed/5215_2.v @@ -0,0 +1,8 @@ +Require Import Coq.Program.Tactics. +Set Universe Polymorphism. +Set Printing Universes. +Definition typ := Type. + +Program Definition foo : typ := _ -> _. +Next Obligation. Admitted. +Next Obligation. exact typ. Show Proof. Show Universes. Defined. diff --git a/test-suite/bugs/closed/5790.v b/test-suite/bugs/closed/5790.v new file mode 100644 index 000000000..6c93a3906 --- /dev/null +++ b/test-suite/bugs/closed/5790.v @@ -0,0 +1,7 @@ +Set Universe Polymorphism. +Section foo. +Context (v : Type). +Axiom a : True <-> False. + +Hint Resolve -> a. +End foo. diff --git a/test-suite/coq-makefile/timing/run.sh b/test-suite/coq-makefile/timing/run.sh index 7e0baaa8f..2428da731 100755 --- a/test-suite/coq-makefile/timing/run.sh +++ b/test-suite/coq-makefile/timing/run.sh @@ -41,6 +41,9 @@ for ext in "" .desired; do done done for file in time-of-build-before.log time-of-build-after.log time-of-build-both.log; do + echo "cat $file" + cat "$file" + echo diff -u $file.desired.processed $file.processed || exit $? done @@ -56,6 +59,13 @@ make all TIMING=after -j2 || exit $? find ../per-file-before/ -name "*.before-timing" -exec 'cp' '{}' './' ';' make all.timing.diff -j2 || exit $? +echo "cat A.v.before-timing" +cat A.v.before-timing +echo +echo "cat A.v.after-timing" +cat A.v.after-timing +echo +echo "cat A.v.timing.diff" cat A.v.timing.diff echo diff --git a/test-suite/output/ltac.out b/test-suite/output/ltac.out index 35c3057d8..c5d58ec1e 100644 --- a/test-suite/output/ltac.out +++ b/test-suite/output/ltac.out @@ -31,3 +31,10 @@ nat nat 0 0 +Ltac foo := + let x := intros ** in + let y := intros -> in + let v := constr:(nil) in + let w := () in + let z := 1 in + pose v diff --git a/test-suite/output/ltac.v b/test-suite/output/ltac.v index 76c37625a..6adbe95dd 100644 --- a/test-suite/output/ltac.v +++ b/test-suite/output/ltac.v @@ -57,3 +57,14 @@ match goal with |- ?x*?y => idtac x end. match goal with H: context [?x*?y] |- _ => idtac x end. match goal with |- context [?x*?y] => idtac x end. Abort. + +(* Check printing of let in Ltac and Tactic Notation *) + +Ltac foo := + let x := intros in + let y := intros -> in + let v := constr:(@ nil True) in + let w := () in + let z := 1 in + pose v. +Print Ltac foo. diff --git a/toplevel/coqinit.ml b/toplevel/coqinit.ml index c80899288..3a195c1df 100644 --- a/toplevel/coqinit.ml +++ b/toplevel/coqinit.ml @@ -65,7 +65,7 @@ let add_stdlib_path ~load_init ~unix_path ~coq_root ~with_ml = let add_userlib_path ~unix_path = Mltop.add_rec_path Mltop.AddRecML ~unix_path - ~coq_root:Nameops.default_root_prefix ~implicit:false + ~coq_root:Libnames.default_root_prefix ~implicit:false (* Options -I, -I-as, and -R of the command line *) let includes = ref [] @@ -80,7 +80,7 @@ let init_load_path ~load_init = let user_contrib = coqlib/"user-contrib" in let xdg_dirs = Envars.xdg_dirs ~warn:(fun x -> Feedback.msg_warning (str x)) in let coqpath = Envars.coqpath in - let coq_root = Names.DirPath.make [Nameops.coq_root] in + let coq_root = Names.DirPath.make [Libnames.coq_root] in (* NOTE: These directories are searched from last to first *) (* first, developer specific directory to open *) if Coq_config.local then @@ -105,7 +105,7 @@ let init_load_path ~load_init = List.iter (fun s -> add_userlib_path ~unix_path:s) coqpath; (* then current directory (not recursively!) *) Mltop.add_ml_dir "."; - Loadpath.add_load_path "." Nameops.default_root_prefix ~implicit:false; + Loadpath.add_load_path "." Libnames.default_root_prefix ~implicit:false; (* additional loadpath, given with options -Q and -R *) List.iter (fun (unix_path, coq_root, implicit) -> diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index f3d5d9b85..c61a1fd41 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -844,8 +844,10 @@ let start () = exit 1 | _ -> flush_all(); - if !output_context then - Feedback.msg_notice Flags.(with_option raw_print Prettyp.print_full_pure_context () ++ fnl ()); + if !output_context then begin + let sigma, env = Pfedit.get_current_context () in + Feedback.msg_notice (Flags.(with_option raw_print (Prettyp.print_full_pure_context env) sigma) ++ fnl ()) + end; Profile.print_profile (); exit 0 diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index cf63fbdc3..8fdaedbaf 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -100,7 +100,9 @@ let print_cmd_header ?loc com = Format.pp_print_flush !Topfmt.std_ft () let pr_open_cur_subgoals () = - try Printer.pr_open_subgoals () + try + let proof = Proof_global.give_me_the_proof () in + Printer.pr_open_subgoals ~proof with Proof_global.NoCurrentProof -> Pp.str "" (* Reenable when we get back to feedback printing *) diff --git a/vernac/auto_ind_decl.ml b/vernac/auto_ind_decl.ml index 9e63df51d..51dd5cd4f 100644 --- a/vernac/auto_ind_decl.ml +++ b/vernac/auto_ind_decl.ml @@ -377,6 +377,7 @@ let do_replace_lb mode lb_scheme_key aavoid narg p q = Proofview.Goal.enter begin fun gl -> let type_of_pq = Tacmach.New.pf_unsafe_type_of gl p in let sigma = Tacmach.New.project gl in + let env = Tacmach.New.pf_env gl in let u,v = destruct_ind sigma type_of_pq in let lb_type_of_p = try @@ -389,7 +390,7 @@ let do_replace_lb mode lb_scheme_key aavoid narg p q = (str "Leibniz->boolean:" ++ str "You have to declare the" ++ str "decidability over " ++ - Printer.pr_econstr type_of_pq ++ + Printer.pr_econstr_env env sigma type_of_pq ++ str " first.") in Tacticals.New.tclZEROMSG err_msg @@ -442,6 +443,7 @@ let do_replace_bl mode bl_scheme_key (ind,u as indu) aavoid narg lft rgt = Proofview.Goal.enter begin fun gl -> let tt1 = Tacmach.New.pf_unsafe_type_of gl t1 in let sigma = Tacmach.New.project gl in + let env = Tacmach.New.pf_env gl in if EConstr.eq_constr sigma t1 t2 then aux q1 q2 else ( let u,v = try destruct_ind sigma tt1 @@ -461,7 +463,7 @@ let do_replace_bl mode bl_scheme_key (ind,u as indu) aavoid narg lft rgt = (str "boolean->Leibniz:" ++ str "You have to declare the" ++ str "decidability over " ++ - Printer.pr_econstr tt1 ++ + Printer.pr_econstr_env env sigma tt1 ++ str " first.") in user_err err_msg diff --git a/vernac/command.ml b/vernac/command.ml index b027863e8..257c003b5 100644 --- a/vernac/command.ml +++ b/vernac/command.ml @@ -8,8 +8,8 @@ open Pp open CErrors +open Sorts open Util -open Term open Constr open Vars open Termops @@ -22,7 +22,6 @@ open Globnames open Nameops open Constrexpr open Constrexpr_ops -open Topconstr open Constrintern open Nametab open Impargs @@ -377,8 +376,8 @@ let rec check_anonymous_type ind = | _ -> false let make_conclusion_flexible evdref ty poly = - if poly && isArity ty then - let _, concl = destArity ty in + if poly && Term.isArity ty then + let _, concl = Term.destArity ty in match concl with | Type u -> (match Univ.universe_level u with diff --git a/vernac/explainErr.ml b/vernac/explainErr.ml index 2178a7caa..3a8e8fb43 100644 --- a/vernac/explainErr.ml +++ b/vernac/explainErr.ml @@ -76,7 +76,8 @@ let process_vernac_interp_error exn = match fst exn with | Tacred.ReductionTacticError e -> wrap_vernac_error exn (Himsg.explain_reduction_tactic_error e) | Logic.RefinerError e -> - wrap_vernac_error exn (Himsg.explain_refiner_error e) + let sigma, env = Pfedit.get_current_context () in + wrap_vernac_error exn (Himsg.explain_refiner_error env sigma e) | Nametab.GlobalizationError q -> wrap_vernac_error exn (str "The reference" ++ spc () ++ Libnames.pr_qualid q ++ diff --git a/vernac/himsg.ml b/vernac/himsg.ml index d15a811ba..e8c5aeedd 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -11,7 +11,7 @@ open Util open Names open Nameops open Namegen -open Term +open Constr open Termops open Indtypes open Environ @@ -92,9 +92,7 @@ let jv_nf_betaiotaevar sigma jl = (** Printers *) -let pr_lconstr c = quote (pr_lconstr c) let pr_lconstr_env e s c = quote (pr_lconstr_env e s c) -let pr_leconstr c = quote (pr_leconstr c) let pr_leconstr_env e s c = quote (pr_leconstr_env e s c) let pr_ljudge_env e s c = let v,t = pr_ljudge_env e s c in (quote v,quote t) @@ -407,7 +405,7 @@ let explain_not_product env sigma c = let pr = pr_lconstr_env env sigma c in str "The type of this term is a product" ++ spc () ++ str "while it is expected to be" ++ - (if Term.is_Type c then str " a sort" else (brk(1,1) ++ pr)) ++ str "." + (if Constr.is_Type c then str " a sort" else (brk(1,1) ++ pr)) ++ str "." (* TODO: use the names *) (* (co)fixpoints *) @@ -1037,52 +1035,52 @@ let explain_typeclass_error env = function (* Refiner errors *) -let explain_refiner_bad_type arg ty conclty = +let explain_refiner_bad_type env sigma arg ty conclty = str "Refiner was given an argument" ++ brk(1,1) ++ - pr_lconstr arg ++ spc () ++ - str "of type" ++ brk(1,1) ++ pr_lconstr ty ++ spc () ++ - str "instead of" ++ brk(1,1) ++ pr_lconstr conclty ++ str "." + pr_lconstr_env env sigma arg ++ spc () ++ + str "of type" ++ brk(1,1) ++ pr_lconstr_env env sigma ty ++ spc () ++ + str "instead of" ++ brk(1,1) ++ pr_lconstr_env env sigma conclty ++ str "." let explain_refiner_unresolved_bindings l = str "Unable to find an instance for the " ++ str (String.plural (List.length l) "variable") ++ spc () ++ prlist_with_sep pr_comma Name.print l ++ str"." -let explain_refiner_cannot_apply t harg = +let explain_refiner_cannot_apply env sigma t harg = str "In refiner, a term of type" ++ brk(1,1) ++ - pr_lconstr t ++ spc () ++ str "could not be applied to" ++ brk(1,1) ++ - pr_lconstr harg ++ str "." + pr_lconstr_env env sigma t ++ spc () ++ str "could not be applied to" ++ brk(1,1) ++ + pr_lconstr_env env sigma harg ++ str "." -let explain_refiner_not_well_typed c = - str "The term " ++ pr_lconstr c ++ str " is not well-typed." +let explain_refiner_not_well_typed env sigma c = + str "The term " ++ pr_lconstr_env env sigma c ++ str " is not well-typed." let explain_intro_needs_product () = str "Introduction tactics needs products." -let explain_does_not_occur_in c hyp = - str "The term" ++ spc () ++ pr_lconstr c ++ spc () ++ +let explain_does_not_occur_in env sigma c hyp = + str "The term" ++ spc () ++ pr_lconstr_env env sigma c ++ spc () ++ str "does not occur in" ++ spc () ++ Id.print hyp ++ str "." -let explain_non_linear_proof c = - str "Cannot refine with term" ++ brk(1,1) ++ pr_lconstr c ++ +let explain_non_linear_proof env sigma c = + str "Cannot refine with term" ++ brk(1,1) ++ pr_lconstr_env env sigma c ++ spc () ++ str "because a metavariable has several occurrences." -let explain_meta_in_type c = - str "In refiner, a meta appears in the type " ++ brk(1,1) ++ pr_leconstr c ++ +let explain_meta_in_type env sigma c = + str "In refiner, a meta appears in the type " ++ brk(1,1) ++ pr_leconstr_env env sigma c ++ str " of another meta" let explain_no_such_hyp id = str "No such hypothesis: " ++ Id.print id -let explain_refiner_error = function - | BadType (arg,ty,conclty) -> explain_refiner_bad_type arg ty conclty +let explain_refiner_error env sigma = function + | BadType (arg,ty,conclty) -> explain_refiner_bad_type env sigma arg ty conclty | UnresolvedBindings t -> explain_refiner_unresolved_bindings t - | CannotApply (t,harg) -> explain_refiner_cannot_apply t harg - | NotWellTyped c -> explain_refiner_not_well_typed c + | CannotApply (t,harg) -> explain_refiner_cannot_apply env sigma t harg + | NotWellTyped c -> explain_refiner_not_well_typed env sigma c | IntroNeedsProduct -> explain_intro_needs_product () - | DoesNotOccurIn (c,hyp) -> explain_does_not_occur_in c hyp - | NonLinearProof c -> explain_non_linear_proof c - | MetaInType c -> explain_meta_in_type c + | DoesNotOccurIn (c,hyp) -> explain_does_not_occur_in env sigma c hyp + | NonLinearProof c -> explain_non_linear_proof env sigma c + | MetaInType c -> explain_meta_in_type env sigma c | NoSuchHyp id -> explain_no_such_hyp id (* Inductive errors *) diff --git a/vernac/himsg.mli b/vernac/himsg.mli index 5b91f9e68..8945ebadb 100644 --- a/vernac/himsg.mli +++ b/vernac/himsg.mli @@ -27,7 +27,7 @@ val explain_typeclass_error : env -> typeclass_error -> Pp.t val explain_recursion_scheme_error : recursion_scheme_error -> Pp.t -val explain_refiner_error : refiner_error -> Pp.t +val explain_refiner_error : env -> Evd.evar_map -> refiner_error -> Pp.t val explain_pattern_matching_error : env -> Evd.evar_map -> pattern_matching_error -> Pp.t diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml index 7b8a38d5f..a025bfff8 100644 --- a/vernac/lemmas.ml +++ b/vernac/lemmas.ml @@ -253,7 +253,9 @@ let save_remaining_recthms (locality,p,kind) norm ctx binders body opaq i (id,(t | LetIn(na,t1,ty,t2) -> mkLetIn (na,t1,ty, body_i t2) | Lambda(na,ty,t) -> mkLambda(na,ty,body_i t) | App (t, args) -> mkApp (body_i t, args) - | _ -> anomaly Pp.(str "Not a proof by induction: " ++ Printer.pr_constr body ++ str ".") in + | _ -> + let sigma, env = Pfedit.get_current_context () in + anomaly Pp.(str "Not a proof by induction: " ++ Printer.pr_constr_env env sigma body ++ str ".") in let body_i = body_i body in match locality with | Discharge -> @@ -530,7 +532,5 @@ let save_proof ?proof = function Proof_global.(apply_terminator terminator (Proved (is_opaque,idopt,proof_obj))) (* Miscellaneous *) +let get_current_context () = Pfedit.get_current_context () -let get_current_context () = - Pfedit.get_current_context () - diff --git a/vernac/lemmas.mli b/vernac/lemmas.mli index 6972edd52..1b1304db5 100644 --- a/vernac/lemmas.mli +++ b/vernac/lemmas.mli @@ -66,3 +66,4 @@ val save_proof : ?proof:Proof_global.closed_proof -> Vernacexpr.proof_end -> uni and the current global env *) val get_current_context : unit -> Evd.evar_map * Environ.env +[@@ocaml.deprecated "please use [Pfedit.get_current_context]"] diff --git a/vernac/obligations.ml b/vernac/obligations.ml index ed4d8b888..a44de66e9 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -678,6 +678,7 @@ let init_prog_info ?(opaque = false) sign n udecl b t ctx deps fixkind obl_deps = d; obl_tac = tac }) obls, b in + let ctx = UState.make_flexible_nonalgebraic ctx in { prg_name = n ; prg_body = b; prg_type = reduce t; prg_ctx = ctx; prg_univdecl = udecl; prg_obligations = (obls', Array.length obls'); @@ -841,6 +842,9 @@ let obligation_terminator name num guard hook auto pf = Inductiveops.control_only_guard (Global.env ()) body; (** Declare the obligation ourselves and drop the hook *) let prg = get_info (ProgMap.find name !from_prg) in + (** Ensure universes are substituted properly in body and type *) + let body = EConstr.to_constr sigma (EConstr.of_constr body) in + let ty = Option.map (fun x -> EConstr.to_constr sigma (EConstr.of_constr x)) ty in let ctx = Evd.evar_universe_context sigma in let prg = { prg with prg_ctx = ctx } in let obls, rem = prg.prg_obligations in diff --git a/vernac/record.ml b/vernac/record.ml index 1bd47a556..f09b57048 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -8,11 +8,12 @@ open Pp open CErrors +open Term +open Sorts open Util open Names open Globnames open Nameops -open Term open Constr open Vars open Environ diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index a71794f5e..6191f3708 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -56,20 +56,19 @@ let scope_class_of_qualid qid = let show_proof () = (* spiwack: this would probably be cooler with a bit of polishing. *) let p = Proof_global.give_me_the_proof () in + let sigma, env = Pfedit.get_current_context () in let pprf = Proof.partial_proof p in - Feedback.msg_notice (Pp.prlist_with_sep Pp.fnl Printer.pr_econstr pprf) + Feedback.msg_notice (Pp.prlist_with_sep Pp.fnl (Printer.pr_econstr_env env sigma) pprf) let show_top_evars () = (* spiwack: new as of Feb. 2010: shows goal evars in addition to non-goal evars. *) let pfts = Proof_global.give_me_the_proof () in - let gls = Proof.V82.subgoals pfts in - let sigma = gls.Evd.sigma in + let gls,_,_,_,sigma = Proof.proof pfts in Feedback.msg_notice (pr_evars_int sigma 1 (Evd.undefined_map sigma)) let show_universes () = let pfts = Proof_global.give_me_the_proof () in - let gls = Proof.V82.subgoals pfts in - let sigma = gls.Evd.sigma in + let gls,_,_,_,sigma = Proof.proof pfts in let ctx = Evd.universe_context_set (Evd.nf_constraints sigma) in Feedback.msg_notice (Termops.pr_evar_universe_context (Evd.evar_universe_context sigma)); Feedback.msg_notice (str"Normalized constraints: " ++ Univ.pr_universe_context_set (Termops.pr_evd_level sigma) ctx) @@ -78,7 +77,7 @@ let show_universes () = let show_intro all = let open EConstr in let pf = Proof_global.give_me_the_proof() in - let {Evd.it=gls ; sigma=sigma; } = Proof.V82.subgoals pf in + let gls,_,_,_,sigma = Proof.proof pf in if not (List.is_empty gls) then begin let gl = {Evd.it=List.hd gls ; sigma = sigma; } in let l,_= decompose_prod_assum sigma (Termops.strip_outer_cast sigma (pf_concl gl)) in @@ -153,7 +152,7 @@ let show_match id = (* "Print" commands *) let print_path_entry p = - let dir = pr_dirpath (Loadpath.logical p) in + let dir = DirPath.print (Loadpath.logical p) in let path = str (Loadpath.physical p) in Pp.hov 2 (dir ++ spc () ++ path) @@ -176,9 +175,9 @@ let print_modules () = let loaded_opened = List.intersect DirPath.equal opened loaded and only_loaded = List.subtract DirPath.equal loaded opened in str"Loaded and imported library files: " ++ - pr_vertical_list pr_dirpath loaded_opened ++ fnl () ++ + pr_vertical_list DirPath.print loaded_opened ++ fnl () ++ str"Loaded and not imported library files: " ++ - pr_vertical_list pr_dirpath only_loaded + pr_vertical_list DirPath.print only_loaded let print_module r = @@ -257,7 +256,8 @@ let print_namespace ns = let print_constant k body = (* FIXME: universes *) let t = body.Declarations.const_type in - print_kn k ++ str":" ++ spc() ++ Printer.pr_type t + let sigma, env = Pfedit.get_current_context () in + print_kn k ++ str":" ++ spc() ++ Printer.pr_type_env env sigma t in let matches mp = match match_modulepath ns mp with | Some [] -> true @@ -361,29 +361,29 @@ let locate_file f = let msg_found_library = function | Library.LibLoaded, fulldir, file -> Feedback.msg_info (hov 0 - (pr_dirpath fulldir ++ strbrk " has been loaded from file " ++ + (DirPath.print fulldir ++ strbrk " has been loaded from file " ++ str file)) | Library.LibInPath, fulldir, file -> Feedback.msg_info (hov 0 - (pr_dirpath fulldir ++ strbrk " is bound to file " ++ str file)) + (DirPath.print fulldir ++ strbrk " is bound to file " ++ str file)) let err_unmapped_library ?loc ?from qid = let dir = fst (repr_qualid qid) in let prefix = match from with | None -> str "." | Some from -> - str " and prefix " ++ pr_dirpath from ++ str "." + str " and prefix " ++ DirPath.print from ++ str "." in user_err ?loc ~hdr:"locate_library" (strbrk "Cannot find a physical path bound to logical path matching suffix " ++ - pr_dirpath dir ++ prefix) + DirPath.print dir ++ prefix) let err_notfound_library ?loc ?from qid = let prefix = match from with | None -> str "." | Some from -> - str " with prefix " ++ pr_dirpath from ++ str "." + str " with prefix " ++ DirPath.print from ++ str "." in user_err ?loc ~hdr:"locate_library" (strbrk "Unable to locate library " ++ pr_qualid qid ++ prefix) @@ -486,8 +486,8 @@ let vernac_definition locality p (local,k) ((loc,id as lid),pl) def = let red_option = match red_option with | None -> None | Some r -> - let (evc,env)= get_current_context () in - Some (snd (Hook.get f_interp_redexp env evc r)) in + let sigma, env= Pfedit.get_current_context () in + Some (snd (Hook.get f_interp_redexp env sigma r)) in do_definition id (local,p,k) pl bl red_option c typ_opt hook) let vernac_start_proof locality p kind l = @@ -893,7 +893,7 @@ let expand filename = let vernac_add_loadpath implicit pdir ldiropt = let pdir = expand pdir in - let alias = Option.default Nameops.default_root_prefix ldiropt in + let alias = Option.default Libnames.default_root_prefix ldiropt in Mltop.add_rec_path Mltop.AddTopML ~unix_path:pdir ~coq_root:alias ~implicit let vernac_remove_loadpath path = @@ -1539,7 +1539,7 @@ let vernac_print_option key = let get_current_context_of_args = function | Some n -> Pfedit.get_goal_context n - | None -> get_current_context () + | None -> Pfedit.get_current_context () let query_command_selector ?loc = function | None -> None @@ -1601,7 +1601,7 @@ let vernac_global_check c = let get_nth_goal n = let pf = Proof_global.give_me_the_proof() in - let {Evd.it=gls ; sigma=sigma; } = Proof.V82.subgoals pf in + let gls,_,_,_,sigma = Proof.proof pf in let gl = {Evd.it=List.nth gls (n-1) ; sigma = sigma; } in gl @@ -1628,17 +1628,20 @@ let print_about_hyp_globs ?loc ref_or_by_not glopt = let natureofid = match decl with | LocalAssum _ -> "Hypothesis" | LocalDef (_,bdy,_) ->"Constant (let in)" in - v 0 (Id.print id ++ str":" ++ pr_econstr (NamedDecl.get_type decl) ++ fnl() ++ fnl() + let sigma, env = Pfedit.get_current_context () in + v 0 (Id.print id ++ str":" ++ pr_econstr_env env sigma (NamedDecl.get_type decl) ++ fnl() ++ fnl() ++ str natureofid ++ str " of the goal context.") with (* fallback to globals *) - | NoHyp | Not_found -> print_about ref_or_by_not + | NoHyp | Not_found -> + let sigma, env = Pfedit.get_current_context () in + print_about env sigma ref_or_by_not - -let vernac_print ?loc = let open Feedback in function + +let vernac_print ?loc env sigma = let open Feedback in function | PrintTables -> msg_notice (print_tables ()) - | PrintFullContext-> msg_notice (print_full_context_typ ()) - | PrintSectionContext qid -> msg_notice (print_sec_context_typ qid) - | PrintInspect n -> msg_notice (inspect n) + | PrintFullContext-> msg_notice (print_full_context_typ env sigma) + | PrintSectionContext qid -> msg_notice (print_sec_context_typ env sigma qid) + | PrintInspect n -> msg_notice (inspect env sigma n) | PrintGrammar ent -> msg_notice (Metasyntax.pr_grammar ent) | PrintLoadPath dir -> (* For compatibility ? *) msg_notice (print_loadpath dir) | PrintModules -> msg_notice (print_modules ()) @@ -1648,15 +1651,15 @@ let vernac_print ?loc = let open Feedback in function | PrintMLLoadPath -> msg_notice (Mltop.print_ml_path ()) | PrintMLModules -> msg_notice (Mltop.print_ml_modules ()) | PrintDebugGC -> msg_notice (Mltop.print_gc ()) - | PrintName qid -> dump_global qid; msg_notice (print_name qid) + | PrintName qid -> dump_global qid; msg_notice (print_name env sigma qid) | PrintGraph -> msg_notice (Prettyp.print_graph()) | PrintClasses -> msg_notice (Prettyp.print_classes()) | PrintTypeClasses -> msg_notice (Prettyp.print_typeclasses()) | PrintInstances c -> msg_notice (Prettyp.print_instances (smart_global c)) - | PrintCoercions -> msg_notice (Prettyp.print_coercions()) + | PrintCoercions -> msg_notice (Prettyp.print_coercions env sigma) | PrintCoercionPaths (cls,clt) -> msg_notice (Prettyp.print_path_between (cl_of_qualid cls) (cl_of_qualid clt)) - | PrintCanonicalConversions -> msg_notice (Prettyp.print_canonical_projections ()) + | PrintCanonicalConversions -> msg_notice (Prettyp.print_canonical_projections env sigma) | PrintUniverses (b, dst) -> let univ = Global.universes () in let univ = if b then UGraph.sort_universes univ else univ in @@ -1668,16 +1671,16 @@ let vernac_print ?loc = let open Feedback in function | None -> msg_notice (UGraph.pr_universes Universes.pr_with_global_universes univ ++ pr_remaining) | Some s -> dump_universes_gen univ s end - | PrintHint r -> msg_notice (Hints.pr_hint_ref (smart_global r)) + | PrintHint r -> msg_notice (Hints.pr_hint_ref env sigma (smart_global r)) | PrintHintGoal -> msg_notice (Hints.pr_applicable_hint ()) - | PrintHintDbName s -> msg_notice (Hints.pr_hint_db_by_name s) - | PrintHintDb -> msg_notice (Hints.pr_searchtable ()) + | PrintHintDbName s -> msg_notice (Hints.pr_hint_db_by_name env sigma s) + | PrintHintDb -> msg_notice (Hints.pr_searchtable env sigma) | PrintScopes -> - msg_notice (Notation.pr_scopes (Constrextern.without_symbols pr_lglob_constr)) + msg_notice (Notation.pr_scopes (Constrextern.without_symbols (pr_lglob_constr_env env))) | PrintScope s -> - msg_notice (Notation.pr_scope (Constrextern.without_symbols pr_lglob_constr) s) + msg_notice (Notation.pr_scope (Constrextern.without_symbols (pr_lglob_constr_env env)) s) | PrintVisibility s -> - msg_notice (Notation.pr_visibility (Constrextern.without_symbols pr_lglob_constr) s) + msg_notice (Notation.pr_visibility (Constrextern.without_symbols (pr_lglob_constr_env env)) s) | PrintAbout (ref_or_by_not,glnumopt) -> msg_notice (print_about_hyp_globs ?loc ref_or_by_not glnumopt) | PrintImplicit qid -> @@ -1780,9 +1783,10 @@ let vernac_locate = let open Feedback in function | LocateTerm (AN qid) -> msg_notice (print_located_term qid) | LocateAny (ByNotation (_, (ntn, sc))) (** TODO : handle Ltac notations *) | LocateTerm (ByNotation (_, (ntn, sc))) -> - msg_notice - (Notation.locate_notation - (Constrextern.without_symbols pr_lglob_constr) ntn sc) + let _, env = Pfedit.get_current_context () in + msg_notice + (Notation.locate_notation + (Constrextern.without_symbols (pr_lglob_constr_env env)) ntn sc) | LocateLibrary qid -> print_located_library qid | LocateModule qid -> msg_notice (print_located_module qid) | LocateOther (s, qid) -> msg_notice (print_located_other s qid) @@ -1849,10 +1853,11 @@ let vernac_bullet (bullet : Proof_bullet.t) = let vernac_show = let open Feedback in function | ShowScript -> assert false (* Only the stm knows the script *) | ShowGoal goalref -> + let proof = Proof_global.give_me_the_proof () in let info = match goalref with - | OpenSubgoals -> pr_open_subgoals () - | NthGoal n -> pr_nth_open_subgoal n - | GoalId id -> pr_goal_by_id id + | OpenSubgoals -> pr_open_subgoals ~proof + | NthGoal n -> pr_nth_open_subgoal ~proof n + | GoalId id -> pr_goal_by_id ~proof id in msg_notice info | ShowProof -> show_proof () @@ -2043,7 +2048,9 @@ let interp ?proof ?loc locality poly st c = | VernacCheckMayEval (r,g,c) -> vernac_check_may_eval ?loc r g c | VernacDeclareReduction (s,r) -> vernac_declare_reduction locality s r | VernacGlobalCheck c -> vernac_global_check c - | VernacPrint p -> vernac_print ?loc p + | VernacPrint p -> + let sigma, env = Pfedit.get_current_context () in + vernac_print ?loc env sigma p | VernacSearch (s,g,r) -> vernac_search ?loc s g r | VernacLocate l -> vernac_locate l | VernacRegister (id, r) -> vernac_register id r |