diff options
252 files changed, 5536 insertions, 4605 deletions
diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 8b43d975ac..b47494d3ae 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -40,6 +40,11 @@ before_script: - if [ ! "(" -d .opamcache ")" ]; then mv ~/.opam .opamcache; else mv ~/.opam ~/.opam-old; fi - ln -s $(readlink -f .opamcache) ~/.opam + # the default repo in this docker image is a local directory + # at the time of 4aaeb8abf it lagged behind the official + # repository such that camlp5 7.01 was not available + - opam repository set-url default https://opam.ocaml.org + - opam update - opam switch ${COMPILER} - eval $(opam config env) - opam config list diff --git a/.travis.yml b/.travis.yml index 3cd7fdf5e3..9c7ad553f5 100644 --- a/.travis.yml +++ b/.travis.yml @@ -37,34 +37,33 @@ env: - TEST_TARGET="test-suite" COMPILER="4.02.3+32bit" - TEST_TARGET="validate" TW="travis_wait" - TEST_TARGET="validate" COMPILER="4.02.3+32bit" TW="travis_wait" - - TEST_TARGET="ci-bignums" - - TEST_TARGET="ci-color" - - TEST_TARGET="ci-compcert" + - TEST_TARGET="ci-bignums TIMED=1" + - TEST_TARGET="ci-color TIMED=1" + - TEST_TARGET="ci-compcert TIMED=1" - TEST_TARGET="ci-coq-dpdgraph" EXTRA_OPAM="ocamlgraph" - - TEST_TARGET="ci-coquelicot" - - TEST_TARGET="ci-geocoq" - - TEST_TARGET="ci-fiat-crypto" - - TEST_TARGET="ci-fiat-parsers" - - TEST_TARGET="ci-flocq" - - TEST_TARGET="ci-formal-topology" - - TEST_TARGET="ci-hott" - - TEST_TARGET="ci-iris-coq" - - TEST_TARGET="ci-math-classes" - - TEST_TARGET="ci-math-comp" - - TEST_TARGET="ci-sf" - - TEST_TARGET="ci-unimath" - - TEST_TARGET="ci-vst" + - TEST_TARGET="ci-coquelicot TIMED=1" + - TEST_TARGET="ci-geocoq TIMED=1" + - TEST_TARGET="ci-fiat-crypto TIMED=1" + - TEST_TARGET="ci-fiat-parsers TIMED=1" + - TEST_TARGET="ci-flocq TIMED=1" + - TEST_TARGET="ci-formal-topology TIMED=1" + - TEST_TARGET="ci-hott TIMED=1" + - TEST_TARGET="ci-iris-coq TIMED=1" + - TEST_TARGET="ci-math-classes TIMED=1" + - TEST_TARGET="ci-math-comp TIMED=1" + - TEST_TARGET="ci-sf TIMED=1" + - TEST_TARGET="ci-unimath TIMED=1" + - TEST_TARGET="ci-vst TIMED=1" # Not ready yet for 8.7 - # - TEST_TARGET="ci-cpdt" - # - TEST_TARGET="ci-metacoq" - # - TEST_TARGET="ci-tlc" + # - TEST_TARGET="ci-cpdt TIMED=1" + # - TEST_TARGET="ci-metacoq TIMED=1" + # - TEST_TARGET="ci-tlc TIMED=1" matrix: allow_failures: - env: TEST_TARGET="ci-coq-dpdgraph" EXTRA_OPAM="ocamlgraph" - - env: TEST_TARGET="ci-geocoq" - - env: TEST_TARGET="ci-fiat-parsers" + - env: TEST_TARGET="ci-geocoq TIMED=1" include: # Full Coq test-suite with two compilers diff --git a/API/API.ml b/API/API.ml index 32c664d7b1..c952e123d4 100644 --- a/API/API.ml +++ b/API/API.ml @@ -6,199 +6,280 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -module Ppvernac = Ppvernac -module Command = Command -module States = States -module Kindops = Kindops +(* Warning, this file respects the dependency order established in Coq. + + To see such order issue the comand: + +``` +bash -c 'for i in kernel intf library engine pretyping interp proofs parsing printing tactics vernac stm toplevel; do echo -e "\n## $i files" && cat ${i}/${i}.mllib; done && echo -e "\n## highparsing files" && cat parsing/highparsing.mllib' > API/link +``` + *) + +(******************************************************************************) +(* config *) +(******************************************************************************) module Coq_config = Coq_config + +(******************************************************************************) +(* Kernel *) +(******************************************************************************) +(* "mli" files *) +module Declarations = Declarations +module Entries = Entries + +module Names = Names +(* module Uint31 *) +module Univ = Univ +module UGraph = UGraph module Esubst = Esubst +module Sorts = Sorts module Evar = Evar -module Constrexpr = Constrexpr -module Libobject = Libobject -module Evd = Evd -module Libnames = Libnames -module Nameops = Nameops -module Topfmt = Topfmt -module Locus = Locus -module Locusops = Locusops -module Lemmas = Lemmas -module Clenv = Clenv -module Elimschemes = Elimschemes -module Classes = Classes -module Class_tactics = Class_tactics -module Eauto = Eauto -module Keys = Keys -module Vernac_classifier = Vernac_classifier -module Autorewrite = Autorewrite -module Redops = Redops -module Elim = Elim -module Geninterp = Geninterp -module Obligations = Obligations -module Retroknowledge = Retroknowledge -module Evar_refiner = Evar_refiner -module Hipattern = Hipattern -module Auto = Auto -module Hints = Hints -module Contradiction = Contradiction -module Tacticals = Tacticals -module Tactics = Tactics -module Inv = Inv -module Leminv = Leminv -module Equality = Equality -module Redexpr = Redexpr -module Pfedit = Pfedit -module Stm = Stm -module Stateid = Stateid -module Declaremods = Declaremods -module Miscops = Miscops -module Miscprint = Miscprint -module Genprint = Genprint -module Ppconstr = Ppconstr -module Pputils = Pputils -module Extend = Extend -module Logic = Logic -module Himsg = Himsg -module Tacred = Tacred -module Names = Names -module Indrec = Indrec -module Glob_ops = Glob_ops -module Constrexpr_ops = Constrexpr_ops -module Eqdecide = Eqdecide -module Genredexpr = Genredexpr -module Detyping = Detyping -module Tactypes = Tactypes -module ExplainErr = ExplainErr -module Printer = Printer -module Constrextern = Constrextern -module Locality = Locality -module Impargs = Impargs -module Termops = Termops -module Refiner = Refiner -module Ppextend = Ppextend -module Nametab = Nametab -module Vernacentries = Vernacentries -module Mltop = Mltop -module Goal = Goal -module Proof_bullet = Proof_bullet -module Proof_global = Proof_global -module Proof = Proof -module Smartlocate = Smartlocate -module Dumpglob = Dumpglob -module Constrintern = Constrintern -module Topconstr = Topconstr -module Notation_ops = Notation_ops -module Patternops = Patternops -module Mod_typing = Mod_typing -module Modops = Modops -module Opaqueproof = Opaqueproof -module Ind_tables = Ind_tables -module Typeops = Typeops -module Inductive = Inductive +module Constr = Constr +module Context = Context module Vars = Vars -module Reduction = Reduction +module Term = Term module Mod_subst = Mod_subst -module Sorts = Sorts -module Univ = Univ -module Constr = Constr +module Cbytecodes = Cbytecodes +(* module Copcodes *) +module Cemitcodes = Cemitcodes +(* module Nativevalues *) +(* module Primitives *) +module Opaqueproof = Opaqueproof +module Declareops = Declareops +module Retroknowledge = Retroknowledge +module Conv_oracle = Conv_oracle +(* module Pre_env *) +(* module Cbytegen *) +(* module Nativelambda *) +(* module Nativecode *) +(* module Nativelib *) +module Environ = Environ module CClosure = CClosure +module Reduction = Reduction +(* module Nativeconv *) module Type_errors = Type_errors +module Modops = Modops +module Inductive = Inductive +module Typeops = Typeops +(* module Indtypes *) +(* module Cooking *) +(* module Term_typing *) +(* module Subtyping *) +module Mod_typing = Mod_typing +(* module Nativelibrary *) module Safe_typing = Safe_typing -module UGraph = UGraph -module Namegen = Namegen -module Ftactic = Ftactic -module UState = UState -module Proofview_monad = Proofview_monad -module Classops = Classops +(* module Vm *) +(* module Csymtable *) +(* module Vconv *) + +(******************************************************************************) +(* Intf *) +(******************************************************************************) +module Constrexpr = Constrexpr +module Locus = Locus +module Glob_term = Glob_term +module Extend = Extend +module Misctypes = Misctypes +module Decl_kinds = Decl_kinds +module Vernacexpr = Vernacexpr +module Notation_term = Notation_term +module Evar_kinds = Evar_kinds +module Genredexpr = Genredexpr + +(******************************************************************************) +(* Library *) +(******************************************************************************) +module Univops = Univops +module Nameops = Nameops +module Libnames = Libnames +module Globnames = Globnames +module Libobject = Libobject +module Summary = Summary +module Nametab = Nametab module Global = Global -module Goptions = Goptions module Lib = Lib +module Declaremods = Declaremods +(* module Loadpath *) module Library = Library -module Summary = Summary +module States = States +module Kindops = Kindops +(* module Dischargedhypsmap *) +module Goptions = Goptions +(* module Decls *) +(* module Heads *) +module Keys = Keys +module Coqlib = Coqlib + +(******************************************************************************) +(* Engine *) +(******************************************************************************) +(* module Logic_monad *) module Universes = Universes -module Declare = Declare -module Refine = Refine -module Find_subterm = Find_subterm -module Evar_kinds = Evar_kinds -module Decl_kinds = Decl_kinds -module Misctypes = Misctypes +module UState = UState +module Evd = Evd +module EConstr = EConstr +module Tactypes = Tactypes module Pattern = Pattern -module Vernacexpr = Vernacexpr -module Search = Search -module Notation_term = Notation_term +module Namegen = Namegen +module Termops = Termops +module Proofview_monad = Proofview_monad +module Evarutil = Evarutil +module Proofview = Proofview +module Ftactic = Ftactic +module Geninterp = Geninterp + +(******************************************************************************) +(* Pretyping *) +(******************************************************************************) +module Locusops = Locusops +module Pretype_errors = Pretype_errors module Reductionops = Reductionops module Inductiveops = Inductiveops -module Recordops = Recordops +(* module Vnorm *) +(* module Arguments_renaming *) +module Impargs = Impargs +(* module Nativenorm *) module Retyping = Retyping -module Typing = Typing +(* module Cbv *) +module Find_subterm = Find_subterm +(* module Evardefine *) module Evarsolve = Evarsolve +module Recordops = Recordops +module Evarconv = Evarconv +module Typing = Typing +module Miscops = Miscops +module Glob_ops = Glob_ops +module Redops = Redops +module Patternops = Patternops module Constr_matching = Constr_matching +module Tacred = Tacred +module Typeclasses = Typeclasses +module Classops = Classops +(* module Program *) +(* module Coercion *) +module Detyping = Detyping +module Indrec = Indrec +(* module Cases *) module Pretyping = Pretyping -module Evarconv = Evarconv module Unification = Unification -module Typeclasses = Typeclasses -module Pretype_errors = Pretype_errors -module Notation = Notation -module Declarations = Declarations -module Univops = Univops -module Declareops = Declareops -module Globnames = Globnames -module Environ = Environ -module Term = Term -module Coqlib = Coqlib -module Glob_term = Glob_term -module Context = Context +(******************************************************************************) +(* interp *) +(******************************************************************************) module Stdarg = Stdarg +module Genintern = Genintern +module Constrexpr_ops = Constrexpr_ops +module Notation_ops = Notation_ops +module Ppextend = Ppextend +module Notation = Notation +module Dumpglob = Dumpglob +(* module Syntax_def *) +module Smartlocate = Smartlocate +module Topconstr = Topconstr +(* module Reserve *) +(* module Implicit_quantifiers *) +module Constrintern = Constrintern +(* module Modintern *) +module Constrextern = Constrextern +(* module Discharge *) +module Declare = Declare + +(******************************************************************************) +(* Proofs *) +(******************************************************************************) +module Miscprint = Miscprint +module Goal = Goal +module Evar_refiner = Evar_refiner +(* module Proof_using *) +module Proof_type = Proof_type +module Logic = Logic +module Refine = Refine +module Proof = Proof +module Proof_bullet = Proof_bullet +module Proof_global = Proof_global +module Redexpr = Redexpr +module Refiner = Refiner module Tacmach = Tacmach -module Proofview = Proofview -module Evarutil = Evarutil -module EConstr = EConstr +module Pfedit = Pfedit +module Clenv = Clenv +(* module Clenvtac *) +(* "mli" file *) + +(******************************************************************************) +(* Printing *) +(******************************************************************************) +module Genprint = Genprint +module Pputils = Pputils +module Ppconstr = Ppconstr +module Printer = Printer +(* module Printmod *) +(* module Prettyp *) +module Ppvernac = Ppvernac + +(******************************************************************************) +(* Parsing *) +(******************************************************************************) +module Tok = Tok +module CLexer = CLexer +module Pcoq = Pcoq +module Egramml = Egramml +(* Egramcoq *) + +(******************************************************************************) +(* Tactics *) +(******************************************************************************) +(* module Dnet *) +(* module Dn *) +(* module Btermdn *) +module Tacticals = Tacticals +module Hipattern = Hipattern +module Ind_tables = Ind_tables +(* module Eqschemes *) +module Elimschemes = Elimschemes +module Tactics = Tactics +module Elim = Elim +module Equality = Equality +module Contradiction = Contradiction +module Inv = Inv +module Leminv = Leminv +module Hints = Hints +module Auto = Auto +module Eauto = Eauto +module Class_tactics = Class_tactics +(* module Term_dnet *) +module Eqdecide = Eqdecide +module Autorewrite = Autorewrite + +(******************************************************************************) +(* Vernac *) +(******************************************************************************) +(* module Vernacprop *) +module Lemmas = Lemmas +module Himsg = Himsg +module ExplainErr = ExplainErr +(* module Class *) +module Locality = Locality +module Metasyntax = Metasyntax +(* module Auto_ind_decl *) +module Search = Search +(* module Indschemes *) +module Obligations = Obligations +module Command = Command +module Classes = Classes +(* module Record *) +(* module Assumptions *) +module Vernacinterp = Vernacinterp +module Mltop = Mltop +module Topfmt = Topfmt +module Vernacentries = Vernacentries + +(******************************************************************************) +(* Stm *) +(******************************************************************************) +module Vernac_classifier = Vernac_classifier +module Stm = Stm -module Prelude = - struct - type global_reference = Globnames.global_reference - type metavariable = int - type meta_value_map = (metavariable * Constr.constr) list - type named_context_val = Environ.named_context_val - type conv_pb = Reduction.conv_pb = - | CONV - | CUMUL - type constr = Constr.constr - type types = Constr.types - type evar = Constr.existential_key - type 'constr pexistential = 'constr Constr.pexistential - type env = Environ.env - type evar_map = Evd.evar_map - type rigid = Evd.rigid = - | UnivRigid - | UnivFlexible of bool - type reference = Libnames.reference = - | Qualid of Libnames.qualid Loc.located - | Ident of Names.Id.t Loc.located - end - -(* NOTE: It does not make sense to replace the following "module expression" - simply with "module Proof_type = Proof_type" because - there is only "kernel/entries.mli"; - there is no "kernel/entries.ml" file *) -module Entries = - struct - type mutual_inductive_entry = Entries.mutual_inductive_entry - type inline = int option - type 'a proof_output = Constr.constr Univ.in_universe_context_set * 'a - type 'a const_entry_body = 'a proof_output Future.computation - type 'a definition_entry = 'a Entries.definition_entry = - { const_entry_body : 'a const_entry_body; - const_entry_secctx : Context.Named.t option; - const_entry_feedback : Stateid.t option; - const_entry_type : Term.types option; - const_entry_polymorphic : bool; - const_entry_universes : Univ.universe_context; - const_entry_opaque : bool; - const_entry_inline_code : bool } - type parameter_entry = Entries.parameter_entry - type projection_entry = Entries.projection_entry - type 'a constant_entry = 'a Entries.constant_entry = - | DefinitionEntry of 'a definition_entry - | ParameterEntry of parameter_entry - | ProjectionEntry of projection_entry - end +(******************************************************************************) +(* Highparsing *) +(******************************************************************************) +module G_vernac = G_vernac +module G_proofs = G_proofs diff --git a/API/API.mli b/API/API.mli index b1a746e028..a0e77edd12 100644 --- a/API/API.mli +++ b/API/API.mli @@ -6,181 +6,78 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -module Prelude : -sig - (* None of the items in this modules are meant to be used by plugin-writers. - This module is here only for "technical reasons" - (it will disappear when we take advantage of mutually-recursive modules) *) - - (* API.Term.constr *) - type constr = Constr.t - - (* API.Term.types *) - type types = Constr.t - - (* API.Evar.t *) - type evar = Evar.t - - (* 'constr API.Term.pexistential *) - type 'constr pexistential = evar * 'constr array - - (* API.Environ.env *) - type env = Environ.env +(* Warning, this file should respect the dependency order established + in Coq. To see such order issue the comand: - (* API.Evar.Map.t *) - type evar_map = Evd.evar_map + ``` + bash -c 'for i in kernel intf library engine pretyping interp proofs parsing printing tactics vernac stm toplevel; do echo -e "\n## $i files" && cat ${i}/${i}.mllib; done && echo -e "\n## highparsing files" && cat parsing/highparsing.mllib' > API/link + ``` - (* API.Globnames.global_reference *) - type global_reference = Globnames.global_reference + Note however that files in intf/ are located manually now as their + conceptual linking order in the Coq codebase is incorrect (but it + works due to these files being implementation-free. - type rigid = Evd.rigid = - | UnivRigid - | UnivFlexible of bool + See below in the file for their concrete position. +*) - type conv_pb = Reduction.conv_pb = - | CONV - | CUMUL - - type named_context_val = Environ.named_context_val - - type metavariable = int - - (* Termops.meta_value_map *) - type meta_value_map = (metavariable * constr) list - - (* API.Libnames.reference *) - type reference = Libnames.reference = - | Qualid of Libnames.qualid Loc.located - | Ident of Names.Id.t Loc.located +(************************************************************************) +(* Modules from config/ *) +(************************************************************************) +module Coq_config : +sig + val exec_extension : string end -module Univ : +(************************************************************************) +(* Modules from kernel/ *) +(************************************************************************) +module Names : sig - module Level : - sig - type t = Univ.Level.t - val set : t - val pr : t -> Pp.std_ppcmds - end - - module Instance : - sig - type t = Univ.Instance.t - val empty : t - val of_array : Level.t array -> t - val to_array : t -> Level.t array - val pr : (Level.t -> Pp.std_ppcmds) -> t -> Pp.std_ppcmds - end - type 'a puniverses = 'a * Instance.t - val out_punivs : 'a puniverses -> 'a - module Constraint : module type of struct include Univ.Constraint end + open Util - type 'a constrained = 'a * Constraint.t - - module UContext : + module Id : sig - type t = Univ.UContext.t - val empty : t - end - - module AUContext : - sig - type t = Univ.AUContext.t - end - - type universe_context = UContext.t - [@@ocaml.deprecated "alias of API.Univ.UContext.t"] - - type abstract_universe_context = Univ.AUContext.t - type cumulativity_info = Univ.CumulativityInfo.t - type abstract_cumulativity_info = Univ.ACumulativityInfo.t + type t + val equal : t -> t -> bool + val compare : t -> t -> int + val hash : t -> int + val is_valid : string -> bool + val of_bytes : bytes -> t + val of_string : string -> t + val of_string_soft : string -> t + val to_string : t -> string + val print : t -> Pp.t - module LSet : module type of struct include Univ.LSet end - module ContextSet : - sig - type t = Univ.ContextSet.t - val empty : t - val of_context : UContext.t -> t - val to_context : t -> UContext.t + module Set : Set.S with type elt = t + module Map : Map.ExtS with type key = t and module Set := Set + module Pred : Predicate.S with type elt = t + module List : List.MonoS with type elt = t + val hcons : t -> t end - type 'a in_universe_context_set = 'a * ContextSet.t - type 'a in_universe_context = 'a * UContext.t - type constraint_type = Univ.constraint_type - - module Universe : + module Name : sig - type t = Univ.Universe.t - val pr : t -> Pp.std_ppcmds - end - - type universe_context_set = ContextSet.t - [@@ocaml.deprecated "alias of API.Names.ContextSet.t"] - - type universe_set = LSet.t - [@@ocaml.deprecated "alias of API.Names.LSet.t"] - - type 'a constraint_function = 'a -> 'a -> Constraint.t -> Constraint.t - type universe_subst = Univ.universe_subst - type universe_level_subst = Univ.universe_level_subst - - val enforce_leq : Universe.t constraint_function - val pr_uni : Universe.t -> Pp.std_ppcmds - val pr_universe_context : (Level.t -> Pp.std_ppcmds) -> UContext.t -> Pp.std_ppcmds - val pr_universe_context_set : (Level.t -> Pp.std_ppcmds) -> ContextSet.t -> Pp.std_ppcmds - val pr_universe_subst : universe_subst -> Pp.std_ppcmds - val pr_universe_level_subst : universe_level_subst -> Pp.std_ppcmds - val pr_constraints : (Level.t -> Pp.std_ppcmds) -> Constraint.t -> Pp.std_ppcmds -end - -module UState : -sig - type t = UState.t - val context : t -> Univ.UContext.t - val context_set : t -> Univ.ContextSet.t - val of_context_set : Univ.ContextSet.t -> t -end - -module Sorts : -sig - type contents = Sorts.contents = Pos | Null - type t = Sorts.t = - | Prop of contents - | Type of Univ.Universe.t - val is_prop : t -> bool - val hash : t -> int - - type family = Sorts.family = InProp | InSet | InType - val family : t -> family -end - -module Names : -sig - module Id : module type of struct include Names.Id end - - module MBId : sig - type t = Names.MBId.t + type t = Anonymous (** anonymous identifier *) + | Name of Id.t (** non-anonymous identifier *) + val mk_name : Id.t -> t + val is_anonymous : t -> bool + val is_name : t -> bool + val compare : t -> t -> int val equal : t -> t -> bool - val to_id : t -> Names.Id.t - val repr : t -> int * Names.Id.t * Names.DirPath.t - val debug_to_string : t -> string + val hash : t -> int + val hcons : t -> t + val print : t -> Pp.t end - type evaluable_global_reference = Names.evaluable_global_reference = - | EvalVarRef of Id.t - | EvalConstRef of Names.Constant.t - - module Name : module type of struct include Names.Name end - type name = Name.t = - | Anonymous + | Anonymous | Name of Id.t [@@ocaml.deprecated "alias of API.Name.t"] module DirPath : sig - type t = Names.DirPath.t + type t val empty : t val make : Id.t list -> t val repr : t -> Id.t list @@ -188,23 +85,31 @@ sig val to_string : t -> string end + module MBId : sig + type t + val equal : t -> t -> bool + val to_id : t -> Id.t + val repr : t -> int * Id.t * DirPath.t + val debug_to_string : t -> string + end + module Label : sig - type t = Names.Label.t + type t val make : string -> t val equal : t -> t -> bool val compare : t -> t -> int - val of_id : Names.Id.t -> t - val to_id : t -> Names.Id.t + val of_id : Id.t -> t + val to_id : t -> Id.t val to_string : t -> string end module ModPath : sig - type t = Names.ModPath.t = - | MPfile of Names.DirPath.t - | MPbound of MBId.t - | MPdot of t * Label.t + type t = + | MPfile of DirPath.t + | MPbound of MBId.t + | MPdot of t * Label.t val compare : t -> t -> int val equal : t -> t -> bool val hash : t -> int @@ -215,7 +120,7 @@ sig module KerName : sig - type t = Names.KerName.t + type t val make : ModPath.t -> DirPath.t -> Label.t -> t val make2 : ModPath.t -> Label.t -> t val modpath : t -> ModPath.t @@ -223,7 +128,7 @@ sig val compare : t -> t -> int val label : t -> Label.t val repr : t -> ModPath.t * DirPath.t * Label.t - val print : t -> Pp.std_ppcmds + val print : t -> Pp.t val to_string : t -> string end @@ -232,40 +137,46 @@ sig module Constant : sig - type t = Names.Constant.t + type t val equal : t -> t -> bool - val make1 : Names.KerName.t -> t - val make2 : Names.ModPath.t -> Label.t -> t - val make3 : Names.ModPath.t -> Names.DirPath.t -> Label.t -> t - val repr3 : t -> Names.ModPath.t * Names.DirPath.t * Label.t - val canonical : t -> Names.KerName.t - val user : t -> Names.KerName.t + val make1 : KerName.t -> t + val make2 : ModPath.t -> Label.t -> t + val make3 : ModPath.t -> DirPath.t -> Label.t -> t + val repr3 : t -> ModPath.t * DirPath.t * Label.t + val canonical : t -> KerName.t + val user : t -> KerName.t val label : t -> Label.t end module MutInd : sig - type t = Names.MutInd.t - val make1 : Names.KerName.t -> t - val make2 : Names.ModPath.t -> Label.t -> t + type t + val make1 : KerName.t -> t + val make2 : ModPath.t -> Label.t -> t val equal : t -> t -> bool - val repr3 : t -> Names.ModPath.t * Names.DirPath.t * Label.t - val canonical : t -> Names.KerName.t - val modpath : t -> Names.ModPath.t + val repr3 : t -> ModPath.t * DirPath.t * Label.t + val canonical : t -> KerName.t + val modpath : t -> ModPath.t val label : t -> Label.t - val user : t -> Names.KerName.t - val print : t -> Pp.std_ppcmds + val user : t -> KerName.t + val print : t -> Pp.t end module Projection : sig - type t = Names.Projection.t + type t val make : Constant.t -> bool -> t val map : (Constant.t -> Constant.t) -> t -> t val constant : t -> Constant.t val equal : t -> t -> bool + val unfolded : t -> bool + val unfold : t -> t end + type evaluable_global_reference = + | EvalVarRef of Id.t + | EvalConstRef of Constant.t + type inductive = MutInd.t * int val eq_ind : inductive -> inductive -> bool @@ -273,31 +184,37 @@ sig val eq_constructor : constructor -> constructor -> bool val constructor_hash : constructor -> int - module MPset : module type of struct include Names.MPset end - module MPmap : module type of struct include Names.MPmap end - module KNset : module type of struct include Names.KNset end - module KNmap : module type of struct include Names.KNmap end - module Cset : module type of struct include Names.Cset end - module Cset_env : module type of struct include Names.Cset_env end - module Cmap : module type of struct include Names.Cmap end - module Cmap_env : module type of struct include Names.Cmap_env end - module Cpred : module type of struct include Names.Cpred end - module Mindset : module type of struct include Names.Mindset end - module Mindmap : module type of struct include Names.Mindmap end - module Mindmap_env : module type of struct include Names.Mindmap_env end - module Indmap : module type of struct include Names.Indmap end - with type key = inductive - module Indmap_env : module type of struct include Names.Indmap_env end - module Constrmap : module type of struct include Names.Constrmap end - module Constrmap_env : module type of struct include Names.Constrmap_env end + module MPset : Set.S with type elt = ModPath.t + module MPmap : Map.ExtS with type key = ModPath.t and module Set := MPset + + module KNset : CSig.SetS with type elt = KerName.t + module KNpred : Predicate.S with type elt = KerName.t + module KNmap : Map.ExtS with type key = KerName.t and module Set := KNset + + module Cpred : Predicate.S with type elt = Constant.t + module Cset : CSig.SetS with type elt = Constant.t + module Cset_env : CSig.SetS with type elt = Constant.t + + module Cmap : Map.ExtS with type key = Constant.t and module Set := Cset + module Cmap_env : Map.ExtS with type key = Constant.t and module Set := Cset_env + + module Mindset : CSig.SetS with type elt = MutInd.t + module Mindmap : Map.ExtS with type key = MutInd.t and module Set := Mindset + module Mindmap_env : CSig.MapS with type key = MutInd.t + + module Indmap : CSig.MapS with type key = inductive + module Constrmap : CSig.MapS with type key = constructor + module Indmap_env : CSig.MapS with type key = inductive + module Constrmap_env : CSig.MapS with type key = constructor type transparent_state = Id.Pred.t * Cpred.t + val empty_transparent_state : transparent_state val full_transparent_state : transparent_state val var_full_transparent_state : transparent_state val cst_full_transparent_state : transparent_state - val pr_kn : KerName.t -> Pp.std_ppcmds + val pr_kn : KerName.t -> Pp.t [@@ocaml.deprecated "alias of API.Names.KerName.print"] val eq_constant : Constant.t -> Constant.t -> bool @@ -310,9 +227,8 @@ sig [@@ocaml.deprecated "alias of API.Names.ModPath.t"] type variable = Id.t - [@@ocaml.deprecated "alias of API.Names.Id.t"] - type 'a tableKey = 'a Names.tableKey = + type 'a tableKey = | ConstKey of 'a | VarKey of Id.t | RelKey of Int.t @@ -383,11 +299,11 @@ sig val make_con : ModPath.t -> DirPath.t -> Label.t -> Constant.t [@@ocaml.deprecated "alias of API.Names.Constant.make3"] - val debug_pr_con : Constant.t -> Pp.std_ppcmds + val debug_pr_con : Constant.t -> Pp.t - val debug_pr_mind : MutInd.t -> Pp.std_ppcmds + val debug_pr_mind : MutInd.t -> Pp.t - val pr_con : Constant.t -> Pp.std_ppcmds + val pr_con : Constant.t -> Pp.t val string_of_con : Constant.t -> string @@ -397,23 +313,297 @@ sig val debug_string_of_con : Constant.t -> string - module Idset : module type of struct include Id.Set end + type identifier = Id.t + module Idset : Set.S with type elt = identifier and type t = Id.Set.t + end -module Context : +module Univ : +sig + + module Level : + sig + type t + val set : t + val pr : t -> Pp.t + end + + type universe_level = Level.t + + module LSet : + sig + include CSig.SetS with type elt = universe_level + val pr : (Level.t -> Pp.t) -> t -> Pp.t + end + + module Universe : + sig + type t + val pr : t -> Pp.t + end + + type universe = Universe.t + + module Instance : + sig + type t + val empty : t + val of_array : Level.t array -> t + val to_array : t -> Level.t array + val pr : (Level.t -> Pp.t) -> t -> Pp.t + end + + type 'a puniverses = 'a * Instance.t + + val out_punivs : 'a puniverses -> 'a + + type constraint_type = Lt | Le | Eq + + type univ_constraint = universe_level * constraint_type * universe_level + + module Constraint : sig + include Set.S with type elt = univ_constraint + end + + type 'a constrained = 'a * Constraint.t + + module UContext : + sig + type t + val empty : t + end + + type universe_context = UContext.t + + module AUContext : + sig + type t + val empty : t + end + + type abstract_universe_context = AUContext.t + + module CumulativityInfo : + sig + type t + end + + type cumulativity_info = CumulativityInfo.t + + module ACumulativityInfo : + sig + type t + end + type abstract_cumulativity_info = ACumulativityInfo.t + + module ContextSet : + sig + type t + val empty : t + val of_context : UContext.t -> t + val to_context : t -> UContext.t + end + + type 'a in_universe_context_set = 'a * ContextSet.t + type 'a in_universe_context = 'a * UContext.t + + type universe_context_set = ContextSet.t + + type universe_set = LSet.t + + type 'a constraint_function = 'a -> 'a -> Constraint.t -> Constraint.t + + module LMap : + sig + include CMap.ExtS with type key = universe_level and module Set := LSet + + val union : 'a t -> 'a t -> 'a t + val diff : 'a t -> 'a t -> 'a t + val subst_union : 'a option t -> 'a option t -> 'a option t + val pr : ('a -> Pp.t) -> 'a t -> Pp.t + end + + type 'a universe_map = 'a LMap.t + type universe_subst = universe universe_map + type universe_level_subst = universe_level universe_map + + val enforce_leq : Universe.t constraint_function + val pr_uni : Universe.t -> Pp.t + val pr_universe_context : (Level.t -> Pp.t) -> UContext.t -> Pp.t + val pr_universe_context_set : (Level.t -> Pp.t) -> ContextSet.t -> Pp.t + val pr_universe_subst : universe_subst -> Pp.t + val pr_universe_level_subst : universe_level_subst -> Pp.t + val pr_constraints : (Level.t -> Pp.t) -> Constraint.t -> Pp.t +end + +module UGraph : sig + type t + val pr_universes : (Univ.Level.t -> Pp.t) -> t -> Pp.t +end + +module Esubst : +sig + type 'a subs + val subs_id : int -> 'a subs +end + +module Sorts : +sig + type contents = Pos | Null + type t = + | Prop of contents + | Type of Univ.Universe.t + val is_prop : t -> bool + val hash : t -> int + + type family = InProp | InSet | InType + val family : t -> family +end + +module Evar : +sig + (** Unique identifier of some {i evar} *) + type t + + (** Recover the underlying integer. *) + val repr : t -> int + + val equal : t -> t -> bool + + (** a set of unique identifiers of some {i evars} *) + module Set : Set.S with type elt = t + module Map : CMap.ExtS with type key = t and module Set := Set + +end + +module Constr : +sig + open Names + + type t + + type constr = t + type types = t + + type cast_kind = + | VMcast + | NATIVEcast + | DEFAULTcast + | REVERTcast + + type metavariable = int + + type existential_key = Evar.t + type 'constr pexistential = existential_key * 'constr array + type 'a puniverses = 'a Univ.puniverses + type pconstant = Constant.t puniverses + type pinductive = inductive puniverses + type pconstructor = constructor puniverses + + type ('constr, 'types) prec_declaration = + Name.t array * 'types array * 'constr array + + type ('constr, 'types) pfixpoint = + (int array * int) * ('constr, 'types) prec_declaration + + type ('constr, 'types) pcofixpoint = + int * ('constr, 'types) prec_declaration + + type case_style = + LetStyle | IfStyle | LetPatternStyle | MatchStyle + | RegularStyle (** infer printing form from number of constructor *) + + type case_printing = + { ind_tags : bool list; (** tell whether letin or lambda in the arity of the inductive type *) + cstr_tags : bool list array; (** tell whether letin or lambda in the signature of each constructor *) + style : case_style } + + type case_info = + { ci_ind : inductive; (* inductive type to which belongs the value that is being matched *) + ci_npar : int; (* number of parameters of the above inductive type *) + ci_cstr_ndecls : int array; (* For each constructor, the corresponding integer determines + the number of values that can be bound in a match-construct. + NOTE: parameters of the inductive type are therefore excluded from the count *) + ci_cstr_nargs : int array; (* for each constructor, the corresponding integers determines + the number of values that can be applied to the constructor, + in addition to the parameters of the related inductive type + NOTE: "lets" are therefore excluded from the count + NOTE: parameters of the inductive type are also excluded from the count *) + ci_pp_info : case_printing (* not interpreted by the kernel *) + } + + type ('constr, 'types, 'sort, 'univs) kind_of_term = + | Rel of int + | Var of Id.t + | Meta of metavariable + | Evar of 'constr pexistential + | Sort of 'sort + | Cast of 'constr * cast_kind * 'types + | Prod of Name.t * 'types * 'types + | Lambda of Name.t * 'types * 'constr + | LetIn of Name.t * 'constr * 'types * 'constr + | App of 'constr * 'constr array + | Const of (Constant.t * 'univs) + | Ind of (inductive * 'univs) + | Construct of (constructor * 'univs) + | Case of case_info * 'constr * 'constr * 'constr array + | Fix of ('constr, 'types) pfixpoint + | CoFix of ('constr, 'types) pcofixpoint + | Proj of Projection.t * 'constr + + val equal : t -> t -> bool + val eq_constr_nounivs : t -> t -> bool + val compare : t -> t -> int + + val hash : t -> int + + val mkRel : int -> t + val mkVar : Id.t -> t + val mkMeta : metavariable -> t + type existential = existential_key * constr array + val mkEvar : existential -> t + val mkSort : Sorts.t -> t + val mkProp : t + val mkSet : t + val mkType : Univ.Universe.t -> t + val mkCast : t * cast_kind * t -> t + val mkProd : Name.t * types * types -> types + val mkLambda : Name.t * types * t -> t + val mkLetIn : Name.t * t * types * t -> t + val mkApp : t * t array -> t + val map_puniverses : ('a -> 'b) -> 'a puniverses -> 'b puniverses + + val mkConst : Constant.t -> t + val mkConstU : pconstant -> t + + val mkProj : (Projection.t * t) -> t + + val mkInd : inductive -> t + val mkIndU : pinductive -> t + + val mkConstruct : constructor -> t + val mkConstructU : pconstructor -> t + val mkConstructUi : pinductive * int -> t + + val mkCase : case_info * t * t * t array -> t + +end + +module Context : +sig module Rel : sig module Declaration : sig (* local declaration *) (* local declaration *) - type ('constr, 'types) pt = ('constr, 'types) Context.Rel.Declaration.pt = + type ('constr, 'types) pt = | LocalAssum of Names.Name.t * 'types (** name, type *) | LocalDef of Names.Name.t * 'constr * 'types (** name, value, type *) - type t = (Prelude.constr, Prelude.types) pt + type t = (Constr.constr, Constr.types) pt (** Return the name bound by a given declaration. *) val get_name : ('c, 't) pt -> Names.Name.t @@ -450,7 +640,7 @@ sig val map_constr : ('c -> 'c) -> ('c, 'c) pt -> ('c, 'c) pt (** Perform a given action on all terms in a given declaration. *) - val iter_constr : ('c -> unit) -> ('c, 'c) pt -> unit + val iter_constr : ('c -> unit) -> ('c, 'c) pt -> unit (** Reduce all terms in a given declaration to a single value. *) val fold_constr : ('c -> 'a -> 'a) -> ('c, 'c) pt -> 'a -> 'a @@ -503,11 +693,11 @@ sig module Declaration : sig (** local declaration *) - type ('constr, 'types) pt = ('constr, 'types) Context.Named.Declaration.pt = + type ('constr, 'types) pt = | LocalAssum of Names.Id.t * 'types (** identifier, type *) | LocalDef of Names.Id.t * 'constr * 'types (** identifier, value, type *) - type t = (Prelude.constr, Prelude.types) pt + type t = (Constr.constr, Constr.types) pt (** Return the identifier bound by a given declaration. *) val get_id : ('c, 't) pt -> Names.Id.t @@ -604,12 +794,32 @@ sig end end +module Vars : +sig + type substl = Constr.t list + + val substl : substl -> Constr.t -> Constr.t + + val subst1 : Constr.t -> Constr.t -> Constr.t + + val lift : int -> Constr.t -> Constr.t + + val closed0 : Constr.t -> bool + + val closedn : int -> Constr.t -> bool + + val replace_vars : (Names.Id.t * Constr.t) list -> Constr.t -> Constr.t + + val noccurn : int -> Constr.t -> bool + val subst_var : Names.Id.t -> Constr.t -> Constr.t + val subst_vars : Names.Id.t list -> Constr.t -> Constr.t + val substnl : substl -> int -> Constr.t -> Constr.t +end + module Term : sig - type sorts_family = Sorts.family = InProp | InSet | InType - [@@deprecated "alias of API.Sorts.family"] - type metavariable = Prelude.metavariable + type sorts_family = Sorts.family = InProp | InSet | InType type contents = Sorts.contents = Pos | Null @@ -618,45 +828,55 @@ sig | Type of Univ.Universe.t [@@ocaml.deprecated "alias of API.Sorts.t"] - type constr = Prelude.constr - type types = Prelude.types + type constr = Constr.t + type types = Constr.t + + type metavariable = int + type ('constr, 'types) prec_declaration = Names.Name.t array * 'types array * 'constr array - type 'constr pexistential = 'constr Prelude.pexistential - type cast_kind = Term.cast_kind = + + type 'constr pexistential = 'constr Constr.pexistential + type cast_kind = Constr.cast_kind = | VMcast | NATIVEcast | DEFAULTcast | REVERTcast + type 'a puniverses = 'a Univ.puniverses type pconstant = Names.Constant.t puniverses type pinductive = Names.inductive puniverses type pconstructor = Names.constructor puniverses - type case_style = Term.case_style = - | LetStyle - | IfStyle - | LetPatternStyle - | MatchStyle - | RegularStyle - type case_printing = Term.case_printing = - { ind_tags : bool list; - cstr_tags : bool list array; - style : case_style - } - type case_info = Term.case_info = - { ci_ind : Names.inductive; - ci_npar : int; - ci_cstr_ndecls : int array; - ci_cstr_nargs : int array; - ci_pp_info : case_printing - } + type case_style = Constr.case_style = + | LetStyle + | IfStyle + | LetPatternStyle + | MatchStyle + | RegularStyle + + type case_printing = Constr.case_printing = + { ind_tags : bool list; + cstr_tags : bool list array; + style : case_style + } + + type case_info = Constr.case_info = + { ci_ind : Names.inductive; + ci_npar : int; + ci_cstr_ndecls: int array; + ci_cstr_nargs : int array; + ci_pp_info : case_printing + } + type ('constr, 'types) pfixpoint = (int array * int) * ('constr, 'types) prec_declaration + type ('constr, 'types) pcofixpoint = int * ('constr, 'types) prec_declaration - type ('constr, 'types, 'sort, 'univs) kind_of_term = ('constr, 'types, 'sort, 'univs) Term.kind_of_term = + + 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 metavariable + | Meta of Constr.metavariable | Evar of 'constr pexistential | Sort of 'sort | Cast of 'constr * cast_kind * 'types @@ -671,7 +891,7 @@ sig | Fix of ('constr, 'types) pfixpoint | CoFix of ('constr, 'types) pcofixpoint | Proj of Names.Projection.t * 'constr - type existential = Prelude.evar * constr array + type existential = Constr.existential_key * constr array type rec_declaration = Names.Name.t array * constr array * constr array type fixpoint = (int array * int) * rec_declaration type cofixpoint = int * rec_declaration @@ -685,7 +905,7 @@ sig val mkRel : int -> constr val mkVar : Names.Id.t -> constr - val mkMeta : Prelude.metavariable -> constr + val mkMeta : Constr.metavariable -> constr val mkEvar : existential -> constr val mkSort : Sorts.t -> types @@ -765,18 +985,19 @@ sig *) val eq_constr_nounivs : constr -> constr -> bool - type ('constr, 'types) kind_of_type = ('constr, 'types) Term.kind_of_type = - | SortType of Sorts.t - | CastType of 'types * 'types - | ProdType of Names.Name.t * 'types * 'types - | LetInType of Names.Name.t * 'constr * 'types * 'types - | AtomicType of 'constr * 'constr array + type ('constr, 'types) kind_of_type = + | SortType of Sorts.t + | CastType of 'types * 'types + | ProdType of Names.Name.t * 'types * 'types + | LetInType of Names.Name.t * 'constr * 'types * 'types + | AtomicType of 'constr * 'constr array + val kind_of_type : types -> (constr, types) kind_of_type val is_prop_sort : Sorts.t -> bool [@@ocaml.deprecated "alias of API.Sorts.is_prop"] - type existential_key = Prelude.evar + type existential_key = Constr.existential_key val family_of_sort : Sorts.t -> Sorts.family @@ -797,181 +1018,13 @@ sig val compare_constr : (constr -> constr -> bool) -> constr -> constr -> bool end -module EConstr : -sig - type t = EConstr.t - type constr = t - type types = t - type unsafe_judgment = EConstr.unsafe_judgment - type named_declaration = (constr, types) Context.Named.Declaration.pt - type named_context = (constr, types) Context.Named.pt - type rel_context = (constr, types) Context.Rel.pt - type rel_declaration = (constr, types) Context.Rel.Declaration.pt - type existential = constr Term.pexistential - module ESorts : - sig - type t = EConstr.ESorts.t - (** Type of sorts up-to universe unification. Essentially a wrapper around - Sorts.t so that normalization is ensured statically. *) - - val make : Sorts.t -> t - (** Turn a sort into an up-to sort. *) - - val kind : Prelude.evar_map -> t -> Sorts.t - (** Returns the view into the current sort. Note that the kind of a variable - may change if the unification state of the evar map changes. *) - - end - - module EInstance : - sig - type t = EConstr.EInstance.t - (** Type of universe instances up-to universe unification. Similar to - {ESorts.t} for {Univ.Instance.t}. *) - - val make : Univ.Instance.t -> t - val kind : Prelude.evar_map -> t -> Univ.Instance.t - val empty : t - val is_empty : t -> bool - end - - val of_constr : Term.constr -> constr - - val kind : Prelude.evar_map -> constr -> (constr, constr, ESorts.t, EInstance.t) Term.kind_of_term - - val mkArrow : constr -> constr -> constr - val mkInd : Names.inductive -> t - val mkProp : constr - val mkProd : Names.Name.t * constr * constr -> constr - val mkRel : int -> constr - val mkSort : Sorts.t -> constr - val mkVar : Names.Id.t -> constr - val mkLambda : Names.Name.t * constr * constr -> constr - val mkLambda_or_LetIn : rel_declaration -> constr -> constr - val mkApp : constr * constr array -> constr - val mkEvar : constr Term.pexistential -> constr - - val mkMeta : Prelude.metavariable -> constr - - val mkConstructU : Names.constructor * EInstance.t -> constr - val mkLetIn : Names.Name.t * constr * constr * constr -> constr - val mkProd_or_LetIn : rel_declaration -> constr -> constr - val mkCast : constr * Term.cast_kind * constr -> constr - val mkNamedLambda : Names.Id.t -> types -> constr -> constr - val mkNamedProd : Names.Id.t -> types -> types -> types - - val isCast : Evd.evar_map -> t -> bool - val isEvar : Prelude.evar_map -> constr -> bool - val isInd : Prelude.evar_map -> constr -> bool - val isRel : Prelude.evar_map -> constr -> bool - val isSort : Prelude.evar_map -> constr -> bool - val isVar : Prelude.evar_map -> constr -> bool - val isConst : Prelude.evar_map -> constr -> bool - val isConstruct : Prelude.evar_map -> constr -> bool - - val destInd : Prelude.evar_map -> constr -> Names.inductive * EInstance.t - val destVar : Prelude.evar_map -> constr -> Names.Id.t - val destEvar : Prelude.evar_map -> constr -> constr Term.pexistential - val destRel : Prelude.evar_map -> constr -> int - val destProd : Prelude.evar_map -> constr -> Names.Name.t * types * types - val destLambda : Prelude.evar_map -> constr -> Names.Name.t * types * constr - val destApp : Prelude.evar_map -> constr -> constr * constr array - val destConst : Prelude.evar_map -> constr -> Names.Constant.t * EInstance.t - val destConstruct : Prelude.evar_map -> constr -> Names.constructor * EInstance.t - val destFix : Evd.evar_map -> t -> (t, t) Term.pfixpoint - val destCast : Evd.evar_map -> t -> t * Term.cast_kind * t - - val mkConstruct : Names.constructor -> constr - - val compose_lam : (Names.Name.t * constr) list -> constr -> constr - - val decompose_lam : Prelude.evar_map -> constr -> (Names.Name.t * constr) list * constr - val decompose_lam_n_assum : Prelude.evar_map -> int -> constr -> rel_context * constr - val decompose_app : Prelude.evar_map -> constr -> constr * constr list - val decompose_prod : Prelude.evar_map -> constr -> (Names.Name.t * constr) list * constr - val decompose_prod_assum : Prelude.evar_map -> constr -> rel_context * constr - - val applist : constr * constr list -> constr - - val to_constr : Prelude.evar_map -> constr -> Constr.t - - val push_rel : rel_declaration -> Prelude.env -> Prelude.env - - module Unsafe : - sig - val to_constr : constr -> Term.constr - - val to_rel_decl : (constr, types) Context.Rel.Declaration.pt -> (Prelude.constr, Prelude.types) Context.Rel.Declaration.pt - - (** Physical identity. Does not care for defined evars. *) - - val to_named_decl : (constr, types) Context.Named.Declaration.pt -> (Prelude.constr, Prelude.types) Context.Named.Declaration.pt - - val to_instance : EInstance.t -> Univ.Instance.t - end - - module Vars : - sig - val substnl : t list -> int -> t -> t - val noccurn : Prelude.evar_map -> int -> constr -> bool - val closed0 : Prelude.evar_map -> constr -> bool - val subst1 : constr -> constr -> constr - val substl : constr list -> constr -> constr - val lift : int -> constr -> constr - val liftn : int -> int -> t -> t - val subst_var : Names.Id.t -> t -> t - val subst_vars : Names.Id.t list -> t -> t - end - - val fresh_global : - ?loc:Loc.t -> ?rigid:Prelude.rigid -> ?names:Univ.Instance.t -> Environ.env -> - Evd.evar_map -> Prelude.global_reference -> Evd.evar_map * t - -val of_named_decl : (Term.constr, Term.types) Context.Named.Declaration.pt -> (constr, types) Context.Named.Declaration.pt - val of_rel_decl : (Term.constr, Term.types) Context.Rel.Declaration.pt -> (constr, types) Context.Rel.Declaration.pt - val kind_of_type : Prelude.evar_map -> constr -> (constr, constr) Term.kind_of_type - val to_lambda : Prelude.evar_map -> int -> constr -> constr - val it_mkLambda_or_LetIn : constr -> rel_context -> constr - val push_rel_context : rel_context -> Prelude.env -> Prelude.env - val eq_constr : Prelude.evar_map -> constr -> constr -> bool - val iter_with_binders : Prelude.evar_map -> ('a -> 'a) -> ('a -> constr -> unit) -> 'a -> constr -> unit - val fold : Prelude.evar_map -> ('a -> constr -> 'a) -> 'a -> constr -> 'a - val existential_type : Prelude.evar_map -> existential -> types - val iter : Prelude.evar_map -> (constr -> unit) -> constr -> unit - val eq_constr_universes : Prelude.evar_map -> constr -> constr -> Universes.universe_constraints option - val eq_constr_nounivs : Prelude.evar_map -> constr -> constr -> bool - val compare_constr : Evd.evar_map -> (constr -> constr -> bool) -> constr -> constr -> bool - val isApp : Prelude.evar_map -> constr -> bool - val it_mkProd_or_LetIn : constr -> rel_context -> constr - val push_named : named_declaration -> Prelude.env -> Prelude.env - val destCase : Prelude.evar_map -> constr -> Term.case_info * constr * constr * constr array - val decompose_lam_assum : Prelude.evar_map -> constr -> rel_context * constr - val mkConst : Names.Constant.t -> constr - val mkCase : Term.case_info * constr * constr * constr array -> constr - val named_context : Prelude.env -> named_context - val val_of_named_context : named_context -> Prelude.named_context_val - val mkFix : (t, t) Term.pfixpoint -> t - val decompose_prod_n_assum : Evd.evar_map -> int -> t -> rel_context * t - val isMeta : Evd.evar_map -> t -> bool - - val destMeta : Evd.evar_map -> t -> Term.metavariable - - val map_with_binders : Evd.evar_map -> ('a -> 'a) -> ('a -> t -> t) -> 'a -> t -> t - val mkNamedLetIn : Names.Id.t -> constr -> types -> constr -> constr - val map : Evd.evar_map -> (t -> t) -> t -> t - val mkConstU : Names.Constant.t * EInstance.t -> t - val isProd : Evd.evar_map -> t -> bool - val mkConstructUi : (Names.inductive * EInstance.t) * int -> t - val isLambda : Evd.evar_map -> t -> bool -end - module Mod_subst : sig - type substitution = Mod_subst.substitution - type 'a substituted = 'a Mod_subst.substituted - type delta_resolver = Mod_subst.delta_resolver + type delta_resolver + type substitution + type 'a substituted - val force_constr : Term.constr substituted -> Term.constr + val force_constr : Constr.t substituted -> Constr.t val empty_delta_resolver : delta_resolver val constant_of_delta_kn : delta_resolver -> Names.KerName.t -> Names.Constant.t @@ -979,21 +1032,94 @@ sig val subst_kn : substitution -> Names.KerName.t -> Names.KerName.t val subst_evaluable_reference : substitution -> Names.evaluable_global_reference -> Names.evaluable_global_reference - val subst_mps : substitution -> Term.constr -> Term.constr + val subst_mps : substitution -> Constr.t -> Constr.t val subst_constant : substitution -> Names.Constant.t -> Names.Constant.t val subst_ind : substitution -> Names.inductive -> Names.inductive - val debug_pr_subst : substitution -> Pp.std_ppcmds - val debug_pr_delta : delta_resolver -> Pp.std_ppcmds + val debug_pr_subst : substitution -> Pp.t + val debug_pr_delta : delta_resolver -> Pp.t +end + +module Opaqueproof : +sig + type opaquetab + type opaque + val empty_opaquetab : opaquetab + val force_proof : opaquetab -> opaque -> Constr.t +end + +module Cbytecodes : +sig + type tag = int + type reloc_table = (tag * int) array +end + +module Cemitcodes : +sig + type to_patch_substituted +end + +module Decl_kinds : +sig + type polymorphic = bool + type cumulative_inductive_flag = bool + type recursivity_kind = + | Finite + | CoFinite + | BiFinite + + type locality = + | Discharge + | Local + | Global + + type definition_object_kind = + | Definition + | Coercion + | SubClass + | CanonicalStructure + | Example + | Fixpoint + | CoFixpoint + | Scheme + | StructureComponent + | IdentityCoercion + | Instance + | Method + type theorem_kind = + | Theorem + | Lemma + | Fact + | Remark + | Property + | Proposition + | Corollary + type goal_object_kind = + | DefinitionBody of definition_object_kind + | Proof of theorem_kind + type goal_kind = locality * polymorphic * goal_object_kind + type assumption_object_kind = + | Definitional + | Logical + | Conjectural + type logical_kind = + | IsAssumption of assumption_object_kind + | IsDefinition of definition_object_kind + | IsProof of theorem_kind + type binding_kind = + | Explicit + | Implicit + type private_flag = bool + type definition_kind = locality * polymorphic * definition_object_kind end module Retroknowledge : sig - type action = Retroknowledge.action - type nat_field = Retroknowledge.nat_field = + type action + type nat_field = | NatType | NatPlus | NatTimes - type n_field = Retroknowledge.n_field = + type n_field = | NPositive | NType | NTwice @@ -1002,7 +1128,7 @@ sig | NPhiInv | NPlus | NTimes - type int31_field = Retroknowledge.int31_field = + type int31_field = | Int31Bits | Int31Type | Int31Constructor @@ -1028,63 +1154,85 @@ sig | Int31Lor | Int31Land | Int31Lxor - type field = Retroknowledge.field = + type field = | KInt31 of string * int31_field end +module Conv_oracle : +sig + type level +end + module Declarations : sig - type recarg = Declarations.recarg = + + open Names + + type recarg = | Norec | Mrec of Names.inductive | Imbr of Names.inductive type wf_paths = recarg Rtree.t - type inline = Declarations.inline - type constant_def = Declarations.constant_def = + type inline = int option + type constant_def = | Undef of inline - | Def of Term.constr Mod_subst.substituted + | Def of Constr.t Mod_subst.substituted | OpaqueDef of Opaqueproof.opaque - type template_arity = Declarations.template_arity = { + type template_arity = { template_param_levels : Univ.Level.t option list; template_level : Univ.Universe.t; } - type ('a, 'b) declaration_arity = ('a, 'b) Declarations.declaration_arity = + type ('a, 'b) declaration_arity = | RegularArity of 'a | TemplateArity of 'b - type constant_type = (Prelude.types, Context.Rel.t * template_arity) declaration_arity - type constant_universes = Declarations.constant_universes - type projection_body = Declarations.projection_body = { + type constant_universes = + | Monomorphic_const of Univ.universe_context + | Polymorphic_const of Univ.abstract_universe_context + + type projection_body = { proj_ind : Names.MutInd.t; proj_npars : int; proj_arg : int; - proj_type : Term.types; - proj_eta : Term.constr * Term.types; - proj_body : Term.constr; + proj_type : Constr.types; + proj_eta : Constr.t * Constr.types; + proj_body : Constr.t; } - type typing_flags = Declarations.typing_flags - type constant_body = Declarations.constant_body = { + type typing_flags = { + check_guarded : bool; + check_universes : bool; + } + + type constant_body = { const_hyps : Context.Named.t; const_body : constant_def; - const_type : constant_type; + const_type : Term.types; const_body_code : Cemitcodes.to_patch_substituted option; const_universes : constant_universes; const_proj : projection_body option; const_inline_code : bool; const_typing_flags : typing_flags; } - type one_inductive_body = Declarations.one_inductive_body = { + + type regular_inductive_arity = { + mind_user_arity : Constr.types; + mind_sort : Sorts.t; + } + + type inductive_arity = (regular_inductive_arity, template_arity) declaration_arity + + type one_inductive_body = { mind_typename : Names.Id.t; mind_arity_ctxt : Context.Rel.t; - mind_arity : Declarations.inductive_arity; + mind_arity : inductive_arity; mind_consnames : Names.Id.t array; - mind_user_lc : Term.types array; + mind_user_lc : Constr.types array; mind_nrealargs : int; mind_nrealdecls : int; mind_kelim : Sorts.family list; - mind_nf_lc : Term.types array; + mind_nf_lc : Constr.types array; mind_consnrealargs : int array; mind_consnrealdecls : int array; mind_recargs : wf_paths; @@ -1092,42 +1240,47 @@ sig mind_nb_args : int; mind_reloc_tbl : Cbytecodes.reloc_table; } - type ('ty,'a) functorize = ('ty,'a) Declarations.functorize = + + type ('ty,'a) functorize = | NoFunctor of 'a | MoreFunctor of Names.MBId.t * 'ty * ('ty,'a) functorize - type with_declaration = Declarations.with_declaration = + + type with_declaration = | WithMod of Names.Id.t list * Names.ModPath.t - | WithDef of Names.Id.t list * Term.constr Univ.in_universe_context - type module_alg_expr = Declarations.module_alg_expr = + | WithDef of Names.Id.t list * Constr.t Univ.in_universe_context + + type module_alg_expr = | MEident of Names.ModPath.t | MEapply of module_alg_expr * Names.ModPath.t | MEwith of module_alg_expr * with_declaration - type abstract_inductive_universes = Declarations.abstract_inductive_universes = - | Monomorphic_ind of Univ.UContext.t - | Polymorphic_ind of Univ.abstract_universe_context - | Cumulative_ind of Univ.abstract_cumulativity_info + type abstract_inductive_universes = + | Monomorphic_ind of Univ.universe_context + | Polymorphic_ind of Univ.abstract_universe_context + | Cumulative_ind of Univ.abstract_cumulativity_info - type mutual_inductive_body = Declarations.mutual_inductive_body = { + type record_body = (Id.t * Constant.t array * projection_body array) option + + type mutual_inductive_body = { mind_packets : one_inductive_body array; - mind_record : Declarations.record_body option; + mind_record : record_body option; mind_finite : Decl_kinds.recursivity_kind; mind_ntypes : int; mind_hyps : Context.Named.t; mind_nparams : int; mind_nparams_rec : int; mind_params_ctxt : Context.Rel.t; - mind_universes : Declarations.abstract_inductive_universes; + mind_universes : abstract_inductive_universes; mind_private : bool option; - mind_typing_flags : Declarations.typing_flags; + mind_typing_flags : typing_flags; } and module_expression = (module_type_body,module_alg_expr) functorize - and module_implementation = Declarations.module_implementation = + and module_implementation = | Abstract | Algebraic of module_expression | Struct of module_signature | FullStruct - and module_body = Declarations.module_body = + and module_body = { mod_mp : Names.ModPath.t; mod_expr : module_implementation; mod_type : module_signature; @@ -1139,28 +1292,99 @@ sig and module_signature = (module_type_body,structure_body) functorize and module_type_body = module_body and structure_body = (Names.Label.t * structure_field_body) list - and structure_field_body = Declarations.structure_field_body = + and structure_field_body = | SFBconst of constant_body | SFBmind of mutual_inductive_body | SFBmodule of module_body | SFBmodtype of module_type_body end -module Univops : sig - val universes_of_constr : Term.constr -> Univ.LSet.t - val restrict_universe_context : Univ.ContextSet.t -> Univ.LSet.t -> Univ.ContextSet.t +module Declareops : +sig + val constant_has_body : Declarations.constant_body -> bool + val is_opaque : Declarations.constant_body -> bool + val eq_recarg : Declarations.recarg -> Declarations.recarg -> bool +end + +module Entries : +sig + + open Names + open Constr + + type local_entry = + | LocalDefEntry of constr + | 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 + + type one_inductive_entry = { + mind_entry_typename : Id.t; + mind_entry_arity : constr; + mind_entry_template : bool; (* Use template polymorphism *) + mind_entry_consnames : Id.t list; + mind_entry_lc : constr list } + + type mutual_inductive_entry = { + mind_entry_record : (Names.Id.t option) option; + (** Some (Some id): primitive record with id the binder name of the record + in projections. + Some None: non-primitive record *) + mind_entry_finite : Decl_kinds.recursivity_kind; + mind_entry_params : (Id.t * local_entry) list; + mind_entry_inds : one_inductive_entry list; + mind_entry_universes : inductive_universes; + (* universe constraints and the constraints for subtyping of + inductive types in the block. *) + mind_entry_private : bool option; + } + + type inline = int option + 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 + type 'a definition_entry = + { const_entry_body : 'a const_entry_body; + (* List of section variables *) + const_entry_secctx : Context.Named.t option; + (* State id on which the completion of type checking is reported *) + const_entry_feedback : Stateid.t option; + const_entry_type : Constr.types option; + const_entry_universes : constant_universes_entry; + const_entry_opaque : bool; + const_entry_inline_code : bool } + type parameter_entry = Context.Named.t option * bool * Constr.types Univ.in_universe_context * inline + + type projection_entry = { + proj_entry_ind : MutInd.t; + proj_entry_arg : int } + + type 'a constant_entry = + | DefinitionEntry of 'a definition_entry + | ParameterEntry of parameter_entry + | ProjectionEntry of projection_entry + type module_struct_entry = Declarations.module_alg_expr + type module_params_entry = + (Names.MBId.t * module_struct_entry) list + type module_type_entry = module_params_entry * module_struct_entry end module Environ : sig - type env = Prelude.env - type named_context_val = Prelude.named_context_val - type ('constr, 'types) punsafe_judgment = ('constr, 'types) Environ.punsafe_judgment = + type env + type named_context_val + + type ('constr, 'types) punsafe_judgment = { uj_val : 'constr; uj_type : 'types } - type 'types punsafe_type_judgment = 'types Environ.punsafe_type_judgment = { + type 'types punsafe_type_judgment = { utj_val : 'types; utj_type : Sorts.t } @@ -1172,7 +1396,7 @@ sig val push_rec_types : Term.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 -> Environ.named_context_val -> Context.Named.Declaration.t + val lookup_named_val : Names.Id.t -> named_context_val -> Context.Named.Declaration.t val lookup_constant : Names.Constant.t -> env -> Declarations.constant_body val opaque_tables : env -> Opaqueproof.opaquetab val is_projection : Names.Constant.t -> env -> bool @@ -1184,63 +1408,170 @@ sig val push_named_context_val : Context.Named.Declaration.t -> named_context_val -> named_context_val val reset_with_named_context : named_context_val -> env -> env val rel_context : env -> Context.Rel.t - val constant_value_in : env -> Names.Constant.t Univ.puniverses -> Term.constr - val named_type : Names.Id.t -> env -> Term.types - val constant_opt_value_in : env -> Names.Constant.t Univ.puniverses -> Term.constr option + val constant_value_in : env -> Names.Constant.t Univ.puniverses -> Constr.t + val named_type : Names.Id.t -> env -> Constr.types + val constant_opt_value_in : env -> Names.Constant.t Univ.puniverses -> Constr.t option val fold_named_context_reverse : ('a -> Context.Named.Declaration.t -> 'a) -> init:'a -> env -> 'a - val evaluable_named : Names.Id.t -> Environ.env -> bool + val evaluable_named : Names.Id.t -> env -> bool val push_context_set : ?strict:bool -> Univ.ContextSet.t -> env -> env end -module UGraph : +module CClosure : sig - type t = UGraph.t - val pr_universes : (Univ.Level.t -> Pp.std_ppcmds) -> t -> Pp.std_ppcmds + + type table_key = Names.Constant.t Univ.puniverses Names.tableKey + + type fconstr + + type fterm = + | FRel of int + | FAtom of Constr.t (** Metas and Sorts *) + | FCast of fconstr * Constr.cast_kind * fconstr + | FFlex of table_key + | FInd of Names.inductive Univ.puniverses + | 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 *) + | 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 + | FLIFT of int * fconstr + | FCLOS of Constr.t * fconstr Esubst.subs + | FLOCKED + + module RedFlags : sig + type reds + type red_kind + val mkflags : red_kind list -> reds + val fBETA : red_kind + val fCOFIX : red_kind + val fCONST : Names.Constant.t -> red_kind + val fFIX : red_kind + val fMATCH : red_kind + val fZETA : red_kind + val red_add_transparent : reds -> Names.transparent_state -> reds + end + + type 'a infos_cache + type 'a infos = { + i_flags : RedFlags.reds; + i_cache : 'a infos_cache } + + type clos_infos = fconstr infos + + val mk_clos : fconstr Esubst.subs -> Constr.t -> fconstr + val mk_atom : Constr.t -> fconstr + val mk_clos_deep : + (fconstr Esubst.subs -> Constr.t -> fconstr) -> + fconstr Esubst.subs -> Constr.t -> fconstr + val mk_red : fterm -> fconstr + val all : RedFlags.reds + val beta : RedFlags.reds + 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 whd_val : clos_infos -> fconstr -> Constr.t + + val inject : Constr.t -> fconstr + + val kl : clos_infos -> fconstr -> Constr.t + val term_of_fconstr : fconstr -> Constr.t end module Reduction : sig exception NotConvertible - type conv_pb = Prelude.conv_pb = + type conv_pb = | CONV | CUMUL - val whd_all : Environ.env -> Term.constr -> Term.constr + val whd_all : Environ.env -> Constr.t -> Constr.t - val whd_betaiotazeta : Environ.env -> Term.constr -> Term.constr + val whd_betaiotazeta : Environ.env -> Constr.t -> Constr.t val is_arity : Environ.env -> Term.types -> bool val dest_prod : Environ.env -> Term.types -> Context.Rel.t * Term.types - type 'a extended_conversion_function = + type 'a extended_conversion_function = ?l2r:bool -> ?reds:Names.transparent_state -> Environ.env -> - ?evars:((Term.existential->Term.constr option) * UGraph.t) -> + ?evars:((Term.existential->Constr.t option) * UGraph.t) -> 'a -> 'a -> unit - val conv : Term.constr extended_conversion_function + val conv : Constr.t extended_conversion_function end -module Vars : +module Type_errors : sig - type substl = Term.constr list - - val substl : substl -> Term.constr -> Term.constr - - val subst1 : Term.constr -> Term.constr -> Term.constr - - val lift : int -> Term.constr -> Term.constr - val closed0 : Term.constr -> bool + open Names + open Term + open Environ + + type 'constr pguard_error = + (** Fixpoints *) + | NotEnoughAbstractionInFixBody + | RecursionNotOnInductiveType of 'constr + | RecursionOnIllegalTerm of int * (env * 'constr) * int list * int list + | NotEnoughArgumentsForFixCall of int + (** CoFixpoints *) + | CodomainNotInductiveType of 'constr + | NestedRecursiveOccurrences + | UnguardedRecursiveCall of 'constr + | RecCallInTypeOfAbstraction of 'constr + | RecCallInNonRecArgOfConstructor of 'constr + | RecCallInTypeOfDef of 'constr + | RecCallInCaseFun of 'constr + | RecCallInCaseArg of 'constr + | RecCallInCasePred of 'constr + | NotGuardedForm of 'constr + | ReturnPredicateNotCoInductive of 'constr + + type arity_error = + | NonInformativeToInformative + | StrongEliminationOnNonSmallType + | WrongArity + + type ('constr, 'types) ptype_error = + | UnboundRel of int + | 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 + | CaseNotInductive of ('constr, 'types) punsafe_judgment + | WrongCaseInfo of pinductive * case_info + | NumberBranches of ('constr, 'types) punsafe_judgment * int + | IllFormedBranch of 'constr * pconstructor * 'constr * 'constr + | Generalization of (Name.t * 'types) * ('constr, 'types) punsafe_judgment + | ActualType of ('constr, 'types) punsafe_judgment * 'types + | CantApplyBadType of + (int * 'constr * 'constr) * ('constr, 'types) punsafe_judgment * ('constr, 'types) punsafe_judgment array + | CantApplyNonFunctional of ('constr, 'types) punsafe_judgment * ('constr, 'types) punsafe_judgment array + | IllFormedRecBody of 'constr pguard_error * Name.t array * int * env * ('constr, 'types) punsafe_judgment array + | IllTypedRecBody of + int * Name.t array * ('constr, 'types) punsafe_judgment array * 'types array + | UnsatisfiedConstraints of Univ.Constraint.t + + type type_error = (constr, types) ptype_error - val closedn : int -> Term.constr -> bool - - val replace_vars : (Names.Id.t * Term.constr) list -> Term.constr -> Term.constr + exception TypeError of Environ.env * type_error +end - val noccurn : int -> Term.constr -> bool - val subst_var : Names.Id.t -> Term.constr -> Term.constr - val subst_vars : Names.Id.t list -> Term.constr -> Term.constr - val substnl : substl -> int -> Term.constr -> Term.constr +module Modops : +sig + val destr_nofunctor : ('ty,'a) Declarations.functorize -> 'a + val add_structure : + Names.ModPath.t -> Declarations.structure_body -> Mod_subst.delta_resolver -> + Environ.env -> Environ.env + val add_module_type : Names.ModPath.t -> Declarations.module_type_body -> Environ.env -> Environ.env end module Inductive : @@ -1249,154 +1580,615 @@ sig val type_of_inductive : Environ.env -> mind_specif Univ.puniverses -> Term.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 * Term.constr list + val find_inductive : Environ.env -> Term.types -> Term.pinductive * Constr.t list end module Typeops : sig val infer_type : Environ.env -> Term.types -> Environ.unsafe_type_judgment - val type_of_constant_type : Environ.env -> Declarations.constant_type -> Term.types val type_of_constant_in : Environ.env -> Term.pconstant -> Term.types end -module Opaqueproof : +module Mod_typing : sig - type opaquetab = Opaqueproof.opaquetab - type opaque = Opaqueproof.opaque - val empty_opaquetab : opaquetab - val force_proof : opaquetab -> opaque -> Term.constr + type 'alg translation = + Declarations.module_signature * 'alg * Mod_subst.delta_resolver * Univ.ContextSet.t + val translate_modtype : + Environ.env -> Names.ModPath.t -> Entries.inline -> + Entries.module_type_entry -> Declarations.module_type_body + val translate_mse : + Environ.env -> Names.ModPath.t option -> Entries.inline -> Declarations.module_alg_expr -> + Declarations.module_alg_expr translation end -module Modops : +module Safe_typing : sig - val destr_nofunctor : ('ty,'a) Declarations.functorize -> 'a - val add_structure : - Names.ModPath.t -> Declarations.structure_body -> Mod_subst.delta_resolver -> - Environ.env -> Environ.env - val add_module_type : Names.ModPath.t -> Declarations.module_type_body -> Environ.env -> Environ.env + type private_constants + val mk_pure_proof : Constr.t -> private_constants Entries.proof_output end -module Entries : +(************************************************************************) +(* End of modules from kernel/ *) +(************************************************************************) + +(************************************************************************) +(* Modules from intf/ *) +(************************************************************************) + +module Misctypes : sig - type mutual_inductive_entry = Entries.mutual_inductive_entry - type inline = int option - type 'a proof_output = Term.constr Univ.in_universe_context_set * 'a - type 'a const_entry_body = 'a proof_output Future.computation - type 'a definition_entry = 'a Entries.definition_entry = - { const_entry_body : 'a const_entry_body; - (* List of section variables *) - const_entry_secctx : Context.Named.t option; - (* State id on which the completion of type checking is reported *) - const_entry_feedback : Stateid.t option; - const_entry_type : Term.types option; - const_entry_polymorphic : bool; - const_entry_universes : Univ.UContext.t; - const_entry_opaque : bool; - const_entry_inline_code : bool } - type parameter_entry = Context.Named.t option * bool * Term.types Univ.in_universe_context * inline - type projection_entry = Entries.projection_entry - type 'a constant_entry = 'a Entries.constant_entry = - | DefinitionEntry of 'a definition_entry - | ParameterEntry of parameter_entry - | ProjectionEntry of projection_entry + type evars_flag = bool + type clear_flag = bool option + type advanced_flag = bool + type rec_flag = bool + + type 'a or_by_notation = + | AN of 'a + | ByNotation of (string * string option) Loc.located + + type 'a or_var = + | ArgArg of 'a + | ArgVar of Names.Id.t Loc.located + + type 'a and_short_name = 'a * Names.Id.t Loc.located option + + type 'a glob_sort_gen = + | GProp (** representation of [Prop] literal *) + | GSet (** representation of [Set] literal *) + | GType of 'a (** representation of [Type] literal *) + + type level_info = Names.Name.t Loc.located option + type glob_level = level_info glob_sort_gen + + type sort_info = Names.Name.t Loc.located list + type glob_sort = sort_info glob_sort_gen + + type case_style = Term.case_style = + | LetStyle + | IfStyle + | LetPatternStyle + | MatchStyle + | RegularStyle (** infer printing form from number of constructor *) + + type 'a cast_type = + | CastConv of 'a + | CastVM of 'a + | CastCoerce + | CastNative of 'a + + type 'constr intro_pattern_expr = + | IntroForthcoming of bool + | IntroNaming of intro_pattern_naming_expr + | IntroAction of 'constr intro_pattern_action_expr + and intro_pattern_naming_expr = + | IntroIdentifier of Names.Id.t + | IntroFresh of Names.Id.t + | IntroAnonymous + and 'constr intro_pattern_action_expr = + | IntroWildcard + | IntroOrAndPattern of 'constr or_and_intro_pattern_expr + | IntroInjection of ('constr intro_pattern_expr) Loc.located list + | IntroApplyOn of 'constr Loc.located * 'constr intro_pattern_expr Loc.located + | IntroRewrite of bool + and 'constr or_and_intro_pattern_expr = + | IntroOrPattern of ('constr intro_pattern_expr) Loc.located list list + | IntroAndPattern of ('constr intro_pattern_expr) Loc.located list + + type quantified_hypothesis = + | AnonHyp of int + | NamedHyp of Names.Id.t + + type 'a explicit_bindings = (quantified_hypothesis * 'a) Loc.located list + + type 'a bindings = + | ImplicitBindings of 'a list + | ExplicitBindings of 'a explicit_bindings + | NoBindings + + type 'a with_bindings = 'a * 'a bindings + + type 'a core_destruction_arg = + | ElimOnConstr of 'a + | ElimOnIdent of Names.Id.t Loc.located + | ElimOnAnonHyp of int + + type inversion_kind = + | SimpleInversion + | FullInversion + | FullInversionClear + + type multi = + | Precisely of int + | UpTo of int + | RepeatStar + | RepeatPlus + type 'id move_location = + | MoveAfter of 'id + | MoveBefore of 'id + | MoveFirst + | MoveLast + + type 'a destruction_arg = clear_flag * 'a core_destruction_arg + end -module Mod_typing : +module Locus : sig - type 'alg translation = - Declarations.module_signature * 'alg * Mod_subst.delta_resolver * Univ.ContextSet.t - val translate_mse : - Environ.env -> Names.ModPath.t option -> Entries.inline -> Declarations.module_alg_expr -> - Declarations.module_alg_expr translation + type 'a occurrences_gen = + | AllOccurrences + | AllOccurrencesBut of 'a list (** non-empty *) + | NoOccurrences + | OnlyOccurrences of 'a list (** non-empty *) + type occurrences = int occurrences_gen + type occurrences_expr = (int Misctypes.or_var) occurrences_gen + type 'a with_occurrences = occurrences_expr * 'a + type hyp_location_flag = + InHyp | InHypTypeOnly | InHypValueOnly + type 'a hyp_location_expr = 'a with_occurrences * hyp_location_flag + type 'id clause_expr = + { onhyps : 'id hyp_location_expr list option; + concl_occs : occurrences_expr } + type clause = Names.Id.t clause_expr + type hyp_location = Names.Id.t * hyp_location_flag + type goal_location = hyp_location option end -module Esubst : +(************************************************************************) +(* End Modules from intf/ *) +(************************************************************************) + +(************************************************************************) +(* Modules from library/ *) +(************************************************************************) + +module Univops : sig - type 'a subs = 'a Esubst.subs - val subs_id : int -> 'a subs + val universes_of_constr : Term.constr -> Univ.universe_set + val restrict_universe_context : Univ.universe_context_set -> Univ.universe_set -> Univ.universe_context_set end -module CClosure : +module Nameops : sig - type fconstr = CClosure.fconstr - type clos_infos = CClosure.clos_infos - type table_key = Names.Constant.t Univ.puniverses Names.tableKey - type fterm = CClosure.fterm = - | FRel of int - | FAtom of Term.constr (** Metas and Sorts *) - | FCast of fconstr * Term.cast_kind * fconstr - | FFlex of table_key - | FInd of Names.inductive Univ.puniverses - | 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 * Term.constr * fconstr * Term.constr array * fconstr Esubst.subs (* predicate and branches are closures *) - | FLambda of int * (Names.Name.t * Term.constr) list * Term.constr * fconstr Esubst.subs - | FProd of Names.Name.t * fconstr * fconstr - | FLetIn of Names.Name.t * fconstr * fconstr * Term.constr * fconstr Esubst.subs - | FEvar of Term.existential * fconstr Esubst.subs - | FLIFT of int * fconstr - | FCLOS of Term.constr * fconstr Esubst.subs - | FLOCKED - module RedFlags : sig - type reds = CClosure.RedFlags.reds - type red_kind = CClosure.RedFlags.red_kind - val mkflags : red_kind list -> reds - val fBETA : red_kind - val fCOFIX : red_kind - val fCONST : Names.Constant.t -> CClosure.RedFlags.red_kind - val fFIX : red_kind - val fMATCH : red_kind - val fZETA : red_kind - val red_add_transparent : reds -> Names.transparent_state -> reds + val atompart_of_id : Names.Id.t -> string + + val pr_id : Names.Id.t -> Pp.t + [@@ocaml.deprecated "alias of API.Names.Id.print"] + + val pr_name : Names.Name.t -> Pp.t + [@@ocaml.deprecated "alias of API.Names.Name.print"] + + val name_fold : (Names.Id.t -> 'a -> 'a) -> Names.Name.t -> 'a -> 'a + val name_app : (Names.Id.t -> Names.Id.t) -> Names.Name.t -> Names.Name.t + val add_suffix : Names.Id.t -> string -> Names.Id.t + val increment_subscript : Names.Id.t -> Names.Id.t + val make_ident : string -> int option -> Names.Id.t + val out_name : Names.Name.t -> Names.Id.t + val pr_lab : Names.Label.t -> Pp.t + module Name : + sig + include module type of struct include Names.Name end + val get_id : t -> Names.Id.t + val fold_right : (Names.Id.t -> 'a -> 'a) -> t -> 'a -> 'a end - val mk_clos : fconstr Esubst.subs -> Term.constr -> fconstr - val mk_atom : Term.constr -> fconstr - val mk_clos_deep : - (fconstr Esubst.subs -> Term.constr -> fconstr) -> - fconstr Esubst.subs -> Term.constr -> fconstr - val mk_red : fterm -> fconstr - val all : RedFlags.reds - val beta : RedFlags.reds - val betaiota : RedFlags.reds - val betaiotazeta : RedFlags.reds +end + +module Libnames : +sig + + open Util + open Names + + type full_path + val pr_path : full_path -> Pp.t + val make_path : Names.DirPath.t -> Names.Id.t -> full_path + val eq_full_path : full_path -> full_path -> bool + val dirpath : full_path -> Names.DirPath.t + val path_of_string : string -> full_path + + type qualid + val make_qualid : Names.DirPath.t -> Names.Id.t -> qualid + val qualid_eq : qualid -> qualid -> bool + val repr_qualid : qualid -> Names.DirPath.t * Names.Id.t + val pr_qualid : qualid -> Pp.t + val string_of_qualid : qualid -> string + val qualid_of_string : string -> qualid + val qualid_of_path : full_path -> qualid + val qualid_of_dirpath : Names.DirPath.t -> qualid + val qualid_of_ident : Names.Id.t -> qualid - val create_clos_infos : ?evars:(Term.existential -> Term.constr option) -> RedFlags.reds -> Environ.env -> clos_infos + type reference = + | Qualid of qualid Loc.located + | Ident of Names.Id.t Loc.located + val loc_of_reference : reference -> Loc.t option + val qualid_of_reference : reference -> qualid Loc.located + val pr_reference : reference -> Pp.t - val whd_val : clos_infos -> fconstr -> Term.constr + val is_dirpath_prefix_of : Names.DirPath.t -> Names.DirPath.t -> bool + 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 - val inject : Term.constr -> fconstr + val string_of_path : full_path -> string + val basename : full_path -> Names.Id.t - val kl : clos_infos -> fconstr -> Term.constr - val term_of_fconstr : fconstr -> Term.constr + type object_name = full_path * Names.KerName.t + type object_prefix = Names.DirPath.t * (Names.ModPath.t * Names.DirPath.t) + + module Dirset : Set.S with type elt = DirPath.t + module Dirmap : Map.ExtS with type key = DirPath.t and module Set := Dirset + module Spmap : CSig.MapS with type key = full_path end -module Type_errors : +module Globnames : sig - type type_error = Type_errors.type_error - exception TypeError of Environ.env * type_error + + open Util + + type global_reference = + | VarRef of Names.Id.t + | ConstRef of Names.Constant.t + | IndRef of Names.inductive + | ConstructRef of Names.constructor + + type extended_global_reference = + | TrueGlobal of global_reference + | SynDef of Names.KerName.t + + (* Long term: change implementation so that only 1 kind of order is needed. + * Today: _env ones are fine grained, which one to pick depends. Eg. + * - conversion rule are implemented by the non_env ones + * - pretty printing (of user provided names/aliases) are implemented by + * the _env ones + *) + module Refset : CSig.SetS with type elt = global_reference + module Refmap : Map.ExtS + with type key = global_reference and module Set := Refset + + module Refset_env : CSig.SetS with type elt = global_reference + module Refmap_env : Map.ExtS + with type key = global_reference and module Set := Refset_env + + module RefOrdered : + sig + type t = global_reference + val compare : t -> t -> int + end + + val pop_global_reference : global_reference -> global_reference + val eq_gr : global_reference -> global_reference -> bool + val destIndRef : global_reference -> Names.inductive + + val encode_mind : Names.DirPath.t -> Names.Id.t -> Names.MutInd.t + val encode_con : Names.DirPath.t -> Names.Id.t -> Names.Constant.t + + val global_of_constr : Constr.t -> global_reference + + val subst_global : Mod_subst.substitution -> global_reference -> global_reference * Constr.t + val destConstructRef : global_reference -> Names.constructor + + val reference_of_constr : Constr.t -> global_reference + [@@ocaml.deprecated "alias of API.Globnames.global_of_constr"] + + val is_global : global_reference -> Constr.t -> bool end -module Evar : +module Libobject : sig - (** Unique identifier of some {i evar} *) - type t = Prelude.evar + type obj + type 'a substitutivity = + | Dispose + | Substitute of 'a + | Keep of 'a + | Anticipate of 'a - (** Recover the underlying integer. *) - val repr : t -> int + type 'a object_declaration = { + object_name : string; + cache_function : Libnames.object_name * 'a -> unit; + load_function : int -> Libnames.object_name * 'a -> unit; + open_function : int -> Libnames.object_name * 'a -> unit; + classify_function : 'a -> 'a substitutivity; + subst_function : Mod_subst.substitution * 'a -> 'a; + discharge_function : Libnames.object_name * 'a -> 'a option; + rebuild_function : 'a -> 'a + } + val declare_object : 'a object_declaration -> ('a -> obj) + val default_object : string -> 'a object_declaration + val object_tag : obj -> string +end - val equal : t -> t -> bool +module Summary : +sig - (** a set of unique identifiers of some {i evars} *) - module Set : module type of struct include Evar.Set end + type frozen + type marshallable + + type 'a summary_declaration = + { freeze_function : marshallable -> 'a; + unfreeze_function : 'a -> unit; + init_function : unit -> unit; } + + val ref : ?freeze:(marshallable -> 'a -> 'a) -> name:string -> 'a -> 'a ref + val declare_summary : string -> 'a summary_declaration -> unit + module Local : + sig + type 'a local_ref + val ref : ?freeze:('a -> 'a) -> name:string -> 'a -> 'a local_ref + val (:=) : 'a local_ref -> 'a -> unit + val (!) : 'a local_ref -> 'a + end +end + +module Nametab : +sig + exception GlobalizationError of Libnames.qualid + + type ltac_constant = Names.KerName.t + + val global : Libnames.reference -> Globnames.global_reference + val global_of_path : Libnames.full_path -> Globnames.global_reference + val shortest_qualid_of_global : Names.Id.Set.t -> Globnames.global_reference -> Libnames.qualid + val path_of_global : Globnames.global_reference -> Libnames.full_path + val locate_extended : Libnames.qualid -> Globnames.extended_global_reference + val full_name_module : Libnames.qualid -> Names.DirPath.t + val locate_tactic : Libnames.qualid -> Names.KerName.t + val pr_global_env : Names.Id.Set.t -> Globnames.global_reference -> Pp.t + val shortest_qualid_of_tactic : Names.KerName.t -> Libnames.qualid + val basename_of_global : Globnames.global_reference -> Names.Id.t + + type visibility = + | Until of int + | Exactly of int + + val push_tactic : visibility -> Libnames.full_path -> Names.KerName.t -> unit + val error_global_not_found : ?loc:Loc.t -> Libnames.qualid -> 'a + val shortest_qualid_of_module : Names.ModPath.t -> Libnames.qualid + val dirpath_of_module : Names.ModPath.t -> Names.DirPath.t + val locate_module : Libnames.qualid -> Names.ModPath.t + val dirpath_of_global : Globnames.global_reference -> Names.DirPath.t + val locate : Libnames.qualid -> Globnames.global_reference + val locate_constant : Libnames.qualid -> Names.Constant.t +end + +module Global : +sig + val env : unit -> Environ.env + val lookup_mind : Names.MutInd.t -> Declarations.mutual_inductive_body + val lookup_constant : Names.Constant.t -> Declarations.constant_body + val lookup_module : Names.ModPath.t -> Declarations.module_body + val lookup_modtype : Names.ModPath.t -> Declarations.module_type_body + val lookup_inductive : Names.inductive -> Declarations.mutual_inductive_body * Declarations.one_inductive_body + val constant_of_delta_kn : Names.KerName.t -> Names.Constant.t + val register : + Retroknowledge.field -> Constr.t -> Constr.t -> unit + val env_of_context : Environ.named_context_val -> Environ.env + val is_polymorphic : Globnames.global_reference -> bool + + val constr_of_global_in_context : Environ.env -> + Globnames.global_reference -> Constr.types * Univ.AUContext.t + + val type_of_global_in_context : Environ.env -> + Globnames.global_reference -> Constr.types * Univ.AUContext.t + + val current_dirpath : unit -> Names.DirPath.t + val body_of_constant_body : Declarations.constant_body -> (Constr.t * Univ.AUContext.t) option + val body_of_constant : Names.Constant.t -> (Constr.t * Univ.AUContext.t) option + val add_constraints : Univ.Constraint.t -> unit +end + +module Lib : sig + type is_type = bool + type export = bool option + type node = + | Leaf of Libobject.obj (* FIX: horrible hack (wrt. Enrico) *) + | CompilingLibrary of Libnames.object_prefix + | OpenedModule of is_type * export * Libnames.object_prefix * Summary.frozen + | ClosedModule of library_segment + | OpenedSection of Libnames.object_prefix * Summary.frozen + | ClosedSection of library_segment + + and library_segment = (Libnames.object_name * node) list + + val current_mp : unit -> Names.ModPath.t + val is_modtype : unit -> bool + val is_module : unit -> bool + val sections_are_opened : unit -> bool + val add_anonymous_leaf : ?cache_first:bool -> Libobject.obj -> unit + val contents : unit -> library_segment + val cwd : unit -> Names.DirPath.t + val add_leaf : Names.Id.t -> Libobject.obj -> Libnames.object_name + val make_kn : Names.Id.t -> Names.KerName.t + val make_path : Names.Id.t -> Libnames.full_path + val discharge_con : Names.Constant.t -> Names.Constant.t + val discharge_inductive : Names.inductive -> Names.inductive +end + +module Declaremods : +sig + + val append_end_library_hook : (unit -> unit) -> unit + +end + +module Library : +sig + val library_is_loaded : Names.DirPath.t -> bool + val loaded_libraries : unit -> Names.DirPath.t list +end + +module States : +sig + val with_state_protection_on_exception : ('a -> 'b) -> 'a -> 'b + val with_state_protection : ('a -> 'b) -> 'a -> 'b +end + +module Kindops : +sig + val logical_kind_of_goal_kind : Decl_kinds.goal_object_kind -> Decl_kinds.logical_kind +end + +module Goptions : +sig + type option_name = string list + type 'a option_sig = + { + optdepr : bool; + optname : string; + optkey : option_name; + optread : unit -> 'a; + optwrite : 'a -> unit + } + + type 'a write_function = 'a -> unit + + val declare_bool_option : ?preprocess:(bool -> bool) -> + bool option_sig -> bool write_function + val declare_int_option : ?preprocess:(int option -> int option) -> + int option option_sig -> int option write_function + val declare_string_option: ?preprocess:(string -> string) -> + string option_sig -> string write_function + val set_bool_option_value : option_name -> bool -> unit +end + +module Keys : +sig + type key + val constr_key : ('a -> ('a, 't, 'u, 'i) Constr.kind_of_term) -> 'a -> key option + val declare_equiv_keys : key -> key -> unit + val pr_keys : (Globnames.global_reference -> Pp.t) -> Pp.t +end + +module Coqlib : +sig + + type coq_eq_data = { eq : Globnames.global_reference; + ind : Globnames.global_reference; + refl : Globnames.global_reference; + sym : Globnames.global_reference; + trans: Globnames.global_reference; + congr: Globnames.global_reference; + } + + type coq_sigma_data = { + proj1 : Globnames.global_reference; + proj2 : Globnames.global_reference; + elim : Globnames.global_reference; + intro : Globnames.global_reference; + typ : Globnames.global_reference } + val gen_reference : string -> string list -> string -> Globnames.global_reference + val find_reference : string -> string list -> string -> Globnames.global_reference + val check_required_library : string list -> unit + val logic_module_name : string list + val glob_true : Globnames.global_reference + val glob_false : Globnames.global_reference + val glob_O : Globnames.global_reference + val glob_S : Globnames.global_reference + val nat_path : Libnames.full_path + val datatypes_module_name : string list + val glob_eq : Globnames.global_reference + val build_coq_eq_sym : Globnames.global_reference Util.delayed + val build_coq_False : Globnames.global_reference Util.delayed + val build_coq_not : Globnames.global_reference Util.delayed + val build_coq_eq : Globnames.global_reference Util.delayed + val build_coq_eq_data : coq_eq_data Util.delayed + val path_of_O : Names.constructor + val path_of_S : Names.constructor + val build_prod : coq_sigma_data Util.delayed + val build_coq_True : Globnames.global_reference Util.delayed + val coq_iff_ref : Globnames.global_reference lazy_t + val build_coq_iff_left_proj : Globnames.global_reference Util.delayed + val build_coq_iff_right_proj : Globnames.global_reference Util.delayed + val init_modules : string list list + val build_coq_eq_refl : Globnames.global_reference Util.delayed + val arith_modules : string list list + val zarith_base_modules : string list list + val gen_reference_in_modules : string -> string list list-> string -> Globnames.global_reference + val jmeq_module_name : string list + val coq_eq_ref : Globnames.global_reference lazy_t + val coq_not_ref : Globnames.global_reference lazy_t + val coq_or_ref : Globnames.global_reference lazy_t + val build_coq_and : Globnames.global_reference Util.delayed + val build_coq_I : Globnames.global_reference Util.delayed + val coq_reference : string -> string list -> string -> Globnames.global_reference +end + +(************************************************************************) +(* End of modules from library/ *) +(************************************************************************) + +(************************************************************************) +(* Modules from engine/ *) +(************************************************************************) + +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 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 + val pr_with_global_universes : Univ.Level.t -> Pp.t + val pr_universe_opt_subst : universe_opt_subst -> Pp.t + type universe_constraint + + module Constraints : + sig + type t + val pr : t -> Pp.t + end + + type universe_constraints = Constraints.t +end + +module UState : +sig + type t + val context : t -> Univ.UContext.t + val context_set : t -> Univ.ContextSet.t + val of_context_set : Univ.ContextSet.t -> t + + type rigid = + | UnivRigid + | UnivFlexible of bool + +end + +(* XXX: Moved from intf *) +module Evar_kinds : +sig + type obligation_definition_status = + | Define of bool + | Expand + + type matching_var_kind = + | FirstOrderPatVar of Names.Id.t + | SecondOrderPatVar of Names.Id.t + + type t = + | ImplicitArg of Globnames.global_reference * (int * Names.Id.t option) + * bool (** Force inference *) + | BinderType of Names.Name.t + | NamedHole of Names.Id.t (* coming from some ?[id] syntax *) + | QuestionMark of obligation_definition_status * Names.Name.t + | CasesType of bool (* true = a subterm of the type *) + | InternalHole + | TomatchTypeParameter of Names.inductive * int + | GoalEvar + | ImpossibleCase + | MatchingVar of matching_var_kind + | VarInstance of Names.Id.t + | SubEvar of Constr.existential_key end module Evd : sig + + type evar = Constr.existential_key + val string_of_existential : Evar.t -> string - type evar_constraint = Prelude.conv_pb * Environ.env * Term.constr * Term.constr + type evar_constraint = Reduction.conv_pb * Environ.env * Constr.t * Constr.t (* --------------------------------- *) @@ -1404,37 +2196,37 @@ sig module Store : sig - type t = Evd.Store.t + type t val empty : t end module Filter : sig - type t = Evd.Filter.t + type t val repr : t -> bool list option end (** This value defines the refinement of a given {i evar} *) - type evar_body = Evd.evar_body = + type evar_body = | Evar_empty (** given {i evar} was not yet refined *) - | Evar_defined of Term.constr (** given {i var} was refined to the indicated term *) + | Evar_defined of Constr.t (** given {i var} was refined to the indicated term *) (** all the information we have concerning some {i evar} *) - type evar_info = Evd.evar_info = + type evar_info = { - evar_concl : Term.constr; + evar_concl : Constr.t; evar_hyps : Environ.named_context_val; evar_body : evar_body; evar_filter : Filter.t; evar_source : Evar_kinds.t Loc.located; - evar_candidates : Term.constr list option; (* if not None, list of allowed instances *) + evar_candidates : Constr.t list option; (* if not None, list of allowed instances *) evar_extra : Store.t } - val evar_concl : evar_info -> Term.constr + val evar_concl : evar_info -> Constr.t val evar_body : evar_info -> evar_body val evar_context : evar_info -> Context.Named.t - val instantiate_evar_array : evar_info -> Term.constr -> Term.constr array -> Term.constr + val instantiate_evar_array : evar_info -> Constr.t -> Constr.t array -> Constr.t val evar_filtered_env : evar_info -> Environ.env val evar_hyps : evar_info -> Environ.named_context_val @@ -1442,39 +2234,50 @@ sig (* evar map *) - type evar_map = Prelude.evar_map - type open_constr = evar_map * Term.constr + type evar_map + type open_constr = evar_map * Constr.t - type rigid = Prelude.rigid = + open Util + + module Metaset : Set.S with type elt = Constr.metavariable + + type rigid = UState.rigid = | UnivRigid - | UnivFlexible of bool + | UnivFlexible of bool - - type 'a freelisted = 'a Evd.freelisted = { + type 'a freelisted = { rebus : 'a; - freemetas : Evd.Metaset.t + freemetas : Metaset.t } - type instance_status = Evd.instance_status - type clbinding = Evd.clbinding = - | Cltyp of Names.Name.t * Term.constr freelisted - | Clval of Names.Name.t * (Term.constr freelisted * instance_status) * Term.constr freelisted + + type instance_constraint = IsSuperType | IsSubType | Conv + + type instance_typing_status = + CoerceToType | TypeNotProcessed | TypeProcessed + + type instance_status = instance_constraint * instance_typing_status + + type clbinding = + | Cltyp of Names.Name.t * Constr.t freelisted + | Clval of Names.Name.t * (Constr.t freelisted * instance_status) * Constr.t freelisted + val empty : evar_map val from_env : Environ.env -> evar_map val find : evar_map -> Evar.t -> evar_info - val find_undefined : evar_map -> Prelude.evar -> evar_info + val find_undefined : evar_map -> evar -> evar_info val is_defined : evar_map -> Evar.t -> bool val mem : evar_map -> Evar.t -> bool val add : evar_map -> Evar.t -> evar_info -> evar_map val evar_universe_context : evar_map -> UState.t val set_universe_context : evar_map -> UState.t -> evar_map val universes : evar_map -> UGraph.t - val define : Evar.t -> Term.constr -> evar_map -> evar_map + val define : Evar.t -> Constr.t -> evar_map -> evar_map val fold : (Evar.t -> evar_info -> 'a -> 'a) -> evar_map -> 'a -> 'a val evar_key : Names.Id.t -> evar_map -> Evar.t val create_evar_defs : evar_map -> evar_map - val meta_declare : Prelude.metavariable -> Term.types -> ?name:Names.Name.t -> evar_map -> evar_map + val meta_declare : Constr.metavariable -> Term.types -> ?name:Names.Name.t -> evar_map -> evar_map val clear_metas : evar_map -> evar_map @@ -1483,24 +2286,24 @@ sig val remove : evar_map -> Evar.t -> evar_map val fresh_global : ?loc:Loc.t -> ?rigid:rigid -> ?names:Univ.Instance.t -> Environ.env -> - evar_map -> Prelude.global_reference -> evar_map * Term.constr + 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 fold_undefined : (Evar.t -> evar_info -> 'a -> 'a) -> evar_map -> 'a -> 'a val universe_context_set : evar_map -> Univ.ContextSet.t - val evar_ident : Prelude.evar -> evar_map -> Names.Id.t option + val evar_ident : evar -> evar_map -> Names.Id.t option val extract_all_conv_pbs : evar_map -> evar_map * evar_constraint list val universe_context : ?names:(Names.Id.t Loc.located) list -> evar_map -> (Names.Id.t * Univ.Level.t) list * Univ.UContext.t val nf_constraints : evar_map -> evar_map val from_ctx : UState.t -> evar_map - val meta_list : evar_map -> (Prelude.metavariable * clbinding) list + val meta_list : evar_map -> (Constr.metavariable * clbinding) list - val meta_defined : evar_map -> Prelude.metavariable -> bool + val meta_defined : evar_map -> Constr.metavariable -> bool - val meta_name : evar_map -> Prelude.metavariable -> Names.Name.t + val meta_name : evar_map -> Constr.metavariable -> Names.Name.t module MonadR : sig @@ -1510,7 +2313,7 @@ sig end end - type 'a sigma = 'a Evd.sigma = { + type 'a sigma = { it : 'a ; sigma : evar_map } @@ -1527,14 +2330,11 @@ sig val union_evar_universe_context : UState.t -> UState.t -> UState.t val merge_universe_context : evar_map -> UState.t -> evar_map - type unsolvability_explanation = Evd.unsolvability_explanation = - | SeveralInstancesFound of int - - module Metaset : module type of struct include Evd.Metaset end - with type elt = Prelude.metavariable + type unsolvability_explanation = + | SeveralInstancesFound of int (** Return {i ids} of all {i evars} that occur in a given term. *) - val evars_of_term : Term.constr -> Evar.Set.t + val evars_of_term : Constr.t -> Evar.Set.t val evar_universe_context_of : Univ.ContextSet.t -> UState.t [@@ocaml.deprecated "alias of API.UState.of_context_set"] @@ -1545,14 +2345,379 @@ sig type evar_universe_context = UState.t [@@ocaml.deprecated "alias of API.UState.t"] - val existential_opt_value : evar_map -> Term.existential -> Term.constr option - val existential_value : evar_map -> Term.existential -> Term.constr + val existential_opt_value : evar_map -> Term.existential -> Constr.t option + val existential_value : evar_map -> Term.existential -> Constr.t exception NotInstantiatedEvar val fresh_sort_in_family : ?loc:Loc.t -> ?rigid:rigid -> Environ.env -> evar_map -> Sorts.family -> evar_map * Sorts.t end +(* XXX: moved from intf *) +module Constrexpr : +sig + + type binder_kind = + | Default of Decl_kinds.binding_kind + | Generalized of Decl_kinds.binding_kind * Decl_kinds.binding_kind * bool + + type explicitation = + | ExplByPos of int * Names.Id.t option + | ExplByName of Names.Id.t + type sign = bool + type raw_natural_number = string + type prim_token = + | Numeral of raw_natural_number * sign + | String of string + + type notation = string + type instance_expr = Misctypes.glob_level list + type proj_flag = int option + type abstraction_kind = + | AbsLambda + | AbsPi + + type cases_pattern_expr_r = + | CPatAlias of cases_pattern_expr * Names.Id.t + | CPatCstr of Libnames.reference + * cases_pattern_expr list option * cases_pattern_expr list + (** [CPatCstr (_, c, Some l1, l2)] represents (@c l1) l2 *) + | CPatAtom of Libnames.reference option + | CPatOr of cases_pattern_expr list + | CPatNotation of notation * cases_pattern_notation_substitution + * cases_pattern_expr list + | CPatPrim of prim_token + | CPatRecord of (Libnames.reference * cases_pattern_expr) list + | CPatDelimiters of string * cases_pattern_expr + | CPatCast of cases_pattern_expr * constr_expr + and cases_pattern_expr = cases_pattern_expr_r CAst.t + + and cases_pattern_notation_substitution = + cases_pattern_expr list * cases_pattern_expr list list + + and constr_expr_r = + | CRef of Libnames.reference * instance_expr option + | CFix of Names.Id.t Loc.located * fix_expr list + | CCoFix of Names.Id.t Loc.located * cofix_expr list + | CProdN of binder_expr list * constr_expr + | CLambdaN of binder_expr list * constr_expr + | CLetIn of Names.Name.t Loc.located * constr_expr * constr_expr option * constr_expr + | CAppExpl of (proj_flag * Libnames.reference * instance_expr option) * constr_expr list + | 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 + * constr_expr option + * case_expr list + * branch_expr list + | CLetTuple of Names.Name.t Loc.located list * (Names.Name.t Loc.located option * constr_expr option) * + constr_expr * constr_expr + | CIf of constr_expr * (Names.Name.t Loc.located option * constr_expr option) + * constr_expr * constr_expr + | CHole of Evar_kinds.t option * Misctypes.intro_pattern_naming_expr * Genarg.raw_generic_argument option + | CPatVar of Names.Id.t + | CEvar of Names.Id.t * (Names.Id.t * constr_expr) list + | CSort of Misctypes.glob_sort + | CCast of constr_expr * constr_expr Misctypes.cast_type + | CNotation of notation * constr_notation_substitution + | CGeneralization of Decl_kinds.binding_kind * abstraction_kind option * constr_expr + | CPrim of prim_token + | CDelimiters of string * constr_expr + and constr_expr = constr_expr_r CAst.t + + and case_expr = constr_expr * Names.Name.t Loc.located option * cases_pattern_expr option + + and branch_expr = + (cases_pattern_expr list Loc.located list * constr_expr) Loc.located + + and binder_expr = + Names.Name.t Loc.located list * binder_kind * constr_expr + + and fix_expr = + Names.Id.t Loc.located * (Names.Id.t Loc.located option * recursion_order_expr) * + local_binder_expr list * constr_expr * constr_expr + + and cofix_expr = + Names.Id.t Loc.located * local_binder_expr list * constr_expr * constr_expr + + and recursion_order_expr = + | CStructRec + | CWfRec of constr_expr + | CMeasureRec of constr_expr * constr_expr option + + and local_binder_expr = + | CLocalAssum of Names.Name.t Loc.located list * binder_kind * constr_expr + | CLocalDef of Names.Name.t Loc.located * constr_expr * constr_expr option + | CLocalPattern of (cases_pattern_expr * constr_expr option) Loc.located + + and constr_notation_substitution = + constr_expr list * + constr_expr list list * + local_binder_expr list list + + type typeclass_constraint = (Names.Name.t Loc.located * Names.Id.t Loc.located list option) * Decl_kinds.binding_kind * constr_expr + type constr_pattern_expr = constr_expr +end + +module Genredexpr : +sig + + (** The parsing produces initially a list of [red_atom] *) + type 'a red_atom = + | FBeta + | FMatch + | FFix + | FCofix + | FZeta + | FConst of 'a list + | FDeltaBut of 'a list + + (** This list of atoms is immediately converted to a [glob_red_flag] *) + type 'a glob_red_flag = { + rBeta : bool; + rMatch : bool; + rFix : bool; + rCofix : bool; + rZeta : bool; + rDelta : bool; (** true = delta all but rConst; false = delta only on rConst*) + rConst : 'a list + } + + (** Generic kinds of reductions *) + type ('a,'b,'c) red_expr_gen = + | Red of bool + | Hnf + | Simpl of 'b glob_red_flag*('b,'c) Util.union Locus.with_occurrences option + | Cbv of 'b glob_red_flag + | Cbn of 'b glob_red_flag + | Lazy of 'b glob_red_flag + | Unfold of 'b Locus.with_occurrences list + | Fold of 'a list + | Pattern of 'a Locus.with_occurrences list + | ExtraRedExpr of string + | CbvVm of ('b,'c) Util.union Locus.with_occurrences option + | CbvNative of ('b,'c) Util.union Locus.with_occurrences option + + type ('a,'b,'c) may_eval = + | ConstrTerm of 'a + | ConstrEval of ('a,'b,'c) red_expr_gen * 'a + | ConstrContext of Names.Id.t Loc.located * 'a + | ConstrTypeOf of 'a + + type r_trm = Constrexpr.constr_expr + type r_pat = Constrexpr.constr_pattern_expr + type r_cst = Libnames.reference Misctypes.or_by_notation + type raw_red_expr = (r_trm, r_cst, r_pat) red_expr_gen +end + +(* XXX: end of moved from intf *) + +module EConstr : +sig + type t + type constr = t + type types = t + type unsafe_judgment = (constr, types) Environ.punsafe_judgment + type named_declaration = (constr, types) Context.Named.Declaration.pt + type named_context = (constr, types) Context.Named.pt + type rel_context = (constr, types) Context.Rel.pt + type rel_declaration = (constr, types) Context.Rel.Declaration.pt + type existential = constr Constr.pexistential + module ESorts : + sig + type t + (** Type of sorts up-to universe unification. Essentially a wrapper around + Sorts.t so that normalization is ensured statically. *) + + val make : Sorts.t -> t + (** Turn a sort into an up-to sort. *) + + val kind : Evd.evar_map -> t -> Sorts.t + (** Returns the view into the current sort. Note that the kind of a variable + may change if the unification state of the evar map changes. *) + + end + + module EInstance : + sig + type t + (** Type of universe instances up-to universe unification. Similar to + {ESorts.t} for {Univ.Instance.t}. *) + + val make : Univ.Instance.t -> t + val kind : Evd.evar_map -> t -> Univ.Instance.t + val empty : t + val is_empty : t -> bool + end + + val of_constr : Constr.t -> constr + + val kind : Evd.evar_map -> constr -> (constr, constr, ESorts.t, EInstance.t) Constr.kind_of_term + + val mkArrow : constr -> constr -> constr + val mkInd : Names.inductive -> t + val mkProp : constr + val mkProd : Names.Name.t * constr * constr -> constr + val mkRel : int -> constr + val mkSort : Sorts.t -> constr + val mkVar : Names.Id.t -> constr + val mkLambda : Names.Name.t * constr * constr -> constr + val mkLambda_or_LetIn : rel_declaration -> constr -> constr + val mkApp : constr * constr array -> constr + val mkEvar : constr Constr.pexistential -> constr + + val mkMeta : Constr.metavariable -> constr + + val mkConstructU : Names.constructor * EInstance.t -> constr + val mkLetIn : Names.Name.t * constr * constr * constr -> constr + val mkProd_or_LetIn : rel_declaration -> constr -> constr + val mkCast : constr * Constr.cast_kind * constr -> constr + val mkNamedLambda : Names.Id.t -> types -> constr -> constr + val mkNamedProd : Names.Id.t -> types -> types -> types + + val isCast : Evd.evar_map -> t -> bool + val isEvar : Evd.evar_map -> constr -> bool + val isInd : Evd.evar_map -> constr -> bool + val isRel : Evd.evar_map -> constr -> bool + val isSort : Evd.evar_map -> constr -> bool + val isVar : Evd.evar_map -> constr -> bool + val isConst : Evd.evar_map -> constr -> bool + val isConstruct : Evd.evar_map -> constr -> bool + + val destInd : Evd.evar_map -> constr -> Names.inductive * EInstance.t + val destVar : Evd.evar_map -> constr -> Names.Id.t + val destEvar : Evd.evar_map -> constr -> constr Constr.pexistential + val destRel : Evd.evar_map -> constr -> int + val destProd : Evd.evar_map -> constr -> Names.Name.t * types * types + val destLambda : Evd.evar_map -> constr -> Names.Name.t * types * constr + val destApp : Evd.evar_map -> constr -> constr * constr array + val destConst : Evd.evar_map -> constr -> Names.Constant.t * EInstance.t + val destConstruct : Evd.evar_map -> constr -> Names.constructor * EInstance.t + val destFix : Evd.evar_map -> t -> (t, t) Constr.pfixpoint + val destCast : Evd.evar_map -> t -> t * Constr.cast_kind * t + + val mkConstruct : Names.constructor -> constr + + val compose_lam : (Names.Name.t * constr) list -> constr -> constr + + val decompose_lam : Evd.evar_map -> constr -> (Names.Name.t * constr) list * constr + val decompose_lam_n_assum : Evd.evar_map -> int -> constr -> rel_context * constr + val decompose_app : Evd.evar_map -> constr -> constr * constr list + val decompose_prod : Evd.evar_map -> constr -> (Names.Name.t * constr) list * constr + val decompose_prod_assum : Evd.evar_map -> constr -> rel_context * constr + + val applist : constr * constr list -> constr + + val to_constr : Evd.evar_map -> constr -> Constr.t + + val push_rel : rel_declaration -> Environ.env -> Environ.env + + module Unsafe : + sig + val to_constr : constr -> Constr.t + + val to_rel_decl : (constr, types) Context.Rel.Declaration.pt -> (Constr.constr, Constr.types) Context.Rel.Declaration.pt + + (** Physical identity. Does not care for defined evars. *) + + val to_named_decl : (constr, types) Context.Named.Declaration.pt -> (Constr.constr, Constr.types) Context.Named.Declaration.pt + + val to_instance : EInstance.t -> Univ.Instance.t + end + + module Vars : + sig + val substnl : t list -> int -> t -> t + val noccurn : Evd.evar_map -> int -> constr -> bool + val closed0 : Evd.evar_map -> constr -> bool + val subst1 : constr -> constr -> constr + val substl : constr list -> constr -> constr + val lift : int -> constr -> constr + val liftn : int -> int -> t -> t + val subst_var : Names.Id.t -> t -> t + val subst_vars : Names.Id.t list -> t -> t + end + + val fresh_global : + ?loc:Loc.t -> ?rigid:UState.rigid -> ?names:Univ.Instance.t -> Environ.env -> + Evd.evar_map -> Globnames.global_reference -> Evd.evar_map * t + + val of_named_decl : (Constr.t, Constr.types) Context.Named.Declaration.pt -> (constr, types) Context.Named.Declaration.pt + val of_rel_decl : (Constr.t, Constr.types) Context.Rel.Declaration.pt -> (constr, types) Context.Rel.Declaration.pt + val kind_of_type : Evd.evar_map -> constr -> (constr, constr) Term.kind_of_type + val to_lambda : Evd.evar_map -> int -> constr -> constr + val it_mkLambda_or_LetIn : constr -> rel_context -> constr + val push_rel_context : rel_context -> Environ.env -> Environ.env + val eq_constr : Evd.evar_map -> constr -> constr -> bool + val iter_with_binders : Evd.evar_map -> ('a -> 'a) -> ('a -> constr -> unit) -> 'a -> constr -> unit + val fold : Evd.evar_map -> ('a -> constr -> 'a) -> 'a -> constr -> 'a + val existential_type : Evd.evar_map -> existential -> types + val iter : Evd.evar_map -> (constr -> unit) -> constr -> unit + val eq_constr_universes : Evd.evar_map -> constr -> constr -> Universes.universe_constraints option + val eq_constr_nounivs : Evd.evar_map -> constr -> constr -> bool + val compare_constr : Evd.evar_map -> (constr -> constr -> bool) -> constr -> constr -> bool + val isApp : Evd.evar_map -> constr -> bool + val it_mkProd_or_LetIn : constr -> rel_context -> constr + val push_named : named_declaration -> Environ.env -> Environ.env + val destCase : Evd.evar_map -> constr -> Constr.case_info * constr * constr * constr array + val decompose_lam_assum : Evd.evar_map -> constr -> rel_context * constr + val mkConst : Names.Constant.t -> constr + val mkCase : Constr.case_info * constr * constr * constr array -> constr + val named_context : Environ.env -> named_context + val val_of_named_context : named_context -> Environ.named_context_val + val mkFix : (t, t) Constr.pfixpoint -> t + val decompose_prod_n_assum : Evd.evar_map -> int -> t -> rel_context * t + val isMeta : Evd.evar_map -> t -> bool + + val destMeta : Evd.evar_map -> t -> Constr.metavariable + + val map_with_binders : Evd.evar_map -> ('a -> 'a) -> ('a -> t -> t) -> 'a -> t -> t + val mkNamedLetIn : Names.Id.t -> constr -> types -> constr -> constr + val map : Evd.evar_map -> (t -> t) -> t -> t + val mkConstU : Names.Constant.t * EInstance.t -> t + val isProd : Evd.evar_map -> t -> bool + val mkConstructUi : (Names.inductive * EInstance.t) * int -> t + val isLambda : Evd.evar_map -> t -> bool +end + +(* XXX: Located manually from intf *) +module Pattern : +sig + + type case_info_pattern = + { cip_style : Misctypes.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 _ => _ ? *) } + + type constr_pattern = + | PRef of Globnames.global_reference + | PVar of Names.Id.t + | PEvar of Evar.t * constr_pattern array + | PRel of int + | PApp of constr_pattern * constr_pattern array + | PSoApp of Names.Id.t * constr_pattern list + | PProj of Names.Projection.t * constr_pattern + | PLambda of Names.Name.t * constr_pattern * constr_pattern + | PProd of Names.Name.t * constr_pattern * constr_pattern + | PLetIn of Names.Name.t * constr_pattern * constr_pattern option * constr_pattern + | PSort of Misctypes.glob_sort + | PMeta of Names.Id.t option + | 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 + + type constr_under_binders = Names.Id.t list * EConstr.constr + + (** Types of substitutions with or w/o bound variables *) + + type patvar_map = EConstr.constr Names.Id.Map.t + type extended_patvar_map = constr_under_binders Names.Id.Map.t + +end + module Namegen : sig (** *) @@ -1584,78 +2749,168 @@ sig Evd.evar_map -> Names.Id.t list -> Names.Name.t list -> EConstr.types -> EConstr.types end -module Safe_typing : +module Termops : sig - type private_constants = Safe_typing.private_constants - val mk_pure_proof : Term.constr -> Safe_typing.private_constants Entries.proof_output + val it_mkLambda_or_LetIn : Constr.t -> Context.Rel.t -> Constr.t + val local_occur_var : Evd.evar_map -> Names.Id.t -> EConstr.constr -> bool + val occur_var : Environ.env -> Evd.evar_map -> Names.Id.t -> EConstr.constr -> bool + val pr_evar_info : Evd.evar_info -> Pp.t + + val print_constr : EConstr.constr -> Pp.t + + (** [dependent m t] tests whether [m] is a subterm of [t] *) + val dependent : Evd.evar_map -> EConstr.constr -> EConstr.constr -> bool + + (** [pop c] returns a copy of [c] with decremented De Bruijn indexes *) + val pop : EConstr.constr -> EConstr.constr + + (** Does a given term contain an existential variable? *) + val occur_existential : Evd.evar_map -> EConstr.constr -> bool + + (** [map_constr_with_binders_left_to_right g f acc c] maps [f updated_acc] on all the immediate subterms of [c]. + {ul {- if a given immediate subterm of [c] is not below a binder, then [updated_acc] is the same as [acc].} + {- if a given immediate subterm of [c] is below a binder [b], then [updated_acc] is computed as [g b acc].}} *) + 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. *) + 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]. + Casts are ignored. *) + val nb_lam : Evd.evar_map -> EConstr.constr -> int + + (** [push_rel_assum env_assumtion env] adds a given {i env assumption} to the {i env context} of a given {i environment}. *) + 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 + + type meta_value_map = (Constr.metavariable * Constr.t) list + + val last_arg : Evd.evar_map -> EConstr.constr -> EConstr.constr + val assums_of_rel_context : ('c, 't) Context.Rel.pt -> (Names.Name.t * 't) list + val prod_applist : Evd.evar_map -> EConstr.constr -> EConstr.constr list -> EConstr.constr + val nb_prod : Evd.evar_map -> EConstr.constr -> int + val is_section_variable : Names.Id.t -> bool + val ids_of_rel_context : ('c, 't) Context.Rel.pt -> Names.Id.t list + val subst_term : Evd.evar_map -> EConstr.constr -> EConstr.constr -> EConstr.constr + val global_vars_set_of_decl : Environ.env -> Evd.evar_map -> EConstr.named_declaration -> Names.Id.Set.t + val vars_of_env: Environ.env -> Names.Id.Set.t + val ids_of_named_context : ('c, 't) Context.Named.pt -> Names.Id.t list + val ids_of_context : Environ.env -> Names.Id.t list + val global_of_constr : Evd.evar_map -> EConstr.constr -> Globnames.global_reference * EConstr.EInstance.t + val print_named_context : Environ.env -> Pp.t + val print_constr_env : Environ.env -> Evd.evar_map -> EConstr.constr -> Pp.t + val clear_named_body : Names.Id.t -> Environ.env -> Environ.env + val is_Prop : Evd.evar_map -> EConstr.constr -> bool + val is_global : Evd.evar_map -> Globnames.global_reference -> EConstr.constr -> bool + + val eq_constr : Evd.evar_map -> EConstr.constr -> EConstr.constr -> bool + + val occur_var_in_decl : + Environ.env -> Evd.evar_map -> + Names.Id.t -> EConstr.named_declaration -> bool + + val subst_meta : meta_value_map -> Constr.t -> Constr.t + + val free_rels : Evd.evar_map -> EConstr.constr -> Int.Set.t + + val occur_term : Evd.evar_map -> EConstr.constr -> EConstr.constr -> bool + [@@ocaml.deprecated "alias of API.Termops.dependent"] + + val replace_term : Evd.evar_map -> EConstr.constr -> EConstr.constr -> EConstr.constr -> EConstr.constr + val map_named_decl : ('a -> 'b) -> ('a, 'a) Context.Named.Declaration.pt -> ('b, 'b) Context.Named.Declaration.pt + val map_rel_decl : ('a -> 'b) -> ('a, 'a) Context.Rel.Declaration.pt -> ('b, 'b) Context.Rel.Declaration.pt + val pr_metaset : Evd.Metaset.t -> Pp.t + val pr_evar_map : ?with_univs:bool -> int option -> Evd.evar_map -> Pp.t + val pr_evar_universe_context : UState.t -> Pp.t end module Proofview_monad : sig - type lazy_msg = unit -> Pp.std_ppcmds + type lazy_msg = unit -> Pp.t module Info : sig - type tree = Proofview_monad.Info.tree + type tree end end -(* All items in the Goal modules are deprecated. *) -module Goal : +module Evarutil : sig - type goal = Evar.t - - val pr_goal : goal -> Pp.std_ppcmds - - module V82 : - sig - val new_goal_with : Evd.evar_map -> goal -> Context.Named.t -> goal Evd.sigma + val e_new_global : Evd.evar_map ref -> Globnames.global_reference -> EConstr.constr - val nf_hyps : Evd.evar_map -> goal -> Environ.named_context_val + val nf_evars_and_universes : Evd.evar_map -> Evd.evar_map * (Constr.t -> Constr.t) + val nf_evar : Evd.evar_map -> EConstr.constr -> EConstr.constr + val nf_evar_info : Evd.evar_map -> Evd.evar_info -> Evd.evar_info - val env : Evd.evar_map -> goal -> Environ.env + val mk_new_meta : unit -> EConstr.constr - val concl : Evd.evar_map -> goal -> EConstr.constr + (** [new_meta] is a generator of unique meta variables *) + val new_meta : unit -> Constr.metavariable - val mk_goal : Evd.evar_map -> - Environ.named_context_val -> - EConstr.constr -> - Evd.Store.t -> - goal * EConstr.constr * Evd.evar_map + val new_Type : ?rigid:Evd.rigid -> Environ.env -> Evd.evar_map -> Evd.evar_map * EConstr.constr + val new_global : Evd.evar_map -> Globnames.global_reference -> Evd.evar_map * EConstr.constr - val extra : Evd.evar_map -> goal -> Evd.Store.t + val new_evar : + Environ.env -> Evd.evar_map -> ?src:Evar_kinds.t Loc.located -> ?filter:Evd.Filter.t -> + ?candidates:EConstr.constr list -> ?store:Evd.Store.t -> + ?naming:Misctypes.intro_pattern_naming_expr -> + ?principal:bool -> EConstr.types -> Evd.evar_map * EConstr.constr - val partial_solution_to : Evd.evar_map -> goal -> goal -> EConstr.constr -> Evd.evar_map + val new_evar_instance : + Environ.named_context_val -> Evd.evar_map -> EConstr.types -> + ?src:Evar_kinds.t Loc.located -> ?filter:Evd.Filter.t -> ?candidates:EConstr.constr list -> + ?store:Evd.Store.t -> ?naming:Misctypes.intro_pattern_naming_expr -> + ?principal:bool -> + EConstr.constr list -> Evd.evar_map * EConstr.constr - val partial_solution : Evd.evar_map -> goal -> EConstr.constr -> Evd.evar_map + val clear_hyps_in_evi : Environ.env -> Evd.evar_map ref -> Environ.named_context_val -> + EConstr.types -> Names.Id.Set.t -> Environ.named_context_val * EConstr.types - val hyps : Evd.evar_map -> goal -> Environ.named_context_val + type clear_dependency_error = + | OccurHypInSimpleClause of Names.Id.t option + | EvarTypingBreak of Constr.existential - val abstract_type : Evd.evar_map -> goal -> EConstr.types - end + exception ClearDependencyError of Names.Id.t * clear_dependency_error + val undefined_evars_of_term : Evd.evar_map -> EConstr.constr -> Evar.Set.t + val e_new_evar : + Environ.env -> Evd.evar_map ref -> ?src:Evar_kinds.t Loc.located -> ?filter:Evd.Filter.t -> + ?candidates:EConstr.constr list -> ?store:Evd.Store.t -> + ?naming:Misctypes.intro_pattern_naming_expr -> + ?principal:bool -> EConstr.types -> EConstr.constr + val new_type_evar : + Environ.env -> Evd.evar_map -> ?src:Evar_kinds.t Loc.located -> ?filter:Evd.Filter.t -> + ?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 evd_comb1 : (Evd.evar_map -> 'b -> Evd.evar_map * 'a) -> Evd.evar_map ref -> 'b -> 'a end module Proofview : sig - type proofview = Proofview.proofview - type entry = Proofview.entry - type +'a tactic = 'a Proofview.tactic - type telescope = Proofview.telescope = + type proofview + type entry + type +'a tactic + type telescope = | TNil of Evd.evar_map | TCons of Environ.env * Evd.evar_map * EConstr.types * (Evd.evar_map -> EConstr.constr -> telescope) + module NonLogical : sig - type +'a t = 'a Proofview.NonLogical.t + type +'a t val make : (unit -> 'a) -> 'a t val return : 'a -> 'a t val ( >> ) : unit t -> 'a t -> 'a t val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t val print_char : char -> unit t - val print_debug : Pp.std_ppcmds -> unit t - val print_warning : Pp.std_ppcmds -> unit t - val print_notice : Pp.std_ppcmds -> unit t - val print_info : Pp.std_ppcmds -> unit t + val print_debug : Pp.t -> unit t + val print_warning : Pp.t -> unit t + val print_notice : Pp.t -> unit t + val print_info : Pp.t -> unit t val run : 'a t -> 'a - type 'a ref = 'a Proofview.NonLogical.ref + type 'a ref val ref : 'a -> 'a ref t val ( := ) : 'a ref -> 'a -> unit t val ( ! ) : 'a ref -> 'a t @@ -1663,7 +2918,7 @@ sig val catch : 'a t -> (Exninfo.iexn -> 'a t) -> 'a t val read_line : string t end - val proofview : proofview -> Goal.goal list * Evd.evar_map + val proofview : proofview -> Evd.evar list * Evd.evar_map val cycle : int -> unit tactic val swap : int -> int -> unit tactic val revgoals : unit tactic @@ -1690,25 +2945,25 @@ sig val shelve_unifiable : unit tactic val apply : Environ.env -> 'a tactic -> proofview -> 'a * proofview - * (bool*Goal.goal list*Goal.goal list) + * (bool * Evd.evar list * Evd.evar list) * Proofview_monad.Info.tree val numgoals : int tactic - val with_shelf : 'a tactic -> (Goal.goal list * 'a) tactic + val with_shelf : 'a tactic -> (Evd.evar list * 'a) tactic module Unsafe : sig val tclEVARS : Evd.evar_map -> unit tactic - val tclGETGOALS : Goal.goal list tactic + val tclGETGOALS : Evd.evar list tactic - val tclSETGOALS : Goal.goal list -> unit tactic + val tclSETGOALS : Evd.evar list -> unit tactic - val tclNEWGOALS : Goal.goal list -> unit tactic + val tclNEWGOALS : Evd.evar list -> unit tactic end module Goal : sig - type 'a t = 'a Proofview.Goal.t + type 'a t val enter : ([ `LZ ] t -> unit tactic) -> unit tactic val hyps : 'a t -> EConstr.named_context val nf_enter : ([ `NF ] t -> unit tactic) -> unit tactic @@ -1749,7 +3004,7 @@ end module Ftactic : sig - type +'a focus = 'a Ftactic.focus + type +'a focus type +'a t = 'a focus Proofview.tactic val return : 'a -> 'a t val run : 'a t -> ('a -> unit Proofview.tactic) -> unit Proofview.tactic @@ -1771,67 +3026,19 @@ sig end end -module Evarutil : -sig - val e_new_global : Evd.evar_map ref -> Globnames.global_reference -> EConstr.constr - - val nf_evars_and_universes : Evd.evar_map -> Evd.evar_map * (Term.constr -> Term.constr) - val nf_evar : Evd.evar_map -> EConstr.constr -> EConstr.constr - val nf_evar_info : Evd.evar_map -> Evd.evar_info -> Evd.evar_info - - val mk_new_meta : unit -> EConstr.constr - - (** [new_meta] is a generator of unique meta variables *) - val new_meta : unit -> Prelude.metavariable - - val new_Type : ?rigid:Evd.rigid -> Environ.env -> Evd.evar_map -> Evd.evar_map * EConstr.constr - val new_global : Evd.evar_map -> Prelude.global_reference -> Evd.evar_map * EConstr.constr - - val new_evar : - Environ.env -> Evd.evar_map -> ?src:Evar_kinds.t Loc.located -> ?filter:Evd.Filter.t -> - ?candidates:EConstr.constr list -> ?store:Evd.Store.t -> - ?naming:Misctypes.intro_pattern_naming_expr -> - ?principal:bool -> EConstr.types -> Evd.evar_map * EConstr.constr - - val new_evar_instance : - Environ.named_context_val -> Evd.evar_map -> EConstr.types -> - ?src:Evar_kinds.t Loc.located -> ?filter:Evd.Filter.t -> ?candidates:EConstr.constr list -> - ?store:Evd.Store.t -> ?naming:Misctypes.intro_pattern_naming_expr -> - ?principal:bool -> - EConstr.constr list -> Evd.evar_map * EConstr.constr - - val clear_hyps_in_evi : Environ.env -> Evd.evar_map ref -> Environ.named_context_val -> - EConstr.types -> Names.Id.Set.t -> Environ.named_context_val * EConstr.types - - exception ClearDependencyError of Names.Id.t * Evarutil.clear_dependency_error - val undefined_evars_of_term : Evd.evar_map -> EConstr.constr -> Evar.Set.t - val e_new_evar : - Environ.env -> Evd.evar_map ref -> ?src:Evar_kinds.t Loc.located -> ?filter:Evd.Filter.t -> - ?candidates:EConstr.constr list -> ?store:Evd.Store.t -> - ?naming:Misctypes.intro_pattern_naming_expr -> - ?principal:bool -> EConstr.types -> EConstr.constr - val new_type_evar : - Environ.env -> Evd.evar_map -> ?src:Evar_kinds.t Loc.located -> ?filter:Evd.Filter.t -> - ?naming:Misctypes.intro_pattern_naming_expr -> ?principal:bool -> Evd.rigid -> - Evd.evar_map * (EConstr.constr * Sorts.t) - val nf_evars_universes : Evd.evar_map -> Term.constr -> Term.constr - val safe_evar_value : Evd.evar_map -> Term.existential -> Term.constr option - val evd_comb1 : (Evd.evar_map -> 'b -> Evd.evar_map * 'a) -> Evd.evar_map ref -> 'b -> 'a -end - module Geninterp : sig module Val : sig - type 'a typ = 'a Geninterp.Val.typ - type t = Geninterp.Val.t = Dyn : 'a typ * 'a -> t - type 'a tag = 'a Geninterp.Val.tag = + type 'a typ + type t = Dyn : 'a typ * 'a -> t + type 'a tag = | Base : 'a typ -> 'a tag | List : 'a tag -> 'a list tag | Opt : 'a tag -> 'a option tag | Pair : 'a tag * 'b tag -> ('a * 'b) tag val create : string -> 'a typ - val pr : 'a typ -> Pp.std_ppcmds + val pr : 'a typ -> Pp.t val eq : 'a typ -> 'b typ -> ('a, 'b) CSig.eq option val typ_list : t list typ val typ_opt : t option typ @@ -1841,8 +3048,8 @@ sig end module TacStore : sig - type t = Geninterp.TacStore.t - type 'a field = 'a Geninterp.TacStore.field + type t + type 'a field val empty : t val field : unit -> 'a field val get : t -> 'a field -> 'a option @@ -1850,9 +3057,10 @@ sig val remove : t -> 'a field -> t val merge : t -> t -> t end - type interp_sign = Geninterp.interp_sign = - {lfun : Val.t Names.Id.Map.t; - extra : TacStore.t } + type interp_sign = { + lfun : Val.t Names.Id.Map.t; + extra : TacStore.t + } type ('glb, 'top) interp_fun = interp_sign -> 'glb -> 'top Ftactic.t val register_interp0 : ('raw, 'glb, 'top) Genarg.genarg_type -> ('glb, Val.t) interp_fun -> unit @@ -1861,443 +3069,582 @@ sig val interp : ('raw, 'glb, 'top) Genarg.genarg_type -> ('glb, Val.t) interp_fun end -module Globnames : +(* XXX: Located manually from intf *) +module Glob_term : sig - type global_reference = Globnames.global_reference = - | VarRef of Names.Id.t - | ConstRef of Names.Constant.t - | IndRef of Names.inductive - | ConstructRef of Names.constructor + type cases_pattern_r = + | PatVar of Names.Name.t + | PatCstr of Names.constructor * cases_pattern list * Names.Name.t + and cases_pattern = cases_pattern_r CAst.t + type existential_name = Names.Id.t + type glob_constr_r = + | GRef of Globnames.global_reference * Misctypes.glob_level list option + (** An identifier that represents a reference to an object defined + either in the (global) environment or in the (local) context. *) + | GVar of Names.Id.t + (** An identifier that cannot be regarded as "GRef". + Bound variables are typically represented this way. *) + | GEvar of existential_name * (Names.Id.t * glob_constr) list + | GPatVar of Evar_kinds.matching_var_kind + | GApp of glob_constr * glob_constr list + | GLambda of Names.Name.t * Decl_kinds.binding_kind * glob_constr * glob_constr + | GProd of Names.Name.t * Decl_kinds.binding_kind * glob_constr * glob_constr + | GLetIn of Names.Name.t * glob_constr * glob_constr option * glob_constr + | GCases of Term.case_style * glob_constr option * tomatch_tuples * cases_clauses + | GLetTuple of Names.Name.t list * (Names.Name.t * glob_constr option) * glob_constr * glob_constr + | GIf of glob_constr * (Names.Name.t * glob_constr option) * glob_constr * glob_constr + | GRec of fix_kind * Names.Id.t array * glob_decl list array * + glob_constr array * glob_constr array + | GSort of Misctypes.glob_sort + | GHole of Evar_kinds.t * Misctypes.intro_pattern_naming_expr * Genarg.glob_generic_argument option + | GCast of glob_constr * glob_constr Misctypes.cast_type - type extended_global_reference = Globnames.extended_global_reference = - | TrueGlobal of global_reference - | SynDef of Names.KerName.t + and glob_constr = glob_constr_r CAst.t - (* Long term: change implementation so that only 1 kind of order is needed. - * Today: _env ones are fine grained, which one to pick depends. Eg. - * - conversion rule are implemented by the non_env ones - * - pretty printing (of user provided names/aliases) are implemented by - * the _env ones - *) - module Refset : module type of struct include Globnames.Refset end - module Refmap : module type of struct include Globnames.Refmap end - module Refset_env : module type of struct include Globnames.Refset_env end - module Refmap_env : module type of struct include Globnames.Refmap_env end - module RefOrdered : - sig - type t = global_reference - val compare : t -> t -> int - end + and glob_decl = Names.Name.t * Decl_kinds.binding_kind * glob_constr option * glob_constr - val pop_global_reference : global_reference -> global_reference - val eq_gr : global_reference -> global_reference -> bool - val destIndRef : global_reference -> Names.inductive + and fix_recursion_order = + | GStructRec + | GWfRec of glob_constr + | GMeasureRec of glob_constr * glob_constr option - val encode_mind : Names.DirPath.t -> Names.Id.t -> Names.MutInd.t - val encode_con : Names.DirPath.t -> Names.Id.t -> Names.Constant.t + and fix_kind = + | GFix of ((int option * fix_recursion_order) array * int) + | GCoFix of int - val global_of_constr : Term.constr -> global_reference + and predicate_pattern = + Names.Name.t * (Names.inductive * Names.Name.t list) Loc.located option - val subst_global : Mod_subst.substitution -> global_reference -> global_reference * Term.constr - val destConstructRef : Globnames.global_reference -> Names.constructor + and tomatch_tuple = (glob_constr * predicate_pattern) - val reference_of_constr : Term.constr -> global_reference - [@@ocaml.deprecated "alias of API.Globnames.global_of_constr"] + and tomatch_tuples = tomatch_tuple list + + and cases_clause = (Names.Id.t list * cases_pattern list * glob_constr) Loc.located + and cases_clauses = cases_clause list + + (** A globalised term together with a closure representing the value + of its free variables. Intended for use when these variables are taken + from the Ltac environment. *) + + type closure = { + idents : Names.Id.t Names.Id.Map.t; + typed : Pattern.constr_under_binders Names.Id.Map.t ; + untyped: closed_glob_constr Names.Id.Map.t } + and closed_glob_constr = { + closure: closure; + term: glob_constr } + + (** Ltac variable maps *) + type var_map = Pattern.constr_under_binders Names.Id.Map.t + type uconstr_var_map = closed_glob_constr Names.Id.Map.t + type unbound_ltac_var_map = Geninterp.Val.t Names.Id.Map.t + + type ltac_var_map = { + ltac_constrs : var_map; + (** Ltac variables bound to constrs *) + ltac_uconstrs : uconstr_var_map; + (** Ltac variables bound to untyped constrs *) + ltac_idents: Names.Id.t Names.Id.Map.t; + (** Ltac variables bound to identifiers *) + ltac_genargs : unbound_ltac_var_map; + (** Ltac variables bound to other kinds of arguments *) + } - val is_global : global_reference -> Term.constr -> bool end -module Evar_kinds : +module Notation_term : sig - type obligation_definition_status = Evar_kinds.obligation_definition_status = - | Define of bool - | Expand + type scope_name = string + type notation_var_instance_type = + | NtnTypeConstr | NtnTypeOnlyBinder | NtnTypeConstrList | NtnTypeBinderList + type tmp_scope_name = scope_name - type matching_var_kind = Evar_kinds.matching_var_kind = - | FirstOrderPatVar of Names.Id.t - | SecondOrderPatVar of Names.Id.t + type subscopes = tmp_scope_name option * scope_name list + type notation_constr = + | NRef of Globnames.global_reference + | NVar of Names.Id.t + | NApp of notation_constr * notation_constr list + | NHole of Evar_kinds.t * Misctypes.intro_pattern_naming_expr * Genarg.glob_generic_argument option + | NList of Names.Id.t * Names.Id.t * notation_constr * notation_constr * bool + | NLambda of Names.Name.t * notation_constr * notation_constr + | 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 * + (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) * + notation_constr * notation_constr + | NIf of notation_constr * (Names.Name.t * notation_constr option) * + notation_constr * notation_constr + | NRec of Glob_term.fix_kind * Names.Id.t array * + (Names.Name.t * notation_constr option * notation_constr) list array * + notation_constr array * notation_constr array + | NSort of Misctypes.glob_sort + | NCast of notation_constr * notation_constr Misctypes.cast_type + type interpretation = (Names.Id.t * (subscopes * notation_var_instance_type)) list * + notation_constr +end - type t = Evar_kinds.t = - | ImplicitArg of Globnames.global_reference * (int * Names.Id.t option) - * bool (** Force inference *) - | BinderType of Names.Name.t - | NamedHole of Names.Id.t (* coming from some ?[id] syntax *) - | QuestionMark of obligation_definition_status * Names.Name.t - | CasesType of bool (* true = a subterm of the type *) - | InternalHole - | TomatchTypeParameter of Names.inductive * int - | GoalEvar - | ImpossibleCase - | MatchingVar of matching_var_kind - | VarInstance of Names.Id.t - | SubEvar of Prelude.evar +module Tactypes : +sig + type glob_constr_and_expr = Glob_term.glob_constr * Constrexpr.constr_expr option + type glob_constr_pattern_and_expr = Names.Id.Set.t * glob_constr_and_expr * Pattern.constr_pattern + type 'a delayed_open = Environ.env -> Evd.evar_map -> Evd.evar_map * 'a + type delayed_open_constr = EConstr.constr delayed_open + type delayed_open_constr_with_bindings = EConstr.constr Misctypes.with_bindings delayed_open + type intro_pattern = delayed_open_constr Misctypes.intro_pattern_expr Loc.located + type intro_patterns = delayed_open_constr Misctypes.intro_pattern_expr Loc.located list + type intro_pattern_naming = Misctypes.intro_pattern_naming_expr Loc.located + type or_and_intro_pattern = delayed_open_constr Misctypes.or_and_intro_pattern_expr Loc.located end -module Decl_kinds : +(* XXX: end of moved from intf *) + +(************************************************************************) +(* End of modules from engine/ *) +(************************************************************************) + +(************************************************************************) +(* Modules from pretyping/ *) +(************************************************************************) + +module Locusops : sig - type polymorphic = bool - type cumulative_inductive_flag = bool - type recursivity_kind = Decl_kinds.recursivity_kind = - | Finite - | CoFinite - | BiFinite - type locality = Decl_kinds.locality = - | Discharge - | Local - | Global - type definition_object_kind = Decl_kinds.definition_object_kind = - | Definition - | Coercion - | SubClass - | CanonicalStructure - | Example - | Fixpoint - | CoFixpoint - | Scheme - | StructureComponent - | IdentityCoercion - | Instance - | Method - type theorem_kind = Decl_kinds.theorem_kind = - | Theorem - | Lemma - | Fact - | Remark - | Property - | Proposition - | Corollary - type goal_object_kind = Decl_kinds.goal_object_kind = - | DefinitionBody of definition_object_kind - | Proof of theorem_kind - type goal_kind = locality * polymorphic * goal_object_kind - type assumption_object_kind = Decl_kinds.assumption_object_kind = - | Definitional - | Logical - | Conjectural - type logical_kind = Decl_kinds.logical_kind = - | IsAssumption of assumption_object_kind - | IsDefinition of definition_object_kind - | IsProof of theorem_kind - type binding_kind = Decl_kinds.binding_kind = - | Explicit - | Implicit - type private_flag = bool - type definition_kind = locality * polymorphic * definition_object_kind + val clause_with_generic_occurrences : 'a Locus.clause_expr -> bool + val nowhere : 'a Locus.clause_expr + val allHypsAndConcl : 'a Locus.clause_expr + val is_nowhere : 'a Locus.clause_expr -> bool + val occurrences_map : + ('a list -> 'b list) -> 'a Locus.occurrences_gen -> 'b Locus.occurrences_gen + val convert_occs : Locus.occurrences -> bool * int list + val onConcl : 'a Locus.clause_expr + val onHyp : 'a -> 'a Locus.clause_expr end -module Misctypes : +module Pretype_errors : sig - type evars_flag = bool - type clear_flag = bool option - type advanced_flag = bool - type rec_flag = bool + type unification_error + type subterm_unification_error + + type type_error = (EConstr.t, EConstr.types) Type_errors.ptype_error + + type pretype_error = + | CantFindCaseType of EConstr.constr + | ActualTypeNotCoercible of EConstr.unsafe_judgment * EConstr.types * unification_error + | UnifOccurCheck of Evar.t * EConstr.constr + | UnsolvableImplicit of Evar.t * Evd.unsolvability_explanation option + | CannotUnify of EConstr.constr * EConstr.constr * unification_error option + | CannotUnifyLocal of EConstr.constr * EConstr.constr * EConstr.constr + | CannotUnifyBindingType of EConstr.constr * EConstr.constr + | CannotGeneralize of EConstr.constr + | NoOccurrenceFound of EConstr.constr * Names.Id.t option + | CannotFindWellTypedAbstraction of EConstr.constr * EConstr.constr list * (Environ.env * type_error) option + | WrongAbstractionType of Names.Name.t * EConstr.constr * EConstr.types * EConstr.types + | AbstractionOverMeta of Names.Name.t * Names.Name.t + | NonLinearUnification of Names.Name.t * EConstr.constr + | VarNotFound of Names.Id.t + | UnexpectedType of EConstr.constr * EConstr.constr + | NotProduct of EConstr.constr + | TypingError of type_error + | CannotUnifyOccurrences of subterm_unification_error + | UnsatisfiableConstraints of + (Evar.t * Evar_kinds.t) option * Evar.Set.t option - type 'a or_by_notation = 'a Misctypes.or_by_notation = - | AN of 'a - | ByNotation of (string * string option) Loc.located - type 'a or_var = 'a Misctypes.or_var = - | ArgArg of 'a - | ArgVar of Names.Id.t Loc.located - type 'a and_short_name = 'a * Names.Id.t Loc.located option - type glob_level = Misctypes.glob_level - type 'a glob_sort_gen = 'a Misctypes.glob_sort_gen = - | GProp - | GSet - | GType of 'a - type sort_info = Names.Name.t Loc.located list - type glob_sort = sort_info glob_sort_gen - type 'a cast_type = 'a Misctypes.cast_type = - | CastConv of 'a - | CastVM of 'a - | CastCoerce - | CastNative of 'a - type 'constr intro_pattern_expr = 'constr Misctypes.intro_pattern_expr = - | IntroForthcoming of bool - | IntroNaming of intro_pattern_naming_expr - | IntroAction of 'constr intro_pattern_action_expr - and intro_pattern_naming_expr = Misctypes.intro_pattern_naming_expr = - | IntroIdentifier of Names.Id.t - | IntroFresh of Names.Id.t - | IntroAnonymous - and 'constr intro_pattern_action_expr = 'constr Misctypes.intro_pattern_action_expr = - | IntroWildcard - | IntroOrAndPattern of 'constr or_and_intro_pattern_expr - | IntroInjection of ('constr intro_pattern_expr) Loc.located list - | IntroApplyOn of 'constr Loc.located * 'constr intro_pattern_expr Loc.located - | IntroRewrite of bool - and 'constr or_and_intro_pattern_expr = 'constr Misctypes.or_and_intro_pattern_expr = - | IntroOrPattern of ('constr intro_pattern_expr) Loc.located list list - | IntroAndPattern of ('constr intro_pattern_expr) Loc.located list - type quantified_hypothesis = Misctypes.quantified_hypothesis = - | AnonHyp of int - | NamedHyp of Names.Id.t - type 'a explicit_bindings = (quantified_hypothesis * 'a) Loc.located list - type 'a bindings = 'a Misctypes.bindings = - | ImplicitBindings of 'a list - | ExplicitBindings of 'a explicit_bindings - | NoBindings - type 'a with_bindings = 'a * 'a bindings - type 'a core_destruction_arg = 'a Misctypes.core_destruction_arg = - | ElimOnConstr of 'a - | ElimOnIdent of Names.Id.t Loc.located - | ElimOnAnonHyp of int - type inversion_kind = Misctypes.inversion_kind = - | SimpleInversion - | FullInversion - | FullInversionClear - type multi = Misctypes.multi = - | Precisely of int - | UpTo of int - | RepeatStar - | RepeatPlus - type 'id move_location = 'id Misctypes.move_location = - | MoveAfter of 'id - | MoveBefore of 'id - | MoveFirst - | MoveLast - type 'a destruction_arg = clear_flag * 'a core_destruction_arg + exception PretypeError of Environ.env * Evd.evar_map * pretype_error + val error_var_not_found : ?loc:Loc.t -> Names.Id.t -> 'b + val precatchable_exception : exn -> bool end -module Pattern : +module Reductionops : sig - type case_info_pattern = Pattern.case_info_pattern - type constr_pattern = Pattern.constr_pattern = - | PRef of Globnames.global_reference - | PVar of Names.Id.t - | PEvar of Evar.t * constr_pattern array - | PRel of int - | PApp of constr_pattern * constr_pattern array - | PSoApp of Names.Id.t * constr_pattern list - | PProj of Names.Projection.t * constr_pattern - | PLambda of Names.Name.t * constr_pattern * constr_pattern - | PProd of Names.Name.t * constr_pattern * constr_pattern - | PLetIn of Names.Name.t * constr_pattern * constr_pattern option * constr_pattern - | PSort of Misctypes.glob_sort - | PMeta of Names.Id.t option - | 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 - type constr_under_binders = Names.Id.t list * EConstr.constr - type extended_patvar_map = constr_under_binders Names.Id.Map.t - type patvar_map = EConstr.constr Names.Id.Map.t + type local_reduction_function = Evd.evar_map -> EConstr.constr -> EConstr.constr + + type reduction_function = Environ.env -> Evd.evar_map -> EConstr.constr -> EConstr.constr + + type local_stack_reduction_function = + Evd.evar_map -> EConstr.constr -> EConstr.constr * EConstr.constr list + + type e_reduction_function = Environ.env -> Evd.evar_map -> EConstr.constr -> Evd.evar_map * EConstr.constr + type state + + val clos_whd_flags : CClosure.RedFlags.reds -> reduction_function + val nf_beta : local_reduction_function + val nf_betaiota : local_reduction_function + val splay_prod : Environ.env -> Evd.evar_map -> EConstr.constr -> + (Names.Name.t * EConstr.constr) list * EConstr.constr + val splay_prod_n : Environ.env -> Evd.evar_map -> int -> EConstr.constr -> EConstr.rel_context * EConstr.constr + val whd_all : reduction_function + val whd_beta : local_reduction_function + + val whd_betaiotazeta : local_reduction_function + + val whd_betaiota_stack : local_stack_reduction_function + + val clos_norm_flags : CClosure.RedFlags.reds -> reduction_function + val is_conv : ?reds:Names.transparent_state -> Environ.env -> Evd.evar_map -> EConstr.constr -> EConstr.constr -> bool + val beta_applist : Evd.evar_map -> EConstr.constr * EConstr.constr list -> EConstr.constr + val sort_of_arity : Environ.env -> Evd.evar_map -> EConstr.constr -> EConstr.ESorts.t + val is_conv_leq : ?reds:Names.transparent_state -> Environ.env -> Evd.evar_map -> EConstr.constr -> EConstr.constr -> bool + val whd_betaiota : local_reduction_function + val is_arity : Environ.env -> Evd.evar_map -> EConstr.constr -> bool + val nf_evar : Evd.evar_map -> EConstr.constr -> EConstr.constr + val nf_meta : Evd.evar_map -> EConstr.constr -> EConstr.constr + val hnf_prod_appvect : Environ.env -> Evd.evar_map -> EConstr.constr -> EConstr.constr array -> EConstr.constr + val pr_state : state -> Pp.t + module Stack : + sig + type 'a t + val pr : ('a -> Pp.t) -> 'a t -> Pp.t + end + module Cst_stack : + sig + type t + val pr : t -> Pp.t + end end -module Constrexpr : +module Inductiveops : sig - type binder_kind = Constrexpr.binder_kind = - | Default of Decl_kinds.binding_kind - | Generalized of Decl_kinds.binding_kind * Decl_kinds.binding_kind * bool - type explicitation = Constrexpr.explicitation = - | ExplByPos of int * Names.Id.t option - | ExplByName of Names.Id.t - type sign = bool - type raw_natural_number = string - type prim_token = Constrexpr.prim_token = - | Numeral of raw_natural_number * sign - | String of string - type notation = string - type instance_expr = Misctypes.glob_level list - type proj_flag = int option - type abstraction_kind = Constrexpr.abstraction_kind = - | AbsLambda - | AbsPi - type cases_pattern_expr_r = Constrexpr.cases_pattern_expr_r = - | CPatAlias of cases_pattern_expr * Names.Id.t - | CPatCstr of Prelude.reference - * cases_pattern_expr list option * cases_pattern_expr list - (** [CPatCstr (_, c, Some l1, l2)] represents (@c l1) l2 *) - | CPatAtom of Prelude.reference option - | CPatOr of cases_pattern_expr list - | CPatNotation of notation * cases_pattern_notation_substitution - * cases_pattern_expr list - | CPatPrim of prim_token - | CPatRecord of (Prelude.reference * cases_pattern_expr) list - | CPatDelimiters of string * cases_pattern_expr - | CPatCast of cases_pattern_expr * constr_expr - and cases_pattern_expr = cases_pattern_expr_r CAst.t + type inductive_family + type inductive_type = + | IndType of inductive_family * EConstr.constr list + type constructor_summary = + { + cs_cstr : Term.pconstructor; + cs_params : Constr.t list; + cs_nargs : int; + cs_args : Context.Rel.t; + cs_concl_realargs : Constr.t array; + } - and cases_pattern_notation_substitution = - cases_pattern_expr list * cases_pattern_expr list list + val arities_of_constructors : Environ.env -> Term.pinductive -> Term.types array + val constructors_nrealargs_env : Environ.env -> Names.inductive -> int array + val constructor_nallargs_env : Environ.env -> Names.constructor -> int - and constr_expr_r = Constrexpr.constr_expr_r = - | CRef of Prelude.reference * instance_expr option - | CFix of Names.Id.t Loc.located * fix_expr list - | CCoFix of Names.Id.t Loc.located * cofix_expr list - | CProdN of binder_expr list * constr_expr - | CLambdaN of binder_expr list * constr_expr - | CLetIn of Names.Name.t Loc.located * constr_expr * constr_expr option * constr_expr - | CAppExpl of (proj_flag * Prelude.reference * instance_expr option) * constr_expr list - | CApp of (proj_flag * constr_expr) * - (constr_expr * explicitation Loc.located option) list - | CRecord of (Prelude.reference * constr_expr) list - | CCases of Term.case_style - * constr_expr option - * case_expr list - * branch_expr list - | CLetTuple of Names.Name.t Loc.located list * (Names.Name.t Loc.located option * constr_expr option) * - constr_expr * constr_expr - | CIf of constr_expr * (Names.Name.t Loc.located option * constr_expr option) - * constr_expr * constr_expr - | CHole of Evar_kinds.t option * Misctypes.intro_pattern_naming_expr * Genarg.raw_generic_argument option - | CPatVar of Names.Id.t - | CEvar of Glob_term.existential_name * (Names.Id.t * constr_expr) list - | CSort of Misctypes.glob_sort - | CCast of constr_expr * constr_expr Misctypes.cast_type - | CNotation of notation * constr_notation_substitution - | CGeneralization of Decl_kinds.binding_kind * abstraction_kind option * constr_expr - | CPrim of prim_token - | CDelimiters of string * constr_expr - and constr_expr = constr_expr_r CAst.t + val inductive_nparams : Names.inductive -> int - and case_expr = constr_expr * Names.Name.t Loc.located option * cases_pattern_expr option + val inductive_nparamdecls : Names.inductive -> int - and branch_expr = - (cases_pattern_expr list Loc.located list * constr_expr) Loc.located + val type_of_constructors : Environ.env -> Term.pinductive -> Term.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 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 +end - and binder_expr = - Names.Name.t Loc.located list * binder_kind * constr_expr +module Impargs : +sig + type implicit_status + type implicit_side_condition + type implicits_list = implicit_side_condition * implicit_status list + type manual_explicitation = Constrexpr.explicitation * (bool * bool * bool) + type manual_implicits = manual_explicitation list + val is_status_implicit : implicit_status -> bool + val name_of_implicit : implicit_status -> Names.Id.t + val implicits_of_global : Globnames.global_reference -> implicits_list list + val declare_manual_implicits : bool -> Globnames.global_reference -> ?enriching:bool -> + manual_implicits list -> unit + val is_implicit_args : unit -> bool + val is_strict_implicit_args : unit -> bool + val is_contextual_implicit_args : unit -> bool + val make_implicit_args : bool -> unit + val make_strict_implicit_args : bool -> unit + val make_contextual_implicit_args : bool -> unit +end - and fix_expr = - Names.Id.t Loc.located * (Names.Id.t Loc.located option * recursion_order_expr) * - local_binder_expr list * constr_expr * constr_expr +module Retyping : (* reconstruct the type of a term knowing that it was already typechecked *) +sig + val get_type_of : ?polyprop:bool -> ?lax:bool -> Environ.env -> Evd.evar_map -> EConstr.constr -> EConstr.types + val get_sort_family_of : ?polyprop:bool -> Environ.env -> Evd.evar_map -> EConstr.types -> Sorts.family + val expand_projection : Environ.env -> Evd.evar_map -> Names.Projection.t -> EConstr.constr -> EConstr.constr list -> EConstr.constr + val get_sort_of : + ?polyprop:bool -> Environ.env -> Evd.evar_map -> EConstr.types -> Sorts.t +end - and cofix_expr = - Names.Id.t Loc.located * local_binder_expr list * constr_expr * constr_expr +module Find_subterm : +sig + val error_invalid_occurrence : int list -> 'a +end - and recursion_order_expr = Constrexpr.recursion_order_expr = - | CStructRec - | CWfRec of constr_expr - | CMeasureRec of constr_expr * constr_expr option +module Evarsolve : +sig + val refresh_universes : + ?status:Evd.rigid -> ?onlyalg:bool -> ?refreshset:bool -> bool option -> + Environ.env -> Evd.evar_map -> EConstr.types -> Evd.evar_map * EConstr.types +end - and local_binder_expr = Constrexpr.local_binder_expr = - | CLocalAssum of Names.Name.t Loc.located list * binder_kind * constr_expr - | CLocalDef of Names.Name.t Loc.located * constr_expr * constr_expr option - | CLocalPattern of (cases_pattern_expr * constr_expr option) Loc.located +module Recordops : +sig - and constr_notation_substitution = - constr_expr list * - constr_expr list list * - local_binder_expr list list + type cs_pattern = + | Const_cs of Globnames.global_reference + | Prod_cs + | Sort_cs of Sorts.family + | Default_cs - type typeclass_constraint = (Names.Name.t Loc.located * Names.Id.t Loc.located list option) * Decl_kinds.binding_kind * constr_expr - type constr_pattern_expr = constr_expr + type obj_typ = { + o_DEF : Constr.t; + o_CTX : Univ.AUContext.t; + o_INJ : int option; (** position of trivial argument *) + o_TABS : Constr.t list; (** ordered *) + o_TPARAMS : Constr.t list; (** ordered *) + o_NPARAMS : int; + o_TCOMPS : Constr.t list } + + val lookup_projections : Names.inductive -> Names.Constant.t option list + val lookup_canonical_conversion : (Globnames.global_reference * cs_pattern) -> Constr.t * obj_typ + val find_projection_nparams : Globnames.global_reference -> int end -module Goptions : +module Evarconv : sig - type option_name = string list - type 'a option_sig = 'a Goptions.option_sig = - { - optdepr : bool; - optname : string; - optkey : option_name; - optread : unit -> 'a; - optwrite : 'a -> unit - } - type 'a write_function = 'a Goptions.write_function - val declare_bool_option : ?preprocess:(bool -> bool) -> - bool option_sig -> bool write_function - val declare_int_option : ?preprocess:(int option -> int option) -> - int option option_sig -> int option write_function - val declare_string_option: ?preprocess:(string -> string) -> - string option_sig -> string write_function - val set_bool_option_value : option_name -> bool -> unit + val e_conv : Environ.env -> ?ts:Names.transparent_state -> Evd.evar_map ref -> EConstr.constr -> EConstr.constr -> bool + val the_conv_x : Environ.env -> ?ts:Names.transparent_state -> EConstr.constr -> EConstr.constr -> Evd.evar_map -> Evd.evar_map + val the_conv_x_leq : Environ.env -> ?ts:Names.transparent_state -> EConstr.constr -> EConstr.constr -> Evd.evar_map -> Evd.evar_map + val solve_unif_constraints_with_heuristics : Environ.env -> ?ts:Names.transparent_state -> Evd.evar_map -> Evd.evar_map end -module Locus : +module Typing : sig - type 'a occurrences_gen = 'a Locus.occurrences_gen = - | AllOccurrences - | AllOccurrencesBut of 'a list (** non-empty *) - | NoOccurrences - | OnlyOccurrences of 'a list (** non-empty *) - type occurrences = int occurrences_gen - type occurrences_expr = (int Misctypes.or_var) occurrences_gen - type 'a with_occurrences = occurrences_expr * 'a - type hyp_location_flag = Locus.hyp_location_flag = - InHyp | InHypTypeOnly | InHypValueOnly - type 'a hyp_location_expr = 'a with_occurrences * hyp_location_flag - type 'id clause_expr = 'id Locus.clause_expr = - { onhyps : 'id hyp_location_expr list option; - concl_occs : occurrences_expr } - type clause = Names.Id.t clause_expr - type hyp_location = Names.Id.t * hyp_location_flag - type goal_location = hyp_location option + val e_sort_of : Environ.env -> Evd.evar_map ref -> EConstr.types -> Sorts.t + + val type_of : ?refresh:bool -> Environ.env -> Evd.evar_map -> EConstr.constr -> Evd.evar_map * EConstr.types + val e_solve_evars : Environ.env -> Evd.evar_map ref -> EConstr.constr -> EConstr.constr + + val unsafe_type_of : Environ.env -> Evd.evar_map -> EConstr.constr -> EConstr.types + + val e_check : Environ.env -> Evd.evar_map ref -> EConstr.constr -> EConstr.types -> unit + + val e_type_of : ?refresh:bool -> Environ.env -> Evd.evar_map ref -> EConstr.constr -> EConstr.types end -module Genredexpr : +module Miscops : sig + val map_red_expr_gen : ('a -> 'd) -> ('b -> 'e) -> ('c -> 'f) -> + ('a,'b,'c) Genredexpr.red_expr_gen -> ('d,'e,'f) Genredexpr.red_expr_gen + val map_cast_type : ('a -> 'b) -> 'a Misctypes.cast_type -> 'b Misctypes.cast_type +end - (** The parsing produces initially a list of [red_atom] *) +module Glob_ops : +sig + val map_glob_constr_left_to_right : (Glob_term.glob_constr -> Glob_term.glob_constr) -> Glob_term.glob_constr -> Glob_term.glob_constr + val loc_of_glob_constr : Glob_term.glob_constr -> Loc.t option + val glob_constr_eq : Glob_term.glob_constr -> Glob_term.glob_constr -> bool + val bound_glob_vars : Glob_term.glob_constr -> Names.Id.Set.t - type 'a red_atom = 'a Genredexpr.red_atom = - | FBeta - | FMatch - | FFix - | FCofix - | FZeta - | FConst of 'a list - | FDeltaBut of 'a list + (** Conversion from glob_constr to cases pattern, if possible - (** This list of atoms is immediately converted to a [glob_red_flag] *) + Take the current alias as parameter, + @raise Not_found if translation is impossible *) + val cases_pattern_of_glob_constr : Names.Name.t -> Glob_term.glob_constr -> Glob_term.cases_pattern + val map_glob_constr : + (Glob_term.glob_constr -> Glob_term.glob_constr) -> Glob_term.glob_constr -> Glob_term.glob_constr - type 'a glob_red_flag = 'a Genredexpr.glob_red_flag = { - rBeta : bool; - rMatch : bool; - rFix : bool; - rCofix : bool; - rZeta : bool; - rDelta : bool; (** true = delta all but rConst; false = delta only on rConst*) - rConst : 'a list - } + val empty_lvar : Glob_term.ltac_var_map - (** Generic kinds of reductions *) +end - type ('a,'b,'c) red_expr_gen = ('a,'b,'c) Genredexpr.red_expr_gen = - | Red of bool - | Hnf - | Simpl of 'b glob_red_flag*('b,'c) Util.union Locus.with_occurrences option - | Cbv of 'b glob_red_flag - | Cbn of 'b glob_red_flag - | Lazy of 'b glob_red_flag - | Unfold of 'b Locus.with_occurrences list - | Fold of 'a list - | Pattern of 'a Locus.with_occurrences list - | ExtraRedExpr of string - | CbvVm of ('b,'c) Util.union Locus.with_occurrences option - | CbvNative of ('b,'c) Util.union Locus.with_occurrences option +module Redops : +sig + val all_flags : 'a Genredexpr.glob_red_flag + val make_red_flag : 'a Genredexpr.red_atom list -> 'a Genredexpr.glob_red_flag +end - type ('a,'b,'c) may_eval = ('a,'b,'c) Genredexpr.may_eval = - | ConstrTerm of 'a - | ConstrEval of ('a,'b,'c) red_expr_gen * 'a - | ConstrContext of Names.Id.t Loc.located * 'a - | ConstrTypeOf of 'a +module Patternops : +sig + val pattern_of_glob_constr : Glob_term.glob_constr -> Names.Id.t list * Pattern.constr_pattern + val subst_pattern : Mod_subst.substitution -> Pattern.constr_pattern -> Pattern.constr_pattern + val pattern_of_constr : Environ.env -> Evd.evar_map -> Constr.t -> Pattern.constr_pattern + val instantiate_pattern : Environ.env -> + Evd.evar_map -> Pattern.extended_patvar_map -> + Pattern.constr_pattern -> Pattern.constr_pattern +end - type r_trm = Constrexpr.constr_expr - type r_pat = Constrexpr.constr_pattern_expr - type r_cst = Prelude.reference Misctypes.or_by_notation - type raw_red_expr = (r_trm, r_cst, r_pat) red_expr_gen +module Constr_matching : +sig + val special_meta : Constr.metavariable + + type binding_bound_vars = Names.Id.Set.t + type bound_ident_map = Names.Id.t Names.Id.Map.t + val is_matching : Environ.env -> Evd.evar_map -> Pattern.constr_pattern -> EConstr.constr -> bool + val extended_matches : + Environ.env -> Evd.evar_map -> binding_bound_vars * Pattern.constr_pattern -> + EConstr.constr -> bound_ident_map * Pattern.extended_patvar_map + exception PatternMatchingFailure + type matching_result = + { m_sub : bound_ident_map * Pattern.patvar_map; + m_ctx : EConstr.constr } + val match_subterm_gen : Environ.env -> Evd.evar_map -> + bool -> + binding_bound_vars * Pattern.constr_pattern -> EConstr.constr -> + matching_result IStream.t + val matches : Environ.env -> Evd.evar_map -> Pattern.constr_pattern -> EConstr.constr -> Pattern.patvar_map +end + +module Tacred : +sig + val try_red_product : Reductionops.reduction_function + val simpl : Reductionops.reduction_function + val unfoldn : + (Locus.occurrences * Names.evaluable_global_reference) list -> Reductionops.reduction_function + val hnf_constr : Reductionops.reduction_function + val red_product : Reductionops.reduction_function + val is_evaluable : Environ.env -> Names.evaluable_global_reference -> bool + val evaluable_of_global_reference : + Environ.env -> Globnames.global_reference -> Names.evaluable_global_reference + val error_not_evaluable : Globnames.global_reference -> 'a + val reduce_to_quantified_ref : + Environ.env -> Evd.evar_map -> Globnames.global_reference -> EConstr.types -> EConstr.types + val pattern_occs : (Locus.occurrences * EConstr.constr) list -> Reductionops.e_reduction_function + val cbv_norm_flags : CClosure.RedFlags.reds -> Reductionops.reduction_function +end + +(* XXX: Located manually from intf *) +module Tok : +sig + + type t = + | KEYWORD of string + | PATTERNIDENT of string + | IDENT of string + | FIELD of string + | INT of string + | STRING of string + | LEFTQMARK + | BULLET of string + | EOI + +end + +module CLexer : +sig + val add_keyword : string -> unit + val remove_keyword : string -> unit + val is_keyword : string -> bool + val keywords : unit -> CString.Set.t + + type keyword_state + val set_keyword_state : keyword_state -> unit + val get_keyword_state : unit -> keyword_state + + val check_ident : string -> unit + val terminal : string -> Tok.t + + include Grammar.GLexerType with type te = Tok.t end +module Extend : +sig + + type gram_assoc = NonA | RightA | LeftA + + type gram_position = + | First + | Last + | Before of string + | After of string + | Level of string + + type production_level = + | NextLevel + | NumLevel of int + + type 'a entry = 'a Grammar.GMake(CLexer).Entry.e + + type 'a user_symbol = + | Ulist1 of 'a user_symbol + | Ulist1sep of 'a user_symbol * string + | Ulist0 of 'a user_symbol + | Ulist0sep of 'a user_symbol * string + | Uopt of 'a user_symbol + | Uentry of 'a + | Uentryl of 'a * int + + type ('self, 'a) symbol = + | Atoken : Tok.t -> ('self, string) symbol + | Alist1 : ('self, 'a) symbol -> ('self, 'a list) symbol + | Alist1sep : ('self, 'a) symbol * ('self, _) symbol -> ('self, 'a list) symbol + | Alist0 : ('self, 'a) symbol -> ('self, 'a list) symbol + | Alist0sep : ('self, 'a) symbol * ('self, _) symbol -> ('self, 'a list) symbol + | Aopt : ('self, 'a) symbol -> ('self, 'a option) symbol + | Aself : ('self, 'self) symbol + | Anext : ('self, 'self) symbol + | Aentry : 'a entry -> ('self, 'a) symbol + | Aentryl : 'a entry * int -> ('self, 'a) symbol + | Arules : 'a rules list -> ('self, 'a) symbol + + and ('self, _, 'r) rule = + | Stop : ('self, 'r, 'r) rule + | Next : ('self, 'a, 'r) rule * ('self, 'b) symbol -> ('self, 'b -> 'a, 'r) rule + + and ('a, 'r) norec_rule = { norec_rule : 's. ('s, 'a, 'r) rule } + + and 'a rules = + | Rules : ('act, Loc.t -> 'a) norec_rule * 'act -> 'a rules + + type ('lev,'pos) constr_entry_key_gen = + | ETName | ETReference | ETBigint + | ETBinder of bool + | ETConstr of ('lev * 'pos) + | ETPattern + | ETOther of string * string + | ETConstrList of ('lev * 'pos) * Tok.t list + | ETBinderList of bool * Tok.t list + + type side = Left | Right + + type production_position = + | BorderProd of side * gram_assoc option + | InternalProd + + type constr_prod_entry_key = + (production_level,production_position) constr_entry_key_gen + + type simple_constr_prod_entry_key = + (production_level,unit) constr_entry_key_gen + + type 'a production_rule = + | Rule : ('a, 'act, Loc.t -> 'a) rule * 'act -> 'a production_rule + + type 'a single_extend_statment = + string option * + (** Level *) + gram_assoc option * + (** Associativity *) + 'a production_rule list + (** Symbol list with the interpretation function *) + + type 'a extend_statment = + gram_position option * + 'a single_extend_statment list +end + +(* XXX: Located manually from intf *) module Vernacexpr : sig + open Misctypes + open Constrexpr + open Libnames + type instance_flag = bool option type coercion_flag = bool type inductive_flag = Decl_kinds.recursivity_kind type lname = Names.Name.t Loc.located type lident = Names.Id.t Loc.located - type opacity_flag = Vernacexpr.opacity_flag = + type opacity_flag = | Opaque of lident list option | Transparent type locality_flag = bool - type inductive_kind = Vernacexpr.inductive_kind = + type inductive_kind = | Inductive_kw | CoInductive | Variant | Record | Structure | Class of bool - type 'a hint_info_gen = 'a Vernacexpr.hint_info_gen = - { hint_priority : int option; - hint_pattern : 'a option } - type vernac_type = Vernacexpr.vernac_type = + + type vernac_type = | VtStartProof of vernac_start | VtSideff of vernac_sideff_type | VtQed of vernac_qed_type @@ -2306,94 +3653,136 @@ sig | VtQuery of vernac_part_of_script * Feedback.route_id | VtStm of vernac_control * vernac_part_of_script | VtUnknown - and vernac_qed_type = Vernacexpr.vernac_qed_type = - | VtKeep - | VtKeepAsAxiom - | VtDrop + and vernac_qed_type = + | VtKeep + | VtKeepAsAxiom + | VtDrop and vernac_start = string * opacity_guarantee * Names.Id.t list and vernac_sideff_type = Names.Id.t list and vernac_part_of_script = bool - and vernac_control = Vernacexpr.vernac_control = - | VtWait - | VtJoinDocument - | VtBack of Stateid.t - and opacity_guarantee = Vernacexpr.opacity_guarantee = - | GuaranteesOpacity - | Doesn'tGuaranteeOpacity - and proof_step = Vernacexpr.proof_step = { - parallel : [ `Yes of solving_tac * anon_abstracting_tac | `No ]; - proof_block_detection : proof_block_name option - } + and vernac_control = + | VtWait + | VtJoinDocument + | VtBack of Stateid.t + and opacity_guarantee = + | GuaranteesOpacity + | Doesn'tGuaranteeOpacity + and proof_step = { + parallel : [ `Yes of solving_tac * anon_abstracting_tac | `No ]; + proof_block_detection : proof_block_name option + } and solving_tac = bool and anon_abstracting_tac = bool and proof_block_name = string - type vernac_when = Vernacexpr.vernac_when = - | VtNow - | VtLater + + type vernac_when = + | VtNow + | VtLater + type verbose_flag = bool type obsolete_locality = bool - type lstring = Vernacexpr.lstring + type lstring type 'a with_coercion = coercion_flag * 'a type scope_name = string type decl_notation = lstring * Constrexpr.constr_expr * scope_name option type constructor_expr = (lident * Constrexpr.constr_expr) with_coercion type 'a with_notation = 'a * decl_notation list - type local_decl_expr = Vernacexpr.local_decl_expr = + + type local_decl_expr = | AssumExpr of lname * Constrexpr.constr_expr | DefExpr of lname * Constrexpr.constr_expr * Constrexpr.constr_expr option + type 'a with_priority = 'a * int option type 'a with_instance = instance_flag * 'a - type constructor_list_or_record_decl_expr = Vernacexpr.constructor_list_or_record_decl_expr = + type constructor_list_or_record_decl_expr = | Constructors of constructor_expr list | RecordDecl of lident option * local_decl_expr with_instance with_priority with_notation list + type plident = lident * lident list option + type inductive_expr = plident with_coercion * Constrexpr.local_binder_expr list * Constrexpr.constr_expr option * inductive_kind * constructor_list_or_record_decl_expr - type syntax_modifier = Vernacexpr.syntax_modifier - type class_rawexpr = Vernacexpr.class_rawexpr - type definition_expr = Vernacexpr.definition_expr - type hint_info_expr = Constrexpr.constr_pattern_expr hint_info_gen - type proof_expr = Vernacexpr.proof_expr - type proof_end = Vernacexpr.proof_end = + type syntax_modifier = + | SetItemLevel of string list * Extend.production_level + | SetLevel of int + | SetAssoc of Extend.gram_assoc + | SetEntryType of string * Extend.simple_constr_prod_entry_key + | SetOnlyParsing + | SetOnlyPrinting + | SetCompatVersion of Flags.compat_version + | SetFormat of string * string Loc.located + + type class_rawexpr = FunClass | SortClass | RefClass of reference or_by_notation + + type definition_expr = + | ProveBody of local_binder_expr list * constr_expr + | DefineBody of local_binder_expr list * Genredexpr.raw_red_expr option * constr_expr + * constr_expr option + type proof_expr = + plident option * (local_binder_expr list * constr_expr) + + type proof_end = | Admitted | Proved of opacity_flag * lident option - type inline = Vernacexpr.inline + type fixpoint_expr = plident * (Names.Id.t Loc.located option * Constrexpr.recursion_order_expr) * Constrexpr.local_binder_expr list * Constrexpr.constr_expr * Constrexpr.constr_expr option - type cofixpoint_expr = Vernacexpr.cofixpoint_expr - type scheme = Vernacexpr.scheme - type section_subset_expr = Vernacexpr.section_subset_expr - type module_binder = Vernacexpr.module_binder - type vernac_argument_status = Vernacexpr.vernac_argument_status - type vernac_implicit_status = Vernacexpr.vernac_implicit_status - type module_ast_inl = Vernacexpr.module_ast_inl - type 'a module_signature = 'a Vernacexpr.module_signature + + type cofixpoint_expr + + type scheme + + type section_subset_expr + + type module_binder + + type vernac_argument_status + type vernac_implicit_status + type module_ast_inl type extend_name = string * int - type simple_binder = Vernacexpr.simple_binder - type option_value = Vernacexpr.option_value - type showable = Vernacexpr.showable - type bullet = Vernacexpr.bullet - type stm_vernac = Vernacexpr.stm_vernac - type comment = Vernacexpr.comment - type register_kind = Vernacexpr.register_kind - type locatable = Vernacexpr.locatable - type search_restriction = Vernacexpr.search_restriction - type searchable = Vernacexpr.searchable - type printable = Vernacexpr.printable - type option_ref_value = Vernacexpr.option_ref_value - type onlyparsing_flag = Vernacexpr.onlyparsing_flag - type reference_or_constr = Vernacexpr.reference_or_constr - type hint_mode = Vernacexpr.hint_mode - type hints_expr = Vernacexpr.hints_expr = + type simple_binder + type option_value + type showable + type bullet + type stm_vernac + type comment + type register_kind + type locatable + type search_restriction + type searchable + type printable + type option_ref_value + type onlyparsing_flag + type reference_or_constr + + type hint_mode + + type 'a hint_info_gen = + { hint_priority : int option; + hint_pattern : 'a option } + + type hint_info_expr = Constrexpr.constr_pattern_expr hint_info_gen + + type hints_expr = | HintsResolve of (hint_info_expr * bool * reference_or_constr) list | HintsImmediate of reference_or_constr list - | HintsUnfold of Prelude.reference list - | HintsTransparency of Prelude.reference list * bool - | HintsMode of Prelude.reference * hint_mode list - | HintsConstructors of Prelude.reference list + | HintsUnfold of Libnames.reference list + | HintsTransparency of Libnames.reference list * bool + | HintsMode of Libnames.reference * hint_mode list + | HintsConstructors of Libnames.reference list | HintsExtern of int * Constrexpr.constr_expr option * Genarg.raw_generic_argument - type vernac_expr = Vernacexpr.vernac_expr = + + type 'a module_signature = + | Enforce of 'a (** ... : T *) + | Check of 'a list (** ... <: T1 <: T2, possibly empty *) + + type inline = + | NoInline + | DefaultInline + | InlineAt of int + + type vernac_expr = | VernacLoad of verbose_flag * string | VernacTime of vernac_expr Loc.located | VernacRedirect of string * vernac_expr Loc.located @@ -2429,10 +3818,10 @@ sig | VernacBeginSection of lident | VernacEndSegment of lident | VernacRequire of - Prelude.reference option * bool option * Prelude.reference list - | VernacImport of bool * Prelude.reference list - | VernacCanonical of Prelude.reference Misctypes.or_by_notation - | VernacCoercion of obsolete_locality * Prelude.reference Misctypes.or_by_notation * + Libnames.reference option * bool option * Libnames.reference list + | VernacImport of bool * Libnames.reference list + | VernacCanonical of Libnames.reference Misctypes.or_by_notation + | VernacCoercion of obsolete_locality * Libnames.reference Misctypes.or_by_notation * class_rawexpr * class_rawexpr | VernacIdentityCoercion of obsolete_locality * lident * class_rawexpr * class_rawexpr @@ -2442,11 +3831,11 @@ sig Constrexpr.local_binder_expr list * Constrexpr.typeclass_constraint * (bool * Constrexpr.constr_expr) option * - hint_info_expr + hint_info_expr | VernacContext of Constrexpr.local_binder_expr list | VernacDeclareInstances of - (Prelude.reference * hint_info_expr) list - | VernacDeclareClass of Prelude.reference + (Libnames.reference * hint_info_expr) list + | VernacDeclareClass of Libnames.reference | VernacDeclareModule of bool option * lident * module_binder list * module_ast_inl | VernacDefineModule of bool option * lident * module_binder list * @@ -2467,26 +3856,26 @@ sig | VernacBack of int | VernacBackTo of int | VernacCreateHintDb of string * bool - | VernacRemoveHints of string list * Prelude.reference list + | VernacRemoveHints of string list * Libnames.reference list | VernacHints of obsolete_locality * string list * hints_expr | VernacSyntacticDefinition of Names.Id.t Loc.located * (Names.Id.t list * Constrexpr.constr_expr) * obsolete_locality * onlyparsing_flag - | VernacDeclareImplicits of Prelude.reference Misctypes.or_by_notation * + | VernacDeclareImplicits of Libnames.reference Misctypes.or_by_notation * (Constrexpr.explicitation * bool * bool) list list - | VernacArguments of Prelude.reference Misctypes.or_by_notation * + | VernacArguments of Libnames.reference Misctypes.or_by_notation * vernac_argument_status list * (Names.Name.t * vernac_implicit_status) list list * int option * [ `ReductionDontExposeCase | `ReductionNeverUnfold | `Rename | `ExtraScopes | `Assert | `ClearImplicits | `ClearScopes | `DefaultImplicits ] list - | VernacArgumentsScope of Prelude.reference Misctypes.or_by_notation * + | VernacArgumentsScope of Libnames.reference Misctypes.or_by_notation * scope_name option list | VernacReserve of simple_binder list | VernacGeneralizable of (lident list) option - | VernacSetOpacity of (Conv_oracle.level * Prelude.reference Misctypes.or_by_notation list) + | VernacSetOpacity of (Conv_oracle.level * Libnames.reference Misctypes.or_by_notation list) | VernacSetStrategy of - (Conv_oracle.level * Prelude.reference Misctypes.or_by_notation list) list + (Conv_oracle.level * Libnames.reference Misctypes.or_by_notation list) list | VernacUnsetOption of Goptions.option_name | VernacSetOption of Goptions.option_name * option_value | VernacSetAppendOption of Goptions.option_name * string @@ -2525,7 +3914,7 @@ sig | VernacProgram of vernac_expr | VernacPolymorphic of bool * vernac_expr | VernacLocal of bool * vernac_expr - and goal_selector = Vernacexpr.goal_selector = + and goal_selector = | SelectNth of int | SelectList of (int * int) list | SelectId of Names.Id.t @@ -2535,443 +3924,82 @@ sig plident * Constrexpr.local_binder_expr list * Constrexpr.constr_expr option * constructor_expr list end -module Glob_term : -sig - type cases_pattern_r = Glob_term.cases_pattern_r = - | PatVar of Names.Name.t - | PatCstr of Names.constructor * cases_pattern list * Names.Name.t - and cases_pattern = cases_pattern_r CAst.t - type existential_name = Names.Id.t - type glob_constr_r = Glob_term.glob_constr_r = - | GRef of Globnames.global_reference * Misctypes.glob_level list option - (** An identifier that represents a reference to an object defined - either in the (global) environment or in the (local) context. *) - | GVar of Names.Id.t - (** An identifier that cannot be regarded as "GRef". - Bound variables are typically represented this way. *) - | GEvar of existential_name * (Names.Id.t * glob_constr) list - | GPatVar of Evar_kinds.matching_var_kind - | GApp of glob_constr * glob_constr list - | GLambda of Names.Name.t * Decl_kinds.binding_kind * glob_constr * glob_constr - | GProd of Names.Name.t * Decl_kinds.binding_kind * glob_constr * glob_constr - | GLetIn of Names.Name.t * glob_constr * glob_constr option * glob_constr - | GCases of Term.case_style * glob_constr option * tomatch_tuples * cases_clauses - | GLetTuple of Names.Name.t list * (Names.Name.t * glob_constr option) * glob_constr * glob_constr - | GIf of glob_constr * (Names.Name.t * glob_constr option) * glob_constr * glob_constr - | GRec of fix_kind * Names.Id.t array * glob_decl list array * - glob_constr array * glob_constr array - | GSort of Misctypes.glob_sort - | GHole of Evar_kinds.t * Misctypes.intro_pattern_naming_expr * Genarg.glob_generic_argument option - | GCast of glob_constr * glob_constr Misctypes.cast_type - - and glob_constr = glob_constr_r CAst.t - - and glob_decl = Names.Name.t * Decl_kinds.binding_kind * glob_constr option * glob_constr - - and fix_recursion_order = Glob_term.fix_recursion_order = - | GStructRec - | GWfRec of glob_constr - | GMeasureRec of glob_constr * glob_constr option - - and fix_kind = Glob_term.fix_kind = - | GFix of ((int option * fix_recursion_order) array * int) - | GCoFix of int - - and predicate_pattern = - Names.Name.t * (Names.inductive * Names.Name.t list) Loc.located option - - and tomatch_tuple = (glob_constr * predicate_pattern) - - and tomatch_tuples = tomatch_tuple list - - and cases_clause = (Names.Id.t list * cases_pattern list * glob_constr) Loc.located - and cases_clauses = cases_clause list - - type closure = Glob_term.closure = - { idents:Names.Id.t Names.Id.Map.t; - typed: Pattern.constr_under_binders Names.Id.Map.t ; - untyped:closed_glob_constr Names.Id.Map.t } - and closed_glob_constr = Glob_term.closed_glob_constr = { - closure: closure; - term: glob_constr } - - type var_map = Pattern.constr_under_binders Names.Id.Map.t - type uconstr_var_map = Glob_term.closed_glob_constr Names.Id.Map.t - type unbound_ltac_var_map = Geninterp.Val.t Names.Id.Map.t - type ltac_var_map = Glob_term.ltac_var_map = { - ltac_constrs : var_map; - (** Ltac variables bound to constrs *) - ltac_uconstrs : uconstr_var_map; - (** Ltac variables bound to untyped constrs *) - ltac_idents: Names.Id.t Names.Id.Map.t; - (** Ltac variables bound to identifiers *) - ltac_genargs : unbound_ltac_var_map; - (** Ltac variables bound to other kinds of arguments *) - } -end - -module Libnames : -sig - type full_path = Libnames.full_path - val pr_path : Libnames.full_path -> Pp.std_ppcmds - val make_path : Names.DirPath.t -> Names.Id.t -> full_path - val eq_full_path : full_path -> full_path -> bool - val dirpath : full_path -> Names.DirPath.t - val path_of_string : string -> full_path - - type qualid = Libnames.qualid - val make_qualid : Names.DirPath.t -> Names.Id.t -> qualid - val qualid_eq : qualid -> qualid -> bool - val repr_qualid : qualid -> Names.DirPath.t * Names.Id.t - val pr_qualid : qualid -> Pp.std_ppcmds - val string_of_qualid : qualid -> string - val qualid_of_string : string -> qualid - val qualid_of_path : full_path -> qualid - val qualid_of_dirpath : Names.DirPath.t -> qualid - val qualid_of_ident : Names.Id.t -> qualid - - type reference = Prelude.reference = - | Qualid of Libnames.qualid Loc.located - | Ident of Names.Id.t Loc.located - val loc_of_reference : reference -> Loc.t option - val qualid_of_reference : reference -> qualid Loc.located - val pr_reference : reference -> Pp.std_ppcmds - - val is_dirpath_prefix_of : Names.DirPath.t -> Names.DirPath.t -> bool - 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.std_ppcmds - - val string_of_path : full_path -> string - val basename : full_path -> Names.Id.t - - type object_name = Libnames.full_path * Names.KerName.t - type object_prefix = Names.DirPath.t * (Names.ModPath.t * Names.DirPath.t) - - module Dirset : module type of struct include Libnames.Dirset end - module Dirmap : module type of struct include Libnames.Dirmap end - module Spmap : module type of struct include Libnames.Spmap end -end - -module Libobject : -sig - type obj = Libobject.obj - type 'a substitutivity = 'a Libobject.substitutivity = - | Dispose - | Substitute of 'a - | Keep of 'a - | Anticipate of 'a - type 'a object_declaration = 'a Libobject.object_declaration = - { - object_name : string; - cache_function : Libnames.object_name * 'a -> unit; - load_function : int -> Libnames.object_name * 'a -> unit; - open_function : int -> Libnames.object_name * 'a -> unit; - classify_function : 'a -> 'a substitutivity; - subst_function : Mod_subst.substitution * 'a -> 'a; - discharge_function : Libnames.object_name * 'a -> 'a option; - rebuild_function : 'a -> 'a - } - val declare_object : 'a object_declaration -> ('a -> obj) - val default_object : string -> 'a object_declaration - val object_tag : obj -> string -end - -module Universes : -sig - type universe_binders = Universes.universe_binders - type universe_opt_subst = Universes.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 constr_of_global : Prelude.global_reference -> Term.constr - val new_univ_level : Names.DirPath.t -> Univ.Level.t - val new_sort_in_family : Sorts.family -> Sorts.t - val pr_with_global_universes : Univ.Level.t -> Pp.std_ppcmds - val pr_universe_opt_subst : universe_opt_subst -> Pp.std_ppcmds - type universe_constraint = Universes.universe_constraint - module Constraints : - sig - type t = Universes.Constraints.t - val pr : t -> Pp.std_ppcmds - end -end - -module Global : -sig - val env : unit -> Environ.env - val lookup_mind : Names.MutInd.t -> Declarations.mutual_inductive_body - val lookup_constant : Names.Constant.t -> Declarations.constant_body - val lookup_module : Names.ModPath.t -> Declarations.module_body - val lookup_modtype : Names.ModPath.t -> Declarations.module_type_body - val lookup_inductive : Names.inductive -> Declarations.mutual_inductive_body * Declarations.one_inductive_body - val constant_of_delta_kn : Names.KerName.t -> Names.Constant.t - val register : - Retroknowledge.field -> Term.constr -> Term.constr -> unit - val env_of_context : Environ.named_context_val -> Environ.env - val is_polymorphic : Globnames.global_reference -> bool - - val constr_of_global_in_context : Environ.env -> Globnames.global_reference -> Constr.t * Univ.AUContext.t - val type_of_global_in_context : Environ.env -> Globnames.global_reference -> Constr.t * Univ.AUContext.t - - val current_dirpath : unit -> Names.DirPath.t - val body_of_constant_body : Declarations.constant_body -> (Term.constr * Univ.AUContext.t) option - val body_of_constant : Names.Constant.t -> (Term.constr * Univ.AUContext.t) option - val add_constraints : Univ.Constraint.t -> unit -end - -module Lib : sig - type is_type = bool - type export = bool option - type node = Lib.node = - | Leaf of Libobject.obj (* FIX: horrible hack (wrt. Enrico) *) - | CompilingLibrary of Libnames.object_prefix - | OpenedModule of is_type * export * Libnames.object_prefix * Summary.frozen - | ClosedModule of library_segment - | OpenedSection of Libnames.object_prefix * Summary.frozen - | ClosedSection of library_segment - - and library_segment = (Libnames.object_name * node) list - - val current_mp : unit -> Names.ModPath.t - val is_modtype : unit -> bool - val is_module : unit -> bool - val sections_are_opened : unit -> bool - val add_anonymous_leaf : ?cache_first:bool -> Libobject.obj -> unit - val contents : unit -> library_segment - val cwd : unit -> Names.DirPath.t - val add_leaf : Names.Id.t -> Libobject.obj -> Libnames.object_name - val make_kn : Names.Id.t -> Names.KerName.t - val make_path : Names.Id.t -> Libnames.full_path - val discharge_con : Names.Constant.t -> Names.Constant.t - val discharge_inductive : Names.inductive -> Names.inductive -end - -module Library : -sig - val library_is_loaded : Names.DirPath.t -> bool - val loaded_libraries : unit -> Names.DirPath.t list -end - -module Summary : -sig - type marshallable = Summary.marshallable - type 'a summary_declaration = 'a Summary.summary_declaration = - { freeze_function : marshallable -> 'a; - unfreeze_function : 'a -> unit; - init_function : unit -> unit; } - val ref : ?freeze:(marshallable -> 'a -> 'a) -> name:string -> 'a -> 'a ref - val declare_summary : string -> 'a summary_declaration -> unit - module Local : - sig - type 'a local_ref = 'a Summary.Local.local_ref - val ref : ?freeze:('a -> 'a) -> name:string -> 'a -> 'a local_ref - val (:=) : 'a local_ref -> 'a -> unit - val (!) : 'a local_ref -> 'a - end -end - -module Declare : -sig - type internal_flag = Declare.internal_flag = - | UserAutomaticRequest - | InternalTacticRequest - | UserIndividualRequest - type constant_declaration = Safe_typing.private_constants Entries.constant_entry * Decl_kinds.logical_kind - type section_variable_entry = Declare.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 - type variable_declaration = Names.DirPath.t * section_variable_entry * Decl_kinds.logical_kind - val declare_constant : - ?internal:internal_flag -> ?local:bool -> Names.Id.t -> ?export_seff:bool -> constant_declaration -> Names.Constant.t - val declare_universe_context : Decl_kinds.polymorphic -> Univ.ContextSet.t -> unit - val declare_definition : - ?internal:internal_flag -> ?opaque:bool -> ?kind:Decl_kinds.definition_object_kind -> - ?local:bool -> ?poly:Decl_kinds.polymorphic -> Names.Id.t -> ?types:Term.constr -> - Term.constr Univ.in_universe_context_set -> Names.Constant.t - val definition_entry : ?fix_exn:Future.fix_exn -> - ?opaque:bool -> ?inline:bool -> ?types:Term.types -> - ?poly:Decl_kinds.polymorphic -> ?univs:Univ.UContext.t -> - ?eff:Safe_typing.private_constants -> Term.constr -> Safe_typing.private_constants Entries.definition_entry - val definition_message : Names.Id.t -> unit - val declare_variable : Names.Id.t -> variable_declaration -> Libnames.object_name -end - -module Reductionops : -sig - type local_reduction_function = Evd.evar_map -> EConstr.constr -> EConstr.constr - - type reduction_function = Environ.env -> Evd.evar_map -> EConstr.constr -> EConstr.constr - - type local_stack_reduction_function = - Evd.evar_map -> EConstr.constr -> EConstr.constr * EConstr.constr list - - type e_reduction_function = Environ.env -> Evd.evar_map -> EConstr.constr -> Evd.evar_map * EConstr.constr - type state = Reductionops.state - - val clos_whd_flags : CClosure.RedFlags.reds -> reduction_function - val nf_beta : local_reduction_function - val nf_betaiota : local_reduction_function - val splay_prod : Environ.env -> Evd.evar_map -> EConstr.constr -> - (Names.Name.t * EConstr.constr) list * EConstr.constr - val splay_prod_n : Environ.env -> Evd.evar_map -> int -> EConstr.constr -> EConstr.rel_context * EConstr.constr - val whd_all : reduction_function - val whd_beta : local_reduction_function - - val whd_betaiotazeta : local_reduction_function - - val whd_betaiota_stack : local_stack_reduction_function +(* XXX: end manual intf move *) - val clos_norm_flags : CClosure.RedFlags.reds -> reduction_function - val is_conv : ?reds:Names.transparent_state -> Environ.env -> Evd.evar_map -> EConstr.constr -> EConstr.constr -> bool - val beta_applist : Evd.evar_map -> EConstr.constr * EConstr.constr list -> EConstr.constr - val sort_of_arity : Environ.env -> Evd.evar_map -> EConstr.constr -> EConstr.ESorts.t - val is_conv_leq : ?reds:Names.transparent_state -> Environ.env -> Evd.evar_map -> EConstr.constr -> EConstr.constr -> bool - val whd_betaiota : local_reduction_function - val is_arity : Environ.env -> Evd.evar_map -> EConstr.constr -> bool - val nf_evar : Evd.evar_map -> EConstr.constr -> EConstr.constr - val nf_meta : Evd.evar_map -> EConstr.constr -> EConstr.constr - val hnf_prod_appvect : Environ.env -> Evd.evar_map -> EConstr.constr -> EConstr.constr array -> EConstr.constr - val pr_state : state -> Pp.std_ppcmds - module Stack : - sig - type 'a t = 'a Reductionops.Stack.t - val pr : ('a -> Pp.std_ppcmds) -> 'a t -> Pp.std_ppcmds - end - module Cst_stack : - sig - type t = Reductionops.Cst_stack.t - val pr : t -> Pp.std_ppcmds - end -end - -module Inductiveops : +module Typeclasses : sig - type inductive_family = Inductiveops.inductive_family - type inductive_type = Inductiveops.inductive_type = - | IndType of inductive_family * EConstr.constr list - type constructor_summary = Inductiveops.constructor_summary = - { - cs_cstr : Term.pconstructor; - cs_params : Term.constr list; - cs_nargs : int; - cs_args : Context.Rel.t; - cs_concl_realargs : Term.constr array; - } - - val arities_of_constructors : Environ.env -> Term.pinductive -> Term.types array - val constructors_nrealargs_env : Environ.env -> Names.inductive -> int array - val constructor_nallargs_env : Environ.env -> Names.constructor -> int - - val inductive_nparams : Names.inductive -> int - - val inductive_nparamdecls : Names.inductive -> int - - val type_of_constructors : Environ.env -> Term.pinductive -> Term.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 * Term.constr list - val find_inductive : Environ.env -> Evd.evar_map -> EConstr.types -> (Names.inductive * EConstr.EInstance.t) * Term.constr list - val type_of_inductive : Environ.env -> Term.pinductive -> Term.types -end + type typeclass = { + cl_univs : Univ.AUContext.t; + cl_impl : Globnames.global_reference; + cl_context : (Globnames.global_reference * bool) option list * Context.Rel.t; + cl_props : Context.Rel.t; + cl_projs : (Names.Name.t * (direction * Vernacexpr.hint_info_expr) option + * Names.Constant.t option) list; + cl_strict : bool; + cl_unique : bool; + } + and direction -module Recordops : -sig - type cs_pattern = Recordops.cs_pattern = - | Const_cs of Globnames.global_reference - | Prod_cs - | Sort_cs of Sorts.family - | Default_cs - type obj_typ = Recordops.obj_typ = { - o_DEF : Term.constr; - o_CTX : Univ.AUContext.t; - o_INJ : int option; (** position of trivial argument *) - o_TABS : Term.constr list; (** ordered *) - o_TPARAMS : Term.constr list; (** ordered *) - o_NPARAMS : int; - o_TCOMPS : Term.constr list } - val lookup_projections : Names.inductive -> Names.Constant.t option list - val lookup_canonical_conversion : (Globnames.global_reference * cs_pattern) -> Term.constr * obj_typ - val find_projection_nparams : Globnames.global_reference -> int -end + type instance + type evar_filter = Evar.t -> Evar_kinds.t -> bool -module Retyping : (* reconstruct the type of a term knowing that it was already typechecked *) -sig - val get_type_of : ?polyprop:bool -> ?lax:bool -> Environ.env -> Evd.evar_map -> EConstr.constr -> EConstr.types - val get_sort_family_of : ?polyprop:bool -> Environ.env -> Evd.evar_map -> EConstr.types -> Sorts.family - val expand_projection : Environ.env -> Evd.evar_map -> Names.Projection.t -> EConstr.constr -> EConstr.constr list -> EConstr.constr - val get_sort_of : - ?polyprop:bool -> Environ.env -> Evd.evar_map -> EConstr.types -> Sorts.t + val resolve_typeclasses : ?fast_path:bool -> ?filter:evar_filter -> ?unique:bool -> + ?split:bool -> ?fail:bool -> Environ.env -> Evd.evar_map -> Evd.evar_map + val set_resolvable : Evd.Store.t -> bool -> Evd.Store.t + val resolve_one_typeclass : ?unique:bool -> Environ.env -> Evd.evar_map -> EConstr.types -> Evd.evar_map * EConstr.constr + val class_info : Globnames.global_reference -> typeclass + val mark_resolvables : ?filter:evar_filter -> Evd.evar_map -> Evd.evar_map + val add_instance : instance -> unit + val new_instance : typeclass -> Vernacexpr.hint_info_expr -> bool -> Decl_kinds.polymorphic -> + Globnames.global_reference -> instance end -module Typing : +module Classops : sig - val e_sort_of : Environ.env -> Evd.evar_map ref -> EConstr.types -> Sorts.t - - val type_of : ?refresh:bool -> Environ.env -> Evd.evar_map -> EConstr.constr -> Evd.evar_map * EConstr.types - val e_solve_evars : Environ.env -> Evd.evar_map ref -> EConstr.constr -> EConstr.constr - - val unsafe_type_of : Environ.env -> Evd.evar_map -> EConstr.constr -> EConstr.types - - val e_check : Environ.env -> Evd.evar_map ref -> EConstr.constr -> EConstr.types -> unit + type coe_index + type inheritance_path = coe_index list + type cl_index - val e_type_of : ?refresh:bool -> Environ.env -> Evd.evar_map ref -> EConstr.constr -> EConstr.types + val hide_coercion : Globnames.global_reference -> int option + val lookup_path_to_sort_from : Environ.env -> Evd.evar_map -> EConstr.types -> + EConstr.types * inheritance_path + val get_coercion_value : coe_index -> Constr.t + val coercions : unit -> coe_index list + val pr_cl_index : cl_index -> Pp.t end -module Evarsolve : +module Detyping : sig - val refresh_universes : - ?status:Evd.rigid -> ?onlyalg:bool -> ?refreshset:bool -> bool option -> - Environ.env -> Evd.evar_map -> EConstr.types -> Evd.evar_map * EConstr.types + val print_universes : bool ref + val print_evar_arguments : bool ref + val detype : ?lax:bool -> bool -> Names.Id.t list -> Environ.env -> Evd.evar_map -> EConstr.constr -> Glob_term.glob_constr + val subst_glob_constr : Mod_subst.substitution -> Glob_term.glob_constr -> Glob_term.glob_constr + val set_detype_anonymous : (?loc:Loc.t -> int -> Glob_term.glob_constr) -> unit end -module Constr_matching : -sig - val special_meta : Prelude.metavariable - - type binding_bound_vars = Names.Id.Set.t - type bound_ident_map = Names.Id.t Names.Id.Map.t - val is_matching : Environ.env -> Evd.evar_map -> Pattern.constr_pattern -> EConstr.constr -> bool - val extended_matches : - Environ.env -> Evd.evar_map -> binding_bound_vars * Pattern.constr_pattern -> - EConstr.constr -> bound_ident_map * Pattern.extended_patvar_map - exception PatternMatchingFailure - type matching_result = - { m_sub : bound_ident_map * Pattern.patvar_map; - m_ctx : EConstr.constr } - val match_subterm_gen : Environ.env -> Evd.evar_map -> - bool -> - binding_bound_vars * Pattern.constr_pattern -> EConstr.constr -> - matching_result IStream.t - val matches : Environ.env -> Evd.evar_map -> Pattern.constr_pattern -> EConstr.constr -> Pattern.patvar_map -end - -module Tactypes : +module Indrec : sig - type glob_constr_and_expr = Glob_term.glob_constr * Constrexpr.constr_expr option - type glob_constr_pattern_and_expr = Names.Id.Set.t * glob_constr_and_expr * Pattern.constr_pattern - type 'a delayed_open = Environ.env -> Evd.evar_map -> Evd.evar_map * 'a - type delayed_open_constr = EConstr.constr delayed_open - type delayed_open_constr_with_bindings = EConstr.constr Misctypes.with_bindings delayed_open - type intro_pattern = delayed_open_constr Misctypes.intro_pattern_expr Loc.located - type intro_patterns = delayed_open_constr Misctypes.intro_pattern_expr Loc.located list - type intro_pattern_naming = Misctypes.intro_pattern_naming_expr Loc.located - type or_and_intro_pattern = delayed_open_constr Misctypes.or_and_intro_pattern_expr Loc.located + 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 -> + 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 -> + Sorts.family -> Evd.evar_map * Constr.t end module Pretyping : sig - type typing_constraint = Pretyping.typing_constraint = - | OfType of EConstr.types - | IsType - | WithoutTypeConstraint + type typing_constraint = + | OfType of EConstr.types + | IsType + | WithoutTypeConstraint type inference_hook = Environ.env -> Evd.evar_map -> Evar.t -> Evd.evar_map * EConstr.constr - type inference_flags = Pretyping.inference_flags = { + + type inference_flags = { use_typeclasses : bool; solve_unification_constraints : bool; use_hook : inference_hook option; @@ -2992,7 +4020,7 @@ sig ?expected_type:typing_constraint -> Geninterp.interp_sign -> Glob_term.closed_glob_constr -> EConstr.constr Tactypes.delayed_open val understand : ?flags:inference_flags -> ?expected_type:typing_constraint -> - Environ.env -> Evd.evar_map -> Glob_term.glob_constr -> Term.constr Evd.in_evar_universe_context + Environ.env -> Evd.evar_map -> Glob_term.glob_constr -> Constr.t Evd.in_evar_universe_context val check_evars : Environ.env -> Evd.evar_map -> Evd.evar_map -> EConstr.constr -> unit val interp_elimination_sort : Misctypes.glob_sort -> Sorts.family val register_constr_interp0 : @@ -3004,39 +4032,30 @@ sig Glob_term.ltac_var_map -> typing_constraint -> Glob_term.glob_constr -> Evd.evar_map * EConstr.constr end -module Evarconv : -sig - val e_conv : Environ.env -> ?ts:Names.transparent_state -> Evd.evar_map ref -> EConstr.constr -> EConstr.constr -> bool - val the_conv_x : Environ.env -> ?ts:Names.transparent_state -> EConstr.constr -> EConstr.constr -> Evd.evar_map -> Evd.evar_map - val the_conv_x_leq : Environ.env -> ?ts:Names.transparent_state -> EConstr.constr -> EConstr.constr -> Evd.evar_map -> Evd.evar_map - val solve_unif_constraints_with_heuristics : Environ.env -> ?ts:Names.transparent_state -> Evd.evar_map -> Evd.evar_map -end - module Unification : sig - type core_unify_flags = Unification.core_unify_flags = - { - modulo_conv_on_closed_terms : Names.transparent_state option; - use_metas_eagerly_in_conv_on_closed_terms : bool; - use_evars_eagerly_in_conv_on_closed_terms : bool; - modulo_delta : Names.transparent_state; - modulo_delta_types : Names.transparent_state; - check_applied_meta_types : bool; - use_pattern_unification : bool; - use_meta_bound_pattern_unification : bool; - frozen_evars : Evar.Set.t; - restrict_conv_on_strict_subterms : bool; - modulo_betaiota : bool; - modulo_eta : bool; - } - type unify_flags = Unification.unify_flags = - { - core_unify_flags : core_unify_flags; - merge_unify_flags : core_unify_flags; - subterm_unify_flags : core_unify_flags; - allow_K_in_toplevel_higher_order_unification : bool; - resolve_evars : bool - } + type core_unify_flags = { + modulo_conv_on_closed_terms : Names.transparent_state option; + use_metas_eagerly_in_conv_on_closed_terms : bool; + use_evars_eagerly_in_conv_on_closed_terms : bool; + modulo_delta : Names.transparent_state; + modulo_delta_types : Names.transparent_state; + check_applied_meta_types : bool; + use_pattern_unification : bool; + use_meta_bound_pattern_unification : bool; + frozen_evars : Evar.Set.t; + restrict_conv_on_strict_subterms : bool; + modulo_betaiota : bool; + modulo_eta : bool; + } + type unify_flags = + { + core_unify_flags : core_unify_flags; + merge_unify_flags : core_unify_flags; + subterm_unify_flags : core_unify_flags; + allow_K_in_toplevel_higher_order_unification : bool; + resolve_evars : bool + } val default_no_delta_unify_flags : unit -> unify_flags val w_unify : Environ.env -> Evd.evar_map -> Reduction.conv_pb -> ?flags:unify_flags -> EConstr.constr -> EConstr.constr -> Evd.evar_map val elim_flags : unit -> unify_flags @@ -3044,77 +4063,47 @@ sig Environ.env -> Evd.evar_map -> ?flags:unify_flags -> EConstr.constr * EConstr.constr -> Evd.evar_map * EConstr.constr end -module Typeclasses : +(************************************************************************) +(* End of modules from pretyping/ *) +(************************************************************************) + +(************************************************************************) +(* Modules from interp/ *) +(************************************************************************) + +module Genintern : sig - type typeclass = Typeclasses.typeclass = { - cl_univs : Univ.AUContext.t; - cl_impl : Globnames.global_reference; - cl_context : (Globnames.global_reference * bool) option list * Context.Rel.t; - cl_props : Context.Rel.t; - cl_projs : (Names.Name.t * (direction * Vernacexpr.hint_info_expr) option - * Names.Constant.t option) list; - cl_strict : bool; - cl_unique : bool; + open Genarg + + module Store : Store.S + + type glob_sign = { + ltacvars : Names.Id.Set.t; + genv : Environ.env; + extra : Store.t; } - and direction = Typeclasses.direction - type instance = Typeclasses.instance - type evar_filter = Evar.t -> Evar_kinds.t -> bool - val resolve_typeclasses : ?fast_path:bool -> ?filter:evar_filter -> ?unique:bool -> - ?split:bool -> ?fail:bool -> Environ.env -> Evd.evar_map -> Evd.evar_map - val set_resolvable : Evd.Store.t -> bool -> Evd.Store.t - val resolve_one_typeclass : ?unique:bool -> Environ.env -> Evd.evar_map -> EConstr.types -> Evd.evar_map * EConstr.constr - val class_info : Globnames.global_reference -> typeclass - val mark_resolvables : ?filter:evar_filter -> Evd.evar_map -> Evd.evar_map - val add_instance : instance -> unit - val new_instance : typeclass -> Vernacexpr.hint_info_expr -> bool -> Decl_kinds.polymorphic -> - Globnames.global_reference -> instance -end -module Pretype_errors : -sig - type unification_error = Pretype_errors.unification_error - type subterm_unification_error = Pretype_errors.subterm_unification_error - type pretype_error = Pretype_errors.pretype_error = - | CantFindCaseType of EConstr.constr - | ActualTypeNotCoercible of EConstr.unsafe_judgment * EConstr.types * unification_error - | UnifOccurCheck of Evar.t * EConstr.constr - | UnsolvableImplicit of Evar.t * Evd.unsolvability_explanation option - | CannotUnify of EConstr.constr * EConstr.constr * unification_error option - | CannotUnifyLocal of EConstr.constr * EConstr.constr * EConstr.constr - | CannotUnifyBindingType of EConstr.constr * EConstr.constr - | CannotGeneralize of EConstr.constr - | NoOccurrenceFound of EConstr.constr * Names.Id.t option - | CannotFindWellTypedAbstraction of EConstr.constr * EConstr.constr list * (Environ.env * Pretype_errors.type_error) option - | WrongAbstractionType of Names.Name.t * EConstr.constr * EConstr.types * EConstr.types - | AbstractionOverMeta of Names.Name.t * Names.Name.t - | NonLinearUnification of Names.Name.t * EConstr.constr - | VarNotFound of Names.Id.t - | UnexpectedType of EConstr.constr * EConstr.constr - | NotProduct of EConstr.constr - | TypingError of Pretype_errors.type_error - | CannotUnifyOccurrences of subterm_unification_error - | UnsatisfiableConstraints of - (Evar.t * Evar_kinds.t) option * Evar.Set.t option + val empty_glob_sign : Environ.env -> glob_sign - exception PretypeError of Environ.env * Evd.evar_map * pretype_error - val error_var_not_found : ?loc:Loc.t -> Names.Id.t -> 'b - val precatchable_exception : exn -> bool -end + type ('raw, 'glb) intern_fun = glob_sign -> 'raw -> glob_sign * 'glb -module Smartlocate : -sig - val locate_global_with_alias : ?head:bool -> Libnames.qualid Loc.located -> Globnames.global_reference - val global_with_alias : ?head:bool -> Prelude.reference -> Globnames.global_reference - val global_of_extended_global : Globnames.extended_global_reference -> Globnames.global_reference - val loc_of_smart_reference : Prelude.reference Misctypes.or_by_notation -> Loc.t option - val smart_global : ?head:bool -> Prelude.reference Misctypes.or_by_notation -> Globnames.global_reference -end -module Dumpglob : -sig - val add_glob : ?loc:Loc.t -> Globnames.global_reference -> unit - val pause : unit -> unit - val continue : unit -> unit + val generic_intern : (raw_generic_argument, glob_generic_argument) intern_fun + + type 'glb subst_fun = Mod_subst.substitution -> 'glb -> 'glb + val generic_substitute : Genarg.glob_generic_argument subst_fun + + type 'glb ntn_subst_fun = Tactypes.glob_constr_and_expr Names.Id.Map.t -> 'glb -> 'glb + + val register_intern0 : ('raw, 'glb, 'top) genarg_type -> + ('raw, 'glb) intern_fun -> unit + + val register_subst0 : ('raw, 'glb, 'top) genarg_type -> + 'glb subst_fun -> unit + + val register_ntn_subst0 : ('raw, 'glb, 'top) genarg_type -> + 'glb ntn_subst_fun -> unit + end module Stdarg : @@ -3126,18 +4115,18 @@ sig val wit_bool : bool Genarg.uniform_genarg_type val wit_string : string Genarg.uniform_genarg_type val wit_pre_ident : string Genarg.uniform_genarg_type - val wit_global : (Prelude.reference, Globnames.global_reference Loc.located Misctypes.or_var, Globnames.global_reference) Genarg.genarg_type + val wit_global : (Libnames.reference, Globnames.global_reference Loc.located Misctypes.or_var, Globnames.global_reference) Genarg.genarg_type val wit_ident : Names.Id.t Genarg.uniform_genarg_type val wit_integer : int Genarg.uniform_genarg_type val wit_constr : (Constrexpr.constr_expr, Tactypes.glob_constr_and_expr, EConstr.constr) Genarg.genarg_type val wit_open_constr : (Constrexpr.constr_expr, Tactypes.glob_constr_and_expr, EConstr.constr) Genarg.genarg_type val wit_intro_pattern : (Constrexpr.constr_expr Misctypes.intro_pattern_expr Loc.located, Tactypes.glob_constr_and_expr Misctypes.intro_pattern_expr Loc.located, Tactypes.intro_pattern) Genarg.genarg_type val wit_int_or_var : (int Misctypes.or_var, int Misctypes.or_var, int) Genarg.genarg_type - val wit_ref : (Prelude.reference, Globnames.global_reference Loc.located Misctypes.or_var, Globnames.global_reference) Genarg.genarg_type + val wit_ref : (Libnames.reference, Globnames.global_reference Loc.located Misctypes.or_var, Globnames.global_reference) Genarg.genarg_type val wit_clause_dft_concl : (Names.Id.t Loc.located Locus.clause_expr,Names.Id.t Loc.located Locus.clause_expr,Names.Id.t Locus.clause_expr) Genarg.genarg_type val wit_uconstr : (Constrexpr.constr_expr , Tactypes.glob_constr_and_expr, Glob_term.closed_glob_constr) Genarg.genarg_type val wit_red_expr : - ((Constrexpr.constr_expr,Prelude.reference Misctypes.or_by_notation,Constrexpr.constr_expr) Genredexpr.red_expr_gen, + ((Constrexpr.constr_expr,Libnames.reference Misctypes.or_by_notation,Constrexpr.constr_expr) Genredexpr.red_expr_gen, (Tactypes.glob_constr_and_expr,Names.evaluable_global_reference Misctypes.and_short_name Misctypes.or_var,Tactypes.glob_constr_pattern_and_expr) Genredexpr.red_expr_gen, (EConstr.constr,Names.evaluable_global_reference,Pattern.constr_pattern) Genredexpr.red_expr_gen) Genarg.genarg_type val wit_quant_hyp : Misctypes.quantified_hypothesis Genarg.uniform_genarg_type @@ -3153,94 +4142,105 @@ sig val wit_quantified_hypothesis : Misctypes.quantified_hypothesis Genarg.uniform_genarg_type val wit_clause : (Names.Id.t Loc.located Locus.clause_expr,Names.Id.t Loc.located Locus.clause_expr,Names.Id.t Locus.clause_expr) Genarg.genarg_type val wit_preident : string Genarg.uniform_genarg_type - val wit_reference : (Prelude.reference, Globnames.global_reference Loc.located Misctypes.or_var, Globnames.global_reference) Genarg.genarg_type + val wit_reference : (Libnames.reference, Globnames.global_reference Loc.located Misctypes.or_var, Globnames.global_reference) Genarg.genarg_type val wit_open_constr_with_bindings : (Constrexpr.constr_expr Misctypes.with_bindings, Tactypes.glob_constr_and_expr Misctypes.with_bindings, EConstr.constr Misctypes.with_bindings Tactypes.delayed_open) Genarg.genarg_type end -module Coqlib : +module Constrexpr_ops : sig - type coq_eq_data = Coqlib.coq_eq_data = { eq : Globnames.global_reference; - ind : Globnames.global_reference; - refl : Globnames.global_reference; - sym : Globnames.global_reference; - trans: Globnames.global_reference; - congr: Globnames.global_reference; - } - type coq_sigma_data = Coqlib.coq_sigma_data = { - proj1 : Globnames.global_reference; - proj2 : Globnames.global_reference; - elim : Globnames.global_reference; - intro : Globnames.global_reference; - typ : Globnames.global_reference } - val gen_reference : string -> string list -> string -> Globnames.global_reference - val find_reference : string -> string list -> string -> Globnames.global_reference - val check_required_library : string list -> unit - val logic_module_name : string list - val glob_true : Globnames.global_reference - val glob_false : Globnames.global_reference - val glob_O : Globnames.global_reference - val glob_S : Globnames.global_reference - val nat_path : Libnames.full_path - val datatypes_module_name : string list - val glob_eq : Globnames.global_reference - val build_coq_eq_sym : Globnames.global_reference Util.delayed - val build_coq_False : Globnames.global_reference Util.delayed - val build_coq_not : Globnames.global_reference Util.delayed - val build_coq_eq : Globnames.global_reference Util.delayed - val build_coq_eq_data : coq_eq_data Util.delayed - val path_of_O : Names.constructor - val path_of_S : Names.constructor - val build_prod : coq_sigma_data Util.delayed - val build_coq_True : Globnames.global_reference Util.delayed - val coq_iff_ref : Globnames.global_reference lazy_t - val build_coq_iff_left_proj : Globnames.global_reference Util.delayed - val build_coq_iff_right_proj : Globnames.global_reference Util.delayed - val init_modules : string list list - val build_coq_eq_refl : Globnames.global_reference Util.delayed - val arith_modules : string list list - val zarith_base_modules : string list list - val gen_reference_in_modules : string -> string list list-> string -> Globnames.global_reference - val jmeq_module_name : string list - val coq_eq_ref : Globnames.global_reference lazy_t - val coq_not_ref : Globnames.global_reference lazy_t - val coq_or_ref : Globnames.global_reference lazy_t - val build_coq_and : Globnames.global_reference Util.delayed - val build_coq_I : Globnames.global_reference Util.delayed - val coq_reference : string -> string list -> string -> Globnames.global_reference + val mkIdentC : Names.Id.t -> Constrexpr.constr_expr + val mkAppC : Constrexpr.constr_expr * Constrexpr.constr_expr list -> Constrexpr.constr_expr + val names_of_local_assums : Constrexpr.local_binder_expr list -> Names.Name.t Loc.located list + val coerce_reference_to_id : Libnames.reference -> Names.Id.t + val coerce_to_id : Constrexpr.constr_expr -> Names.Id.t Loc.located + val constr_loc : Constrexpr.constr_expr -> Loc.t option + val mkRefC : Libnames.reference -> Constrexpr.constr_expr + val mkLambdaC : Names.Name.t Loc.located list * Constrexpr.binder_kind * Constrexpr.constr_expr * Constrexpr.constr_expr -> Constrexpr.constr_expr + 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 end -module Impargs : +module Notation_ops : sig - type implicit_status = Impargs.implicit_status - type implicit_side_condition = Impargs.implicit_side_condition - type implicits_list = implicit_side_condition * implicit_status list - type manual_explicitation = Constrexpr.explicitation * (bool * bool * bool) - type manual_implicits = manual_explicitation list - val is_status_implicit : implicit_status -> bool - val name_of_implicit : implicit_status -> Names.Id.t - val implicits_of_global : Globnames.global_reference -> implicits_list list - val declare_manual_implicits : bool -> Globnames.global_reference -> ?enriching:bool -> - manual_implicits list -> unit - val is_implicit_args : unit -> bool - val is_strict_implicit_args : unit -> bool - val is_contextual_implicit_args : unit -> bool - val make_implicit_args : bool -> unit - val make_strict_implicit_args : bool -> unit - val make_contextual_implicit_args : bool -> unit + val glob_constr_of_notation_constr : ?loc:Loc.t -> Notation_term.notation_constr -> Glob_term.glob_constr + val glob_constr_of_notation_constr_with_binders : ?loc:Loc.t -> + ('a -> Names.Name.t -> 'a * Names.Name.t) -> + ('a -> Notation_term.notation_constr -> Glob_term.glob_constr) -> + 'a -> Notation_term.notation_constr -> Glob_term.glob_constr +end + +module Ppextend : +sig + + type precedence = int + type parenRelation = + | L | E | Any | Prec of precedence + type tolerability = precedence * parenRelation + +end + +module Notation : +sig + type cases_pattern_status = bool + type required_module = Libnames.full_path * string list + type 'a prim_token_interpreter = ?loc:Loc.t -> 'a -> Glob_term.glob_constr + type 'a prim_token_uninterpreter = Glob_term.glob_constr list * (Glob_term.glob_constr -> 'a option) * cases_pattern_status + type delimiters = string + type local_scopes = Notation_term.tmp_scope_name option * Notation_term.scope_name list + type notation_location = (Names.DirPath.t * Names.DirPath.t) * string + val declare_string_interpreter : Notation_term.scope_name -> required_module -> + string prim_token_interpreter -> string prim_token_uninterpreter -> unit + val declare_numeral_interpreter : Notation_term.scope_name -> required_module -> + Bigint.bigint prim_token_interpreter -> Bigint.bigint prim_token_uninterpreter -> unit + val interp_notation_as_global_reference : ?loc:Loc.t -> (Globnames.global_reference -> bool) -> + Constrexpr.notation -> delimiters option -> Globnames.global_reference + val locate_notation : (Glob_term.glob_constr -> Pp.t) -> Constrexpr.notation -> + Notation_term.scope_name option -> Pp.t + val find_delimiters_scope : ?loc:Loc.t -> delimiters -> Notation_term.scope_name + val pr_scope : (Glob_term.glob_constr -> Pp.t) -> Notation_term.scope_name -> Pp.t + val pr_scopes : (Glob_term.glob_constr -> Pp.t) -> Pp.t + val interp_notation : ?loc:Loc.t -> Constrexpr.notation -> local_scopes -> + Notation_term.interpretation * (notation_location * Notation_term.scope_name option) + val uninterp_prim_token : Glob_term.glob_constr -> Notation_term.scope_name * Constrexpr.prim_token +end + +module Dumpglob : +sig + val add_glob : ?loc:Loc.t -> Globnames.global_reference -> unit + val pause : unit -> unit + val continue : unit -> unit +end + +module Smartlocate : +sig + val locate_global_with_alias : ?head:bool -> Libnames.qualid Loc.located -> Globnames.global_reference + val global_with_alias : ?head:bool -> Libnames.reference -> Globnames.global_reference + val global_of_extended_global : Globnames.extended_global_reference -> Globnames.global_reference + val loc_of_smart_reference : Libnames.reference Misctypes.or_by_notation -> Loc.t option + val smart_global : ?head:bool -> Libnames.reference Misctypes.or_by_notation -> Globnames.global_reference +end + +module Topconstr : +sig + val replace_vars_constr_expr : + Names.Id.t Names.Id.Map.t -> Constrexpr.constr_expr -> Constrexpr.constr_expr end module Constrintern : sig - type ltac_sign = Constrintern.ltac_sign = { - ltac_vars : Names.Id.Set.t; - ltac_bound : Names.Id.Set.t; - ltac_extra : Genintern.Store.t; - } - type var_internalization_data = Constrintern.var_internalization_data - type var_internalization_type = Constrintern.var_internalization_type = + type ltac_sign = { + ltac_vars : Names.Id.Set.t; + ltac_bound : Names.Id.Set.t; + ltac_extra : Genintern.Store.t; + } + + type var_internalization_data + + type var_internalization_type = | Inductive of Names.Id.t list * bool | Recursive | Method @@ -3262,9 +4262,9 @@ sig Constrexpr.constr_pattern_expr -> Names.Id.t list * Pattern.constr_pattern val intern_constr : Environ.env -> Constrexpr.constr_expr -> Glob_term.glob_constr val for_grammar : ('a -> 'b) -> 'a -> 'b - val interp_reference : ltac_sign -> Prelude.reference -> Glob_term.glob_constr + val interp_reference : ltac_sign -> Libnames.reference -> Glob_term.glob_constr val interp_constr : Environ.env -> Evd.evar_map -> ?impls:internalization_env -> - Constrexpr.constr_expr -> Term.constr Evd.in_evar_universe_context + Constrexpr.constr_expr -> Constr.t Evd.in_evar_universe_context 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 -> @@ -3279,168 +4279,160 @@ sig val global_reference : Names.Id.t -> Globnames.global_reference end -module Notation_term : -sig - type scope_name = string - type notation_var_instance_type = Notation_term.notation_var_instance_type = - | NtnTypeConstr | NtnTypeOnlyBinder | NtnTypeConstrList | NtnTypeBinderList - type tmp_scope_name = Notation_term.tmp_scope_name - type subscopes = tmp_scope_name option * scope_name list - type notation_constr = Notation_term.notation_constr = - | NRef of Globnames.global_reference - | NVar of Names.Id.t - | NApp of notation_constr * notation_constr list - | NHole of Evar_kinds.t * Misctypes.intro_pattern_naming_expr * Genarg.glob_generic_argument option - | NList of Names.Id.t * Names.Id.t * notation_constr * notation_constr * bool - | NLambda of Names.Name.t * notation_constr * notation_constr - | 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 * - (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) * - notation_constr * notation_constr - | NIf of notation_constr * (Names.Name.t * notation_constr option) * - notation_constr * notation_constr - | NRec of Glob_term.fix_kind * Names.Id.t array * - (Names.Name.t * notation_constr option * notation_constr) list array * - notation_constr array * notation_constr array - | NSort of Misctypes.glob_sort - | NCast of notation_constr * notation_constr Misctypes.cast_type - type interpretation = (Names.Id.t * (subscopes * notation_var_instance_type)) list * - notation_constr -end - -module Notation : -sig - type cases_pattern_status = bool - type required_module = Libnames.full_path * string list - type 'a prim_token_interpreter = ?loc:Loc.t -> 'a -> Glob_term.glob_constr - type 'a prim_token_uninterpreter = Glob_term.glob_constr list * (Glob_term.glob_constr -> 'a option) * cases_pattern_status - type delimiters = string - type local_scopes = Notation_term.tmp_scope_name option * Notation_term.scope_name list - type notation_location = (Names.DirPath.t * Names.DirPath.t) * string - val declare_string_interpreter : Notation_term.scope_name -> required_module -> - string prim_token_interpreter -> string prim_token_uninterpreter -> unit - val declare_numeral_interpreter : Notation_term.scope_name -> required_module -> - Bigint.bigint prim_token_interpreter -> Bigint.bigint prim_token_uninterpreter -> unit - val interp_notation_as_global_reference : ?loc:Loc.t -> (Globnames.global_reference -> bool) -> - Constrexpr.notation -> delimiters option -> Globnames.global_reference - val locate_notation : (Glob_term.glob_constr -> Pp.std_ppcmds) -> Constrexpr.notation -> - Notation_term.scope_name option -> Pp.std_ppcmds - val find_delimiters_scope : ?loc:Loc.t -> delimiters -> Notation_term.scope_name - val pr_scope : (Glob_term.glob_constr -> Pp.std_ppcmds) -> Notation_term.scope_name -> Pp.std_ppcmds - val pr_scopes : (Glob_term.glob_constr -> Pp.std_ppcmds) -> Pp.std_ppcmds - val interp_notation : ?loc:Loc.t -> Constrexpr.notation -> local_scopes -> - Notation_term.interpretation * (notation_location * Notation_term.scope_name option) - val uninterp_prim_token : Glob_term.glob_constr -> Notation_term.scope_name * Constrexpr.prim_token -end - -module Mltop : +module Constrextern : sig - val declare_cache_obj : (unit -> unit) -> string -> unit - val add_known_plugin : (unit -> unit) -> string -> unit - val add_known_module : string -> unit - val module_is_known : string -> bool + val extern_glob_constr : Names.Id.Set.t -> Glob_term.glob_constr -> Constrexpr.constr_expr + val extern_glob_type : Names.Id.Set.t -> Glob_term.glob_constr -> Constrexpr.constr_expr + val extern_constr : ?lax:bool -> bool -> Environ.env -> Evd.evar_map -> Constr.t -> Constrexpr.constr_expr + val without_symbols : ('a -> 'b) -> 'a -> 'b + val print_universes : bool ref + val extern_type : bool -> Environ.env -> Evd.evar_map -> Term.types -> Constrexpr.constr_expr + val with_universes : ('a -> 'b) -> 'a -> 'b + val set_extern_reference : + (?loc:Loc.t -> Names.Id.Set.t -> Globnames.global_reference -> Libnames.reference) -> unit end -module Redexpr : +module Declare : sig - type red_expr = - (EConstr.constr, Names.evaluable_global_reference, Pattern.constr_pattern) Genredexpr.red_expr_gen - val reduction_of_red_expr : - Environ.env -> red_expr -> Reductionops.e_reduction_function * Term.cast_kind - val declare_reduction : string -> Reductionops.reduction_function -> unit -end + type internal_flag = + | UserAutomaticRequest + | InternalTacticRequest + | UserIndividualRequest -module Tacmach : -sig - type tactic = Goal.goal Evd.sigma -> Goal.goal list Evd.sigma + type constant_declaration = Safe_typing.private_constants Entries.constant_entry * Decl_kinds.logical_kind - type 'a sigma = 'a Evd.sigma - [@@ocaml.deprecated "alias of API.Evd.sigma"] + 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 - val re_sig : 'a -> Evd.evar_map -> 'a Evd.sigma + type variable_declaration = Names.DirPath.t * section_variable_entry * Decl_kinds.logical_kind - val pf_reduction_of_red_expr : Goal.goal Evd.sigma -> Redexpr.red_expr -> EConstr.constr -> Evd.evar_map * EConstr.constr + val declare_constant : + ?internal:internal_flag -> ?local:bool -> Names.Id.t -> ?export_seff:bool -> constant_declaration -> Names.Constant.t - val pf_unsafe_type_of : Goal.goal Evd.sigma -> EConstr.constr -> EConstr.types + val declare_universe_context : Decl_kinds.polymorphic -> Univ.ContextSet.t -> unit - val pf_get_new_id : Names.Id.t -> Goal.goal Evd.sigma -> Names.Id.t + val declare_definition : + ?internal:internal_flag -> ?opaque:bool -> ?kind:Decl_kinds.definition_object_kind -> + ?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 -> + ?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 + val declare_variable : Names.Id.t -> variable_declaration -> Libnames.object_name +end - val pf_env : Goal.goal Evd.sigma -> Environ.env +(************************************************************************) +(* End of modules from interp/ *) +(************************************************************************) - val pf_concl : Goal.goal Evd.sigma -> EConstr.types +(************************************************************************) +(* Modules from proofs/ *) +(************************************************************************) - val pf_apply : (Environ.env -> Evd.evar_map -> 'a) -> Goal.goal Evd.sigma -> 'a +module Miscprint : +sig + val pr_or_and_intro_pattern : + ('a -> Pp.t) -> 'a Misctypes.or_and_intro_pattern_expr -> Pp.t + val pr_intro_pattern_naming : Misctypes.intro_pattern_naming_expr -> Pp.t + val pr_intro_pattern : + ('a -> Pp.t) -> 'a Misctypes.intro_pattern_expr Loc.located -> Pp.t + val pr_bindings : + ('a -> Pp.t) -> + ('a -> Pp.t) -> 'a Misctypes.bindings -> Pp.t + val pr_bindings_no_with : + ('a -> Pp.t) -> + ('a -> Pp.t) -> 'a Misctypes.bindings -> Pp.t + val pr_with_bindings : + ('a -> Pp.t) -> + ('a -> Pp.t) -> 'a * 'a Misctypes.bindings -> Pp.t +end - val pf_get_hyp : Goal.goal Evd.sigma -> Names.Id.t -> EConstr.named_declaration - val pf_get_hyp_typ : Goal.goal Evd.sigma -> Names.Id.t -> EConstr.types - val project : Goal.goal Evd.sigma -> Evd.evar_map - val refine : EConstr.constr -> tactic - val refine_no_check : EConstr.constr -> tactic - val pf_type_of : Goal.goal Evd.sigma -> EConstr.constr -> Evd.evar_map * EConstr.types +(* All items in the Goal modules are deprecated. *) +module Goal : +sig + type goal = Evar.t - val pf_hyps : Goal.goal Evd.sigma -> EConstr.named_context + val pr_goal : goal -> Pp.t - val pf_ids_of_hyps : Goal.goal Evd.sigma -> Names.Id.t list + module V82 : + sig + val new_goal_with : Evd.evar_map -> goal -> Context.Named.t -> goal Evd.sigma - val pf_reduce_to_atomic_ind : Goal.goal Evd.sigma -> EConstr.types -> (Names.inductive * EConstr.EInstance.t) * EConstr.types + val nf_hyps : Evd.evar_map -> goal -> Environ.named_context_val - val pf_reduce_to_quantified_ind : Goal.goal Evd.sigma -> EConstr.types -> (Names.inductive * EConstr.EInstance.t) * EConstr.types + val env : Evd.evar_map -> goal -> Environ.env - val pf_eapply : (Environ.env -> Evd.evar_map -> 'a -> Evd.evar_map * 'b) -> - Evar.t Evd.sigma -> 'a -> Evar.t Evd.sigma * 'b + val concl : Evd.evar_map -> goal -> EConstr.constr - val pf_unfoldn : (Locus.occurrences * Names.evaluable_global_reference) list - -> Goal.goal Evd.sigma -> EConstr.constr -> EConstr.constr + val mk_goal : Evd.evar_map -> + Environ.named_context_val -> + EConstr.constr -> + Evd.Store.t -> + goal * EConstr.constr * Evd.evar_map - val pf_reduce : (Environ.env -> Evd.evar_map -> EConstr.constr -> EConstr.constr) -> Goal.goal Evd.sigma -> EConstr.constr -> EConstr.constr + val extra : Evd.evar_map -> goal -> Evd.Store.t - val pf_conv_x : Goal.goal Evd.sigma -> EConstr.constr -> EConstr.constr -> bool + val partial_solution_to : Evd.evar_map -> goal -> goal -> EConstr.constr -> Evd.evar_map - val pf_is_matching : Goal.goal Evd.sigma -> Pattern.constr_pattern -> EConstr.constr -> bool + val partial_solution : Evd.evar_map -> goal -> EConstr.constr -> Evd.evar_map - val pf_hyps_types : Goal.goal Evd.sigma -> (Names.Id.t * EConstr.types) list + val hyps : Evd.evar_map -> goal -> Environ.named_context_val - val pr_gls : Goal.goal Evd.sigma -> Pp.std_ppcmds + val abstract_type : Evd.evar_map -> goal -> EConstr.types + end +end - val pf_nf_betaiota : Goal.goal Evd.sigma -> EConstr.constr -> EConstr.constr +module Evar_refiner : +sig + val w_refine : Evar.t * Evd.evar_info -> + Pretyping.glob_constr_ltac_closure -> Evd.evar_map -> Evd.evar_map +end - val pf_last_hyp : Goal.goal Evd.sigma -> EConstr.named_declaration - val pf_nth_hyp_id : Goal.goal Evd.sigma -> int -> Names.Id.t +module Proof_type : +sig + type prim_rule = + | Cut of bool * bool * Names.Id.t * Term.types + | Refine of Constr.t - val sig_it : 'a Evd.sigma -> 'a + type tactic = Goal.goal Evd.sigma -> Goal.goal list Evd.sigma +end - module New : - sig - val pf_apply : (Environ.env -> Evd.evar_map -> 'a) -> 'b Proofview.Goal.t -> 'a - val project : 'a Proofview.Goal.t -> Evd.evar_map - val pf_unsafe_type_of : 'a Proofview.Goal.t -> EConstr.constr -> EConstr.types - val of_old : (Goal.goal Evd.sigma -> 'a) -> [ `NF ] Proofview.Goal.t -> 'a +module Logic : +sig + type refiner_error = + | BadType of Constr.t * Constr.t * Constr.t + | UnresolvedBindings of Names.Name.t list + | CannotApply of Constr.t * Constr.t + | NotWellTyped of Constr.t + | NonLinearProof of Constr.t + | MetaInType of EConstr.constr + | IntroNeedsProduct + | DoesNotOccurIn of Constr.t * Names.Id.t + | NoSuchHyp of Names.Id.t + exception RefinerError of refiner_error + val catchable_exception : exn -> bool +end - val pf_env : 'a Proofview.Goal.t -> Environ.env - val pf_ids_of_hyps : 'a Proofview.Goal.t -> Names.Id.t list - val pf_concl : 'a Proofview.Goal.t -> EConstr.types - val pf_get_new_id : Names.Id.t -> 'a Proofview.Goal.t -> Names.Id.t - val pf_get_hyp_typ : Names.Id.t -> 'a Proofview.Goal.t -> EConstr.types - val pf_get_type_of : 'a Proofview.Goal.t -> EConstr.constr -> EConstr.types - val pf_global : Names.Id.t -> 'a Proofview.Goal.t -> Globnames.global_reference - val pf_hyps_types : 'a Proofview.Goal.t -> (Names.Id.t * EConstr.types) list - end +module Refine : +sig + val refine : typecheck:bool -> (Evd.evar_map -> Evd.evar_map * EConstr.t) -> unit Proofview.tactic + val solve_constraints : unit Proofview.tactic end module Proof : sig - type proof = Proof.proof - type 'a focus_kind = 'a Proof.focus_kind + type proof + type 'a focus_kind + 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.std_ppcmds + val pr_proof : proof -> Pp.t module V82 : sig val grab_evars : proof -> proof @@ -3456,28 +4448,31 @@ end module Proof_global : sig - type proof_mode = Proof_global.proof_mode = { + type proof_mode = { name : string; set : unit -> unit ; reset : unit -> unit } type proof_universes = UState.t * Universes.universe_binders option - type proof_object = Proof_global.proof_object = { - id : Names.Id.t; - entries : Safe_typing.private_constants Entries.definition_entry list; - persistence : Decl_kinds.goal_kind; - universes: proof_universes; - } - type proof_ending = Proof_global.proof_ending = + type proof_object = { + id : Names.Id.t; + entries : Safe_typing.private_constants Entries.definition_entry list; + persistence : Decl_kinds.goal_kind; + universes: proof_universes; + } + + type proof_ending = | Admitted of Names.Id.t * Decl_kinds.goal_kind * Entries.parameter_entry * proof_universes | Proved of Vernacexpr.opacity_flag * Vernacexpr.lident option * proof_object - type proof_terminator = Proof_global.proof_terminator - type lemma_possible_guards = Proof_global.lemma_possible_guards - type universe_binders = Proof_global.universe_binders + + type proof_terminator + type lemma_possible_guards + type universe_binders type closed_proof = proof_object * proof_terminator + val make_terminator : (proof_ending -> unit) -> proof_terminator val start_dependent_proof : Names.Id.t -> ?pl:universe_binders -> Decl_kinds.goal_kind -> @@ -3498,490 +4493,560 @@ sig val get_current_proof_name : unit -> Names.Id.t end -module Nametab : -sig - exception GlobalizationError of Libnames.qualid - - type ltac_constant = Names.KerName.t - - val global : Libnames.reference -> Globnames.global_reference - val global_of_path : Libnames.full_path -> Globnames.global_reference - val shortest_qualid_of_global : Names.Id.Set.t -> Globnames.global_reference -> Libnames.qualid - val path_of_global : Globnames.global_reference -> Libnames.full_path - val locate_extended : Libnames.qualid -> Globnames.extended_global_reference - val full_name_module : Libnames.qualid -> Names.DirPath.t - val locate_tactic : Libnames.qualid -> Names.KerName.t - val pr_global_env : Names.Id.Set.t -> Globnames.global_reference -> Pp.std_ppcmds - val shortest_qualid_of_tactic : Names.KerName.t -> Libnames.qualid - val basename_of_global : Globnames.global_reference -> Names.Id.t - - type visibility = Nametab.visibility = - | Until of int - | Exactly of int - - val push_tactic : visibility -> Libnames.full_path -> Names.KerName.t -> unit - val error_global_not_found : ?loc:Loc.t -> Libnames.qualid -> 'a - val shortest_qualid_of_module : Names.ModPath.t -> Libnames.qualid - val dirpath_of_module : Names.ModPath.t -> Names.DirPath.t - val locate_module : Libnames.qualid -> Names.ModPath.t - val dirpath_of_global : Globnames.global_reference -> Names.DirPath.t - val locate : Libnames.qualid -> Globnames.global_reference - val locate_constant : Libnames.qualid -> Names.Constant.t -end - -module Ppextend : +module Redexpr : sig - type precedence = int - type parenRelation = Ppextend.parenRelation = - | L | E | Any | Prec of precedence - type tolerability = precedence * parenRelation + type red_expr = + (EConstr.constr, Names.evaluable_global_reference, Pattern.constr_pattern) Genredexpr.red_expr_gen + val reduction_of_red_expr : + Environ.env -> red_expr -> Reductionops.e_reduction_function * Constr.cast_kind + val declare_reduction : string -> Reductionops.reduction_function -> unit end module Refiner : sig val project : 'a Evd.sigma -> Evd.evar_map - + val unpackage : 'a Evd.sigma -> Evd.evar_map ref * 'a val repackage : Evd.evar_map ref -> 'a -> 'a Evd.sigma - val tclSHOWHYPS : Tacmach.tactic -> Tacmach.tactic - exception FailError of int * Pp.std_ppcmds Lazy.t + val tclSHOWHYPS : Proof_type.tactic -> Proof_type.tactic + exception FailError of int * Pp.t Lazy.t - val tclEVARS : Evd.evar_map -> Tacmach.tactic - val tclMAP : ('a -> Tacmach.tactic) -> 'a list -> Tacmach.tactic - val tclREPEAT : Tacmach.tactic -> Tacmach.tactic - val tclORELSE : Tacmach.tactic -> Tacmach.tactic -> Tacmach.tactic - val tclFAIL : int -> Pp.std_ppcmds -> Tacmach.tactic - val tclIDTAC : Tacmach.tactic - val tclTHEN : Tacmach.tactic -> Tacmach.tactic -> Tacmach.tactic - val tclTHENLIST : Tacmach.tactic list -> Tacmach.tactic - val tclTRY : Tacmach.tactic -> Tacmach.tactic - val tclAT_LEAST_ONCE : Tacmach.tactic -> Tacmach.tactic + val tclEVARS : Evd.evar_map -> Proof_type.tactic + val tclMAP : ('a -> Proof_type.tactic) -> 'a list -> Proof_type.tactic + val tclREPEAT : Proof_type.tactic -> Proof_type.tactic + val tclORELSE : Proof_type.tactic -> Proof_type.tactic -> Proof_type.tactic + val tclFAIL : int -> Pp.t -> Proof_type.tactic + val tclIDTAC : Proof_type.tactic + val tclTHEN : Proof_type.tactic -> Proof_type.tactic -> Proof_type.tactic + val tclTHENLIST : Proof_type.tactic list -> Proof_type.tactic + val tclTRY : Proof_type.tactic -> Proof_type.tactic + val tclAT_LEAST_ONCE : Proof_type.tactic -> Proof_type.tactic end -module Termops : +module Tacmach : sig - val it_mkLambda_or_LetIn : Term.constr -> Context.Rel.t -> Term.constr - val local_occur_var : Evd.evar_map -> Names.Id.t -> EConstr.constr -> bool - val occur_var : Environ.env -> Evd.evar_map -> Names.Id.t -> EConstr.constr -> bool - val pr_evar_info : Evd.evar_info -> Pp.std_ppcmds - val print_constr : EConstr.constr -> Pp.std_ppcmds + type tactic = Proof_type.tactic - (** [dependent m t] tests whether [m] is a subterm of [t] *) - val dependent : Prelude.evar_map -> EConstr.constr -> EConstr.constr -> bool + type 'a sigma = 'a Evd.sigma + [@@ocaml.deprecated "alias of API.Evd.sigma"] - (** [pop c] returns a copy of [c] with decremented De Bruijn indexes *) - val pop : EConstr.constr -> EConstr.constr + val re_sig : 'a -> Evd.evar_map -> 'a Evd.sigma - (** Does a given term contain an existential variable? *) - val occur_existential : Prelude.evar_map -> EConstr.constr -> bool + val pf_reduction_of_red_expr : Goal.goal Evd.sigma -> Redexpr.red_expr -> EConstr.constr -> Evd.evar_map * EConstr.constr - (** [map_constr_with_binders_left_to_right g f acc c] maps [f updated_acc] on all the immediate subterms of [c]. - {ul {- if a given immediate subterm of [c] is not below a binder, then [updated_acc] is the same as [acc].} - {- if a given immediate subterm of [c] is below a binder [b], then [updated_acc] is computed as [g b acc].}} *) - val map_constr_with_binders_left_to_right : - Prelude.evar_map -> (EConstr.rel_declaration -> 'a -> 'a) -> ('a -> EConstr.constr -> EConstr.constr) -> 'a -> EConstr.constr -> EConstr.constr + val pf_unsafe_type_of : Goal.goal Evd.sigma -> EConstr.constr -> EConstr.types - (** Remove the outer-most {!Term.kind_of_term.Cast} from a given term. *) - val strip_outer_cast : Prelude.evar_map -> EConstr.constr -> EConstr.constr + val pf_get_new_id : Names.Id.t -> Goal.goal Evd.sigma -> Names.Id.t - (** [nb_lam] โฆ[fun (x1:t1)...(xn:tn) => c]โง where [c] is not an abstraction gives [n]. - Casts are ignored. *) - val nb_lam : Prelude.evar_map -> EConstr.constr -> int + val pf_env : Goal.goal Evd.sigma -> Environ.env - (** [push_rel_assum env_assumtion env] adds a given {i env assumption} to the {i env context} of a given {i environment}. *) - val push_rel_assum : Names.Name.t * EConstr.types -> Environ.env -> Environ.env + val pf_concl : Goal.goal Evd.sigma -> EConstr.types - (** [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 pf_apply : (Environ.env -> Evd.evar_map -> 'a) -> Goal.goal Evd.sigma -> 'a - type meta_value_map = Prelude.meta_value_map + val pf_get_hyp : Goal.goal Evd.sigma -> Names.Id.t -> EConstr.named_declaration + val pf_get_hyp_typ : Goal.goal Evd.sigma -> Names.Id.t -> EConstr.types + val project : Goal.goal Evd.sigma -> Evd.evar_map + val refine : EConstr.constr -> Proof_type.tactic + val refine_no_check : EConstr.constr -> Proof_type.tactic + val pf_type_of : Goal.goal Evd.sigma -> EConstr.constr -> Evd.evar_map * EConstr.types - val last_arg : Evd.evar_map -> EConstr.constr -> EConstr.constr - val assums_of_rel_context : ('c, 't) Context.Rel.pt -> (Names.Name.t * 't) list - val prod_applist : Evd.evar_map -> EConstr.constr -> EConstr.constr list -> EConstr.constr - val nb_prod : Evd.evar_map -> EConstr.constr -> int - val is_section_variable : Names.Id.t -> bool - val ids_of_rel_context : ('c, 't) Context.Rel.pt -> Names.Id.t list - val subst_term : Evd.evar_map -> EConstr.constr -> EConstr.constr -> EConstr.constr - val global_vars_set_of_decl : Environ.env -> Evd.evar_map -> EConstr.named_declaration -> Names.Id.Set.t - val vars_of_env: Environ.env -> Names.Id.Set.t - val ids_of_named_context : ('c, 't) Context.Named.pt -> Names.Id.t list - val ids_of_context : Environ.env -> Names.Id.t list - val global_of_constr : Evd.evar_map -> EConstr.constr -> Globnames.global_reference * EConstr.EInstance.t - val print_named_context : Environ.env -> Pp.std_ppcmds - val print_constr_env : Environ.env -> Evd.evar_map -> EConstr.constr -> Pp.std_ppcmds - val clear_named_body : Names.Id.t -> Environ.env -> Environ.env - val is_Prop : Evd.evar_map -> EConstr.constr -> bool - val is_global : Evd.evar_map -> Globnames.global_reference -> EConstr.constr -> bool + val pf_hyps : Goal.goal Evd.sigma -> EConstr.named_context - val eq_constr : Evd.evar_map -> EConstr.constr -> EConstr.constr -> bool + val pf_ids_of_hyps : Goal.goal Evd.sigma -> Names.Id.t list - val occur_var_in_decl : - Environ.env -> Evd.evar_map -> - Names.Id.t -> EConstr.named_declaration -> bool + val pf_reduce_to_atomic_ind : Goal.goal Evd.sigma -> EConstr.types -> (Names.inductive * EConstr.EInstance.t) * EConstr.types - val subst_meta : Prelude.meta_value_map -> Term.constr -> Term.constr + val pf_reduce_to_quantified_ind : Goal.goal Evd.sigma -> EConstr.types -> (Names.inductive * EConstr.EInstance.t) * EConstr.types - val free_rels : Evd.evar_map -> EConstr.constr -> Int.Set.t + val pf_eapply : (Environ.env -> Evd.evar_map -> 'a -> Evd.evar_map * 'b) -> + Evar.t Evd.sigma -> 'a -> Evar.t Evd.sigma * 'b - val occur_term : Evd.evar_map -> EConstr.constr -> EConstr.constr -> bool - [@@ocaml.deprecated "alias of API.Termops.dependent"] + val pf_unfoldn : (Locus.occurrences * Names.evaluable_global_reference) list + -> Goal.goal Evd.sigma -> EConstr.constr -> EConstr.constr - val replace_term : Evd.evar_map -> EConstr.constr -> EConstr.constr -> EConstr.constr -> EConstr.constr - val map_named_decl : ('a -> 'b) -> ('a, 'a) Context.Named.Declaration.pt -> ('b, 'b) Context.Named.Declaration.pt - val map_rel_decl : ('a -> 'b) -> ('a, 'a) Context.Rel.Declaration.pt -> ('b, 'b) Context.Rel.Declaration.pt - val pr_metaset : Evd.Metaset.t -> Pp.std_ppcmds - val pr_evar_map : ?with_univs:bool -> int option -> Evd.evar_map -> Pp.std_ppcmds - val pr_evar_universe_context : UState.t -> Pp.std_ppcmds -end + val pf_reduce : (Environ.env -> Evd.evar_map -> EConstr.constr -> EConstr.constr) -> Goal.goal Evd.sigma -> EConstr.constr -> EConstr.constr -module Locality : -sig - val make_section_locality : bool option -> bool - module LocalityFixme : sig - val consume : unit -> bool option + val pf_conv_x : Goal.goal Evd.sigma -> EConstr.constr -> EConstr.constr -> bool + + val pf_is_matching : Goal.goal Evd.sigma -> Pattern.constr_pattern -> EConstr.constr -> bool + + val pf_hyps_types : Goal.goal Evd.sigma -> (Names.Id.t * EConstr.types) list + + val pr_gls : Goal.goal Evd.sigma -> Pp.t + + val pf_nf_betaiota : Goal.goal Evd.sigma -> EConstr.constr -> EConstr.constr + + val pf_last_hyp : Goal.goal Evd.sigma -> EConstr.named_declaration + + val pf_nth_hyp_id : Goal.goal Evd.sigma -> int -> Names.Id.t + + val sig_it : 'a Evd.sigma -> 'a + + module New : + sig + val pf_apply : (Environ.env -> Evd.evar_map -> 'a) -> 'b Proofview.Goal.t -> 'a + val project : 'a Proofview.Goal.t -> Evd.evar_map + val pf_unsafe_type_of : 'a Proofview.Goal.t -> EConstr.constr -> EConstr.types + val of_old : (Goal.goal Evd.sigma -> 'a) -> [ `NF ] Proofview.Goal.t -> 'a + + val pf_env : 'a Proofview.Goal.t -> Environ.env + val pf_ids_of_hyps : 'a Proofview.Goal.t -> Names.Id.t list + val pf_concl : 'a Proofview.Goal.t -> EConstr.types + val pf_get_new_id : Names.Id.t -> 'a Proofview.Goal.t -> Names.Id.t + val pf_get_hyp_typ : Names.Id.t -> 'a Proofview.Goal.t -> EConstr.types + val pf_get_type_of : 'a Proofview.Goal.t -> EConstr.constr -> EConstr.types + val pf_global : Names.Id.t -> 'a Proofview.Goal.t -> Globnames.global_reference + val pf_hyps_types : 'a Proofview.Goal.t -> (Names.Id.t * EConstr.types) list end - val make_module_locality : bool option -> bool end -module Search : +module Pfedit : sig - type glob_search_about_item = Search.glob_search_about_item = - | GlobSearchSubPattern of Pattern.constr_pattern - | GlobSearchString of string - type filter_function = Globnames.global_reference -> Environ.env -> Term.constr -> bool - type display_function = Globnames.global_reference -> Environ.env -> Term.constr -> unit - val search_about_filter : glob_search_about_item -> filter_function - val module_filter : Names.DirPath.t list * bool -> filter_function - val generic_search : int option -> display_function -> unit -end + val solve_by_implicit_tactic : unit -> Pretyping.inference_hook option + val refine_by_tactic : Environ.env -> Evd.evar_map -> EConstr.types -> unit Proofview.tactic -> + Constr.t * Evd.evar_map + val declare_implicit_tactic : unit Proofview.tactic -> unit + val clear_implicit_tactic : unit -> unit + val by : unit Proofview.tactic -> bool + val solve : ?with_end_tac:unit Proofview.tactic -> + Vernacexpr.goal_selector -> int option -> unit Proofview.tactic -> + Proof.proof -> Proof.proof * bool + val cook_proof : + unit -> (Names.Id.t * (Safe_typing.private_constants Entries.definition_entry * Proof_global.proof_universes * Decl_kinds.goal_kind)) -module Notation_ops : -sig - val glob_constr_of_notation_constr : ?loc:Loc.t -> Notation_term.notation_constr -> Glob_term.glob_constr - val glob_constr_of_notation_constr_with_binders : ?loc:Loc.t -> - ('a -> Names.Name.t -> 'a * Names.Name.t) -> - ('a -> Notation_term.notation_constr -> Glob_term.glob_constr) -> - 'a -> Notation_term.notation_constr -> Glob_term.glob_constr -end + val get_current_context : unit -> Evd.evar_map * Environ.env -module Constrextern : -sig - val extern_glob_constr : Names.Id.Set.t -> Glob_term.glob_constr -> Constrexpr.constr_expr - val extern_glob_type : Names.Id.Set.t -> Glob_term.glob_constr -> Constrexpr.constr_expr - val extern_constr : ?lax:bool -> bool -> Environ.env -> Evd.evar_map -> Term.constr -> Constrexpr.constr_expr - val without_symbols : ('a -> 'b) -> 'a -> 'b - val print_universes : bool ref - val extern_type : bool -> Environ.env -> Evd.evar_map -> Term.types -> Constrexpr.constr_expr - val with_universes : ('a -> 'b) -> 'a -> 'b - val set_extern_reference : - (?loc:Loc.t -> Names.Id.Set.t -> Globnames.global_reference -> Libnames.reference) -> unit -end + (* Deprecated *) + val delete_current_proof : unit -> unit + [@@ocaml.deprecated "use Proof_global.discard_current"] -module Patternops : -sig - val pattern_of_glob_constr : Glob_term.glob_constr -> Names.Id.t list * Pattern.constr_pattern - val subst_pattern : Mod_subst.substitution -> Pattern.constr_pattern -> Pattern.constr_pattern - val pattern_of_constr : Environ.env -> Evd.evar_map -> Term.constr -> Pattern.constr_pattern - val instantiate_pattern : Environ.env -> - Evd.evar_map -> Pattern.extended_patvar_map -> - Pattern.constr_pattern -> Pattern.constr_pattern -end + val get_current_proof_name : unit -> Names.Id.t + [@@ocaml.deprecated "use Proof_global.get_current_proof_name"] -module Printer : -sig - val pr_named_context : Environ.env -> Evd.evar_map -> Context.Named.t -> Pp.std_ppcmds - val pr_rel_context : Environ.env -> Evd.evar_map -> Context.Rel.t -> Pp.std_ppcmds - val pr_goal : Goal.goal Evd.sigma -> Pp.std_ppcmds - - val pr_constr_env : Prelude.env -> Prelude.evar_map -> Term.constr -> Pp.std_ppcmds - val pr_lconstr_env : Prelude.env -> Prelude.evar_map -> Term.constr -> Pp.std_ppcmds - - val pr_constr : Term.constr -> Pp.std_ppcmds - - val pr_lconstr : Term.constr -> Pp.std_ppcmds - - val pr_econstr : EConstr.constr -> Pp.std_ppcmds - val pr_glob_constr : Glob_term.glob_constr -> Pp.std_ppcmds - val pr_constr_pattern : Pattern.constr_pattern -> Pp.std_ppcmds - val pr_glob_constr_env : Environ.env -> Glob_term.glob_constr -> Pp.std_ppcmds - val pr_lglob_constr_env : Environ.env -> Glob_term.glob_constr -> Pp.std_ppcmds - val pr_econstr_env : Environ.env -> Evd.evar_map -> EConstr.constr -> Pp.std_ppcmds - val pr_constr_pattern_env : Environ.env -> Evd.evar_map -> Pattern.constr_pattern -> Pp.std_ppcmds - val pr_lconstr_pattern_env : Environ.env -> Evd.evar_map -> Pattern.constr_pattern -> Pp.std_ppcmds - val pr_closed_glob : Glob_term.closed_glob_constr -> Pp.std_ppcmds - val pr_lglob_constr : Glob_term.glob_constr -> Pp.std_ppcmds - val pr_leconstr_env : Environ.env -> Evd.evar_map -> EConstr.constr -> Pp.std_ppcmds - val pr_leconstr : EConstr.constr -> Pp.std_ppcmds - val pr_global : Globnames.global_reference -> Pp.std_ppcmds - val pr_lconstr_under_binders : Pattern.constr_under_binders -> Pp.std_ppcmds - val pr_lconstr_under_binders_env : Environ.env -> Evd.evar_map -> Pattern.constr_under_binders -> Pp.std_ppcmds - - val pr_constr_under_binders_env : Environ.env -> Evd.evar_map -> Pattern.constr_under_binders -> Pp.std_ppcmds - val pr_closed_glob_env : Environ.env -> Evd.evar_map -> Glob_term.closed_glob_constr -> Pp.std_ppcmds - val pr_rel_context_of : Environ.env -> Evd.evar_map -> Pp.std_ppcmds - val pr_named_context_of : Environ.env -> Evd.evar_map -> Pp.std_ppcmds - val pr_ltype : Term.types -> Pp.std_ppcmds - val pr_ljudge : EConstr.unsafe_judgment -> Pp.std_ppcmds * Pp.std_ppcmds - val pr_idpred : Names.Id.Pred.t -> Pp.std_ppcmds - val pr_cpred : Names.Cpred.t -> Pp.std_ppcmds - val pr_transparent_state : Names.transparent_state -> Pp.std_ppcmds + val current_proof_statement : unit -> Names.Id.t * Decl_kinds.goal_kind * EConstr.types end -module Classes : +module Clenv : sig - val set_typeclass_transparency : Names.evaluable_global_reference -> bool -> bool -> unit - val new_instance : - ?abstract:bool -> - ?global:bool -> - ?refine:bool -> - Decl_kinds.polymorphic -> - Constrexpr.local_binder_expr list -> - Constrexpr.typeclass_constraint -> - (bool * Constrexpr.constr_expr) option -> - ?generalize:bool -> - ?tac:unit Proofview.tactic -> - ?hook:(Globnames.global_reference -> unit) -> - Vernacexpr.hint_info_expr -> - Names.Id.t -end -module Classops : -sig - type coe_index = Classops.coe_index - type inheritance_path = coe_index list - type cl_index = Classops.cl_index + type hole = { + hole_evar : EConstr.constr; + hole_type : EConstr.types; + hole_deps : bool; + hole_name : Names.Name.t; + } - val hide_coercion : Globnames.global_reference -> int option - val lookup_path_to_sort_from : Environ.env -> Evd.evar_map -> EConstr.types -> - EConstr.types * inheritance_path - val get_coercion_value : coe_index -> Constr.t - val coercions : unit -> coe_index list - val pr_cl_index : cl_index -> Pp.std_ppcmds -end + type clause = { + cl_holes : hole list; + cl_concl : EConstr.types; + } -module ExplainErr : -sig - val process_vernac_interp_error : ?allow_uncaught:bool -> Util.iexn -> Util.iexn - val register_additional_error_info : (Util.iexn -> Pp.std_ppcmds option Loc.located option) -> unit + val make_evar_clause : Environ.env -> Evd.evar_map -> ?len:int -> EConstr.types -> + (Evd.evar_map * clause) + val solve_evar_clause : Environ.env -> Evd.evar_map -> bool -> clause -> EConstr.constr Misctypes.bindings -> + Evd.evar_map + type clausenv + val pr_clenv : clausenv -> Pp.t end -module Tacred : -sig - val try_red_product : Reductionops.reduction_function - val simpl : Reductionops.reduction_function - val unfoldn : - (Locus.occurrences * Names.evaluable_global_reference) list -> Reductionops.reduction_function - val hnf_constr : Reductionops.reduction_function - val red_product : Reductionops.reduction_function - val is_evaluable : Environ.env -> Names.evaluable_global_reference -> bool - val evaluable_of_global_reference : - Environ.env -> Globnames.global_reference -> Names.evaluable_global_reference - val error_not_evaluable : Globnames.global_reference -> 'a - val reduce_to_quantified_ref : - Environ.env -> Evd.evar_map -> Globnames.global_reference -> EConstr.types -> EConstr.types - val pattern_occs : (Locus.occurrences * EConstr.constr) list -> Reductionops.e_reduction_function - val cbv_norm_flags : CClosure.RedFlags.reds -> Reductionops.reduction_function -end +(************************************************************************) +(* End of modules from proofs/ *) +(************************************************************************) -module Detyping : -sig - val print_universes : bool ref - val print_evar_arguments : bool ref - val detype : ?lax:bool -> bool -> Names.Id.t list -> Environ.env -> Evd.evar_map -> EConstr.constr -> Glob_term.glob_constr - val subst_glob_constr : Mod_subst.substitution -> Glob_term.glob_constr -> Glob_term.glob_constr - val set_detype_anonymous : (?loc:Loc.t -> int -> Glob_term.glob_constr) -> unit -end +(************************************************************************) +(* Modules from parsing/ *) +(************************************************************************) -module Constrexpr_ops : +module Pcoq : sig - val mkIdentC : Names.Id.t -> Constrexpr.constr_expr - val mkAppC : Constrexpr.constr_expr * Constrexpr.constr_expr list -> Constrexpr.constr_expr - val names_of_local_assums : Constrexpr.local_binder_expr list -> Names.Name.t Loc.located list - val coerce_reference_to_id : Prelude.reference -> Names.Id.t - val coerce_to_id : Constrexpr.constr_expr -> Names.Id.t Loc.located - val constr_loc : Constrexpr.constr_expr -> Loc.t option - val mkRefC : Prelude.reference -> Constrexpr.constr_expr - val mkLambdaC : Names.Name.t Loc.located list * Constrexpr.binder_kind * Constrexpr.constr_expr * Constrexpr.constr_expr -> Constrexpr.constr_expr - 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 -end -module Glob_ops : -sig - val map_glob_constr_left_to_right : (Glob_term.glob_constr -> Glob_term.glob_constr) -> Glob_term.glob_constr -> Glob_term.glob_constr - val loc_of_glob_constr : Glob_term.glob_constr -> Loc.t option - val glob_constr_eq : Glob_term.glob_constr -> Glob_term.glob_constr -> bool - val bound_glob_vars : Glob_term.glob_constr -> Names.Id.Set.t + open Loc + open Names + open Extend + open Vernacexpr + open Genarg + open Constrexpr + open Libnames + open Misctypes + open Genredexpr - (** Conversion from glob_constr to cases pattern, if possible + module Gram : sig + include Grammar.S with type te = Tok.t - Take the current alias as parameter, - @raise Not_found if translation is impossible *) - val cases_pattern_of_glob_constr : Names.Name.t -> Glob_term.glob_constr -> Glob_term.cases_pattern - val map_glob_constr : - (Glob_term.glob_constr -> Glob_term.glob_constr) -> Glob_term.glob_constr -> Glob_term.glob_constr - val empty_lvar : Glob_term.ltac_var_map -end + type 'a entry = 'a Entry.e + type internal_entry = Tok.t Gramext.g_entry + type symbol = Tok.t Gramext.g_symbol + type action = Gramext.g_action + type production_rule = symbol list * action + type single_extend_statment = + string option * Gramext.g_assoc option * production_rule list + type extend_statment = + Gramext.position option * single_extend_statment list -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 -> - dep_flag -> Sorts.family -> Evd.evar_map * Term.constr - 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 * Term.constr list - val build_case_analysis_scheme_default : Environ.env -> Evd.evar_map -> Term.pinductive -> - Sorts.family -> Evd.evar_map * Term.constr -end + type coq_parsable + + val parsable : ?file:string -> char Stream.t -> coq_parsable + val action : 'a -> action + val entry_create : string -> 'a entry + val entry_parse : 'a entry -> coq_parsable -> 'a + val entry_print : Format.formatter -> 'a entry -> unit + val with_parsable : coq_parsable -> ('a -> 'b) -> 'a -> 'b + + (* Apparently not used *) + val srules' : production_rule list -> symbol + val parse_tokens_after_filter : 'a entry -> Tok.t Stream.t -> 'a + + end with type 'a Entry.e = 'a Grammar.GMake(CLexer).Entry.e + + val parse_string : 'a Gram.entry -> string -> 'a + val eoi_entry : 'a Gram.entry -> 'a Gram.entry + val map_entry : ('a -> 'b) -> 'a Gram.entry -> 'b Gram.entry + + type gram_universe + + val uprim : gram_universe + val uconstr : gram_universe + val utactic : gram_universe + val uvernac : gram_universe + + val register_grammar : ('raw, 'glb, 'top) genarg_type -> 'raw Gram.entry -> unit + + val genarg_grammar : ('raw, 'glb, 'top) genarg_type -> 'raw Gram.entry + + val create_generic_entry : gram_universe -> string -> + ('a, rlevel) abstract_argument_type -> 'a Gram.entry + + module Prim : + sig + open Names + open Libnames + val preident : string Gram.entry + 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 + val natural : int Gram.entry + val bigint : Constrexpr.raw_natural_number Gram.entry + val integer : int Gram.entry + val string : string Gram.entry + val lstring : string located Gram.entry + val qualid : qualid located Gram.entry + val fullyqualid : Id.t list located Gram.entry + val reference : reference Gram.entry + val by_notation : (string * string option) Loc.located Gram.entry + val smart_global : reference or_by_notation Gram.entry + val dirpath : DirPath.t Gram.entry + val ne_string : string Gram.entry + val ne_lstring : string located Gram.entry + val var : Id.t located Gram.entry + end + + module Constr : + sig + val constr : constr_expr Gram.entry + val constr_eoi : constr_expr Gram.entry + val lconstr : constr_expr Gram.entry + val binder_constr : constr_expr Gram.entry + val operconstr : constr_expr Gram.entry + val ident : Id.t Gram.entry + val global : reference Gram.entry + val universe_level : glob_level Gram.entry + val sort : glob_sort Gram.entry + val pattern : cases_pattern_expr Gram.entry + val constr_pattern : constr_expr Gram.entry + val lconstr_pattern : constr_expr Gram.entry + val closed_binder : local_binder_expr list Gram.entry + val binder : local_binder_expr list Gram.entry (* closed_binder or variable *) + val binders : local_binder_expr list Gram.entry (* list of binder *) + val open_binders : local_binder_expr list Gram.entry + val binders_fixannot : (local_binder_expr list * (Id.t located option * recursion_order_expr)) Gram.entry + val typeclass_constraint : (Name.t located * bool * constr_expr) Gram.entry + val record_declaration : constr_expr Gram.entry + val appl_arg : (constr_expr * explicitation located option) Gram.entry + end + + module Vernac_ : + sig + val gallina : vernac_expr Gram.entry + val gallina_ext : vernac_expr Gram.entry + val command : vernac_expr Gram.entry + val syntax : vernac_expr Gram.entry + val vernac : vernac_expr Gram.entry + val rec_definition : (fixpoint_expr * decl_notation list) Gram.entry + val vernac_eoi : vernac_expr Gram.entry + val noedit_mode : vernac_expr Gram.entry + val command_entry : vernac_expr Gram.entry + val red_expr : raw_red_expr Gram.entry + val hint_info : Vernacexpr.hint_info_expr Gram.entry + end + + val epsilon_value : ('a -> 'self) -> ('self, 'a) Extend.symbol -> 'self option + + val get_command_entry : unit -> vernac_expr Gram.entry + val set_command_entry : vernac_expr Gram.entry -> unit + + type gram_reinit = gram_assoc * gram_position + val grammar_extend : 'a Gram.entry -> gram_reinit option -> + 'a Extend.extend_statment -> unit + + module GramState : Store.S + + type 'a grammar_command + + type extend_rule = + | ExtendRule : 'a Gram.entry * gram_reinit option * 'a extend_statment -> extend_rule + + type 'a grammar_extension = 'a -> GramState.t -> extend_rule list * GramState.t + + val create_grammar_command : string -> 'a grammar_extension -> 'a grammar_command + + val extend_grammar_command : 'a grammar_command -> 'a -> unit + val recover_grammar_command : 'a grammar_command -> 'a list + val with_grammar_rule_protection : ('a -> 'b) -> 'a -> 'b + + val to_coqloc : Ploc.t -> Loc.t + val (!@) : Ploc.t -> Loc.t -module Logic : -sig - type refiner_error = Logic.refiner_error = - | BadType of Term.constr * Term.constr * Term.constr - | UnresolvedBindings of Names.Name.t list - | CannotApply of Term.constr * Term.constr - | NotWellTyped of Term.constr - | NonLinearProof of Term.constr - | MetaInType of EConstr.constr - | IntroNeedsProduct - | DoesNotOccurIn of Term.constr * Names.Id.t - | NoSuchHyp of Names.Id.t - exception RefinerError of refiner_error - val catchable_exception : exn -> bool end -module Himsg : +module Egramml : sig - val explain_refiner_error : Logic.refiner_error -> Pp.std_ppcmds - val explain_pretype_error : Environ.env -> Evd.evar_map -> Pretype_errors.pretype_error -> Pp.std_ppcmds + open Vernacexpr + + type 's grammar_prod_item = + | GramTerminal of string + | GramNonTerminal : ('a Genarg.raw_abstract_argument_type option * + ('s, 'a) Extend.symbol) Loc.located -> 's grammar_prod_item + + val extend_vernac_command_grammar : + extend_name -> vernac_expr Pcoq.Gram.entry option -> + vernac_expr grammar_prod_item list -> unit + + val make_rule : + (Loc.t -> Genarg.raw_generic_argument list -> 'a) -> + 'a grammar_prod_item list -> 'a Extend.production_rule + end -module Extend : +(************************************************************************) +(* End of modules from parsing/ *) +(************************************************************************) + +(************************************************************************) +(* Modules from printing/ *) +(************************************************************************) + +module Genprint : sig - type ('self, 'a) symbol = ('self, 'a) Extend.symbol - type 'a user_symbol = 'a Extend.user_symbol = - | Ulist1 of 'a user_symbol - | Ulist1sep of 'a user_symbol * string - | Ulist0 of 'a user_symbol - | Ulist0sep of 'a user_symbol * string - | Uopt of 'a user_symbol - | Uentry of 'a - | Uentryl of 'a * int + type 'a printer = 'a -> Pp.t + val generic_top_print : Genarg.tlevel Genarg.generic_argument printer + val register_print0 : ('raw, 'glb, 'top) Genarg.genarg_type -> + 'raw printer -> 'glb printer -> 'top printer -> unit end module Pputils : sig - val pr_with_occurrences : ('a -> Pp.std_ppcmds) -> (string -> Pp.std_ppcmds) -> 'a Locus.with_occurrences -> Pp.std_ppcmds + val pr_with_occurrences : ('a -> Pp.t) -> (string -> Pp.t) -> 'a Locus.with_occurrences -> Pp.t val pr_red_expr : - ('a -> Pp.std_ppcmds) * ('a -> Pp.std_ppcmds) * ('b -> Pp.std_ppcmds) * ('c -> Pp.std_ppcmds) -> - (string -> Pp.std_ppcmds) -> - ('a,'b,'c) Genredexpr.red_expr_gen -> Pp.std_ppcmds - val pr_raw_generic : Environ.env -> Genarg.rlevel Genarg.generic_argument -> Pp.std_ppcmds - val pr_glb_generic : Environ.env -> Genarg.glevel Genarg.generic_argument -> Pp.std_ppcmds - val pr_or_var : ('a -> Pp.std_ppcmds) -> 'a Misctypes.or_var -> Pp.std_ppcmds - val pr_or_by_notation : ('a -> Pp.std_ppcmds) -> 'a Misctypes.or_by_notation -> Pp.std_ppcmds + ('a -> Pp.t) * ('a -> Pp.t) * ('b -> Pp.t) * ('c -> Pp.t) -> + (string -> Pp.t) -> + ('a,'b,'c) Genredexpr.red_expr_gen -> Pp.t + val pr_raw_generic : Environ.env -> Genarg.rlevel Genarg.generic_argument -> Pp.t + val pr_glb_generic : Environ.env -> Genarg.glevel Genarg.generic_argument -> Pp.t + val pr_or_var : ('a -> Pp.t) -> 'a Misctypes.or_var -> Pp.t + val pr_or_by_notation : ('a -> Pp.t) -> 'a Misctypes.or_by_notation -> Pp.t end module Ppconstr : sig - val pr_name : Names.Name.t -> Pp.std_ppcmds + val pr_name : Names.Name.t -> Pp.t [@@ocaml.deprecated "alias of API.Names.Name.print"] - val pr_id : Names.Id.t -> Pp.std_ppcmds - val pr_or_var : ('a -> Pp.std_ppcmds) -> 'a Misctypes.or_var -> Pp.std_ppcmds - val pr_with_comments : ?loc:Loc.t -> Pp.std_ppcmds -> Pp.std_ppcmds - val pr_lident : Names.Id.t Loc.located -> Pp.std_ppcmds - val pr_lname : Names.Name.t Loc.located -> Pp.std_ppcmds + val pr_id : Names.Id.t -> Pp.t + val pr_or_var : ('a -> Pp.t) -> 'a Misctypes.or_var -> Pp.t + val pr_with_comments : ?loc:Loc.t -> Pp.t -> Pp.t + val pr_lident : Names.Id.t Loc.located -> Pp.t + val pr_lname : Names.Name.t Loc.located -> Pp.t val prec_less : int -> int * Ppextend.parenRelation -> bool - val pr_constr_expr : Constrexpr.constr_expr -> Pp.std_ppcmds - val pr_lconstr_expr : Constrexpr.constr_expr -> Pp.std_ppcmds - val pr_constr_pattern_expr : Constrexpr.constr_pattern_expr -> Pp.std_ppcmds - val pr_lconstr_pattern_expr : Constrexpr.constr_pattern_expr -> Pp.std_ppcmds - val pr_binders : Constrexpr.local_binder_expr list -> Pp.std_ppcmds - val pr_glob_sort : Misctypes.glob_sort -> Pp.std_ppcmds + val pr_constr_expr : Constrexpr.constr_expr -> Pp.t + val pr_lconstr_expr : Constrexpr.constr_expr -> Pp.t + val pr_constr_pattern_expr : Constrexpr.constr_pattern_expr -> Pp.t + val pr_lconstr_pattern_expr : Constrexpr.constr_pattern_expr -> Pp.t + val pr_binders : Constrexpr.local_binder_expr list -> Pp.t + val pr_glob_sort : Misctypes.glob_sort -> Pp.t end -module Genprint : +module Printer : sig - type 'a printer = 'a -> Pp.std_ppcmds - val generic_top_print : Genarg.tlevel Genarg.generic_argument printer - val register_print0 : ('raw, 'glb, 'top) Genarg.genarg_type -> - 'raw printer -> 'glb printer -> 'top printer -> unit + val pr_named_context : Environ.env -> Evd.evar_map -> Context.Named.t -> Pp.t + val pr_rel_context : Environ.env -> Evd.evar_map -> Context.Rel.t -> Pp.t + val pr_goal : Goal.goal Evd.sigma -> Pp.t + + val pr_constr_env : Environ.env -> Evd.evar_map -> Constr.t -> Pp.t + val pr_lconstr_env : Environ.env -> Evd.evar_map -> Constr.t -> Pp.t + + val pr_constr : Constr.t -> Pp.t + + val pr_lconstr : Constr.t -> Pp.t + + val pr_econstr : EConstr.constr -> Pp.t + val pr_glob_constr : Glob_term.glob_constr -> Pp.t + val pr_constr_pattern : Pattern.constr_pattern -> Pp.t + val pr_glob_constr_env : Environ.env -> Glob_term.glob_constr -> Pp.t + val pr_lglob_constr_env : Environ.env -> Glob_term.glob_constr -> Pp.t + val pr_econstr_env : Environ.env -> Evd.evar_map -> EConstr.constr -> Pp.t + val pr_constr_pattern_env : Environ.env -> Evd.evar_map -> Pattern.constr_pattern -> Pp.t + val pr_lconstr_pattern_env : Environ.env -> Evd.evar_map -> Pattern.constr_pattern -> Pp.t + val pr_closed_glob : Glob_term.closed_glob_constr -> Pp.t + val pr_lglob_constr : Glob_term.glob_constr -> Pp.t + val pr_leconstr_env : Environ.env -> Evd.evar_map -> EConstr.constr -> Pp.t + val pr_leconstr : EConstr.constr -> Pp.t + val pr_global : Globnames.global_reference -> Pp.t + val pr_lconstr_under_binders : Pattern.constr_under_binders -> Pp.t + val pr_lconstr_under_binders_env : Environ.env -> Evd.evar_map -> Pattern.constr_under_binders -> Pp.t + + val pr_constr_under_binders_env : Environ.env -> Evd.evar_map -> Pattern.constr_under_binders -> Pp.t + val pr_closed_glob_env : Environ.env -> Evd.evar_map -> Glob_term.closed_glob_constr -> Pp.t + val pr_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_ljudge : EConstr.unsafe_judgment -> Pp.t * Pp.t + 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 end -module Miscprint : -sig - val pr_or_and_intro_pattern : - ('a -> Pp.std_ppcmds) -> 'a Misctypes.or_and_intro_pattern_expr -> Pp.std_ppcmds - val pr_intro_pattern_naming : Misctypes.intro_pattern_naming_expr -> Pp.std_ppcmds - val pr_intro_pattern : - ('a -> Pp.std_ppcmds) -> 'a Misctypes.intro_pattern_expr Loc.located -> Pp.std_ppcmds - val pr_bindings : - ('a -> Pp.std_ppcmds) -> - ('a -> Pp.std_ppcmds) -> 'a Misctypes.bindings -> Pp.std_ppcmds - val pr_bindings_no_with : - ('a -> Pp.std_ppcmds) -> - ('a -> Pp.std_ppcmds) -> 'a Misctypes.bindings -> Pp.std_ppcmds - val pr_with_bindings : - ('a -> Pp.std_ppcmds) -> - ('a -> Pp.std_ppcmds) -> 'a * 'a Misctypes.bindings -> Pp.std_ppcmds -end +(************************************************************************) +(* End of modules from printing/ *) +(************************************************************************) -module Miscops : -sig - val map_red_expr_gen : ('a -> 'd) -> ('b -> 'e) -> ('c -> 'f) -> - ('a,'b,'c) Genredexpr.red_expr_gen -> ('d,'e,'f) Genredexpr.red_expr_gen - val map_cast_type : ('a -> 'b) -> 'a Misctypes.cast_type -> 'b Misctypes.cast_type -end +(************************************************************************) +(* Modules from tactics/ *) +(************************************************************************) -module Stateid : +module Tacticals : sig - type t = Stateid.t - module Self : module type of struct include Stateid.Self end -end + open Proof_type -module Stm : -sig - type state = Stm.state - val state_of_id : - Stateid.t -> [ `Valid of state option | `Expired | `Error of exn ] + val tclORELSE : tactic -> tactic -> tactic + val tclDO : int -> tactic -> tactic + val tclIDTAC : tactic + val tclFAIL : int -> Pp.t -> tactic + val tclTHEN : tactic -> tactic -> tactic + val tclTHENLIST : tactic list -> tactic + val pf_constr_of_global : + Globnames.global_reference -> (EConstr.constr -> Proof_type.tactic) -> Proof_type.tactic + val tclMAP : ('a -> tactic) -> 'a list -> tactic + val tclTRY : tactic -> tactic + val tclCOMPLETE : tactic -> tactic + val tclTHENS : tactic -> tactic list -> tactic + val tclFIRST : tactic list -> tactic + val tclTHENFIRST : tactic -> tactic -> tactic + val tclTHENLAST : tactic -> tactic -> tactic + val tclTHENSFIRSTn : tactic -> tactic array -> tactic -> tactic + val tclTHENSLASTn : tactic -> tactic -> tactic array -> tactic + val tclSOLVE : tactic list -> tactic + + val onClause : (Names.Id.t option -> tactic) -> Locus.clause -> tactic + val onAllHypsAndConcl : (Names.Id.t option -> tactic) -> tactic + val onLastHypId : (Names.Id.t -> tactic) -> tactic + val onNthHypId : int -> (Names.Id.t -> tactic) -> tactic + val onNLastHypsId : int -> (Names.Id.t list -> tactic) -> tactic + + val tclTHENSEQ : tactic list -> tactic + [@@ocaml.deprecated "alias of API.Tacticals.tclTHENLIST"] + + val nLastDecls : int -> Goal.goal Evd.sigma -> EConstr.named_context + + val tclTHEN_i : tactic -> (int -> tactic) -> tactic + + val tclPROGRESS : tactic -> tactic + + val elimination_sort_of_goal : Goal.goal Evd.sigma -> Sorts.family + + module New : + sig + open Proofview + val tclORELSE0 : unit tactic -> unit tactic -> unit tactic + val tclFAIL : int -> Pp.t -> 'a tactic + val pf_constr_of_global : Globnames.global_reference -> EConstr.constr tactic + val tclTHEN : unit tactic -> unit tactic -> unit tactic + val tclTHENS : unit tactic -> unit tactic list -> unit tactic + val tclFIRST : unit tactic list -> unit tactic + val tclZEROMSG : ?loc:Loc.t -> Pp.t -> 'a tactic + val tclORELSE : unit tactic -> unit tactic -> unit tactic + val tclREPEAT : unit tactic -> unit tactic + val tclTRY : unit tactic -> unit tactic + val tclTHENFIRST : unit tactic -> unit tactic -> unit tactic + val tclPROGRESS : unit Proofview.tactic -> unit Proofview.tactic + val tclTHENS3PARTS : unit tactic -> unit tactic array -> unit tactic -> unit tactic array -> unit tactic + val tclDO : int -> unit tactic -> unit tactic + val tclTIMEOUT : int -> unit tactic -> unit tactic + val tclTIME : string option -> 'a tactic -> 'a tactic + val tclOR : unit tactic -> unit tactic -> unit tactic + val tclONCE : unit tactic -> unit tactic + val tclEXACTLY_ONCE : unit tactic -> unit tactic + val tclIFCATCH : + unit tactic -> + (unit -> unit tactic) -> + (unit -> unit tactic) -> unit tactic + val tclSOLVE : unit tactic list -> unit tactic + val tclCOMPLETE : 'a tactic -> 'a tactic + val tclSELECT : Vernacexpr.goal_selector -> 'a tactic -> 'a tactic + val tclWITHHOLES : bool -> 'a tactic -> Evd.evar_map -> 'a tactic + val tclDELAYEDWITHHOLES : bool -> 'a Tactypes.delayed_open -> ('a -> unit tactic) -> unit tactic + val tclTHENLIST : unit tactic list -> unit tactic + val tclTHENLAST : unit tactic -> unit tactic -> unit tactic + val tclMAP : ('a -> unit tactic) -> 'a list -> unit tactic + val tclIDTAC : unit tactic + val tclIFTHENELSE : unit tactic -> unit tactic -> unit tactic -> unit tactic + val tclIFTHENSVELSE : unit tactic -> unit tactic array -> unit tactic -> unit tactic + end end -module Declaremods : +module Hipattern : sig - val append_end_library_hook : (unit -> unit) -> unit + exception NoEquationFound + type 'a matching_function = Evd.evar_map -> EConstr.constr -> 'a option + type testing_function = Evd.evar_map -> EConstr.constr -> bool + val is_disjunction : ?strict:bool -> ?onlybinary:bool -> testing_function + val match_with_disjunction : ?strict:bool -> ?onlybinary:bool -> (EConstr.constr * EConstr.constr list) matching_function + val match_with_equality_type : (EConstr.constr * EConstr.constr list) matching_function + val is_empty_type : testing_function + val is_unit_type : testing_function + val is_unit_or_eq_type : testing_function + val is_conjunction : ?strict:bool -> ?onlybinary:bool -> testing_function + val match_with_conjunction : ?strict:bool -> ?onlybinary:bool -> (EConstr.constr * EConstr.constr list) matching_function + val match_with_imp_term : (EConstr.constr * EConstr.constr) matching_function + val match_with_forall_term : (Names.Name.t * EConstr.constr * EConstr.constr) matching_function + val match_with_nodep_ind : (EConstr.constr * EConstr.constr list * int) matching_function + val match_with_sigma_type : (EConstr.constr * EConstr.constr list) matching_function end -module Pfedit : +module Ind_tables : sig - val solve_by_implicit_tactic : unit -> Pretyping.inference_hook option - val refine_by_tactic : Environ.env -> Evd.evar_map -> EConstr.types -> unit Proofview.tactic -> - Term.constr * Evd.evar_map - val declare_implicit_tactic : unit Proofview.tactic -> unit - val clear_implicit_tactic : unit -> unit - val by : unit Proofview.tactic -> bool - val solve : ?with_end_tac:unit Proofview.tactic -> - Vernacexpr.goal_selector -> int option -> unit Proofview.tactic -> - Proof.proof -> Proof.proof * bool - val cook_proof : - unit -> (Names.Id.t * (Safe_typing.private_constants Entries.definition_entry * Proof_global.proof_universes * Decl_kinds.goal_kind)) - - val get_current_context : unit -> Evd.evar_map * Environ.env - - (* Deprecated *) - val delete_current_proof : unit -> unit - [@@ocaml.deprecated "use Proof_global.discard_current"] + type individual + type 'a scheme_kind - val get_current_proof_name : unit -> Names.Id.t - [@@ocaml.deprecated "use Proof_global.get_current_proof_name"] + val check_scheme : 'a scheme_kind -> Names.inductive -> bool + val find_scheme : ?mode:Declare.internal_flag -> 'a scheme_kind -> Names.inductive -> Names.Constant.t * Safe_typing.private_constants + val pr_scheme_kind : 'a scheme_kind -> Pp.t +end +module Elimschemes : +sig + val case_scheme_kind_from_prop : Ind_tables.individual Ind_tables.scheme_kind + val case_dep_scheme_kind_from_type_in_prop : Ind_tables.individual Ind_tables.scheme_kind + val case_scheme_kind_from_type : Ind_tables.individual Ind_tables.scheme_kind + val case_dep_scheme_kind_from_type : Ind_tables.individual Ind_tables.scheme_kind + val case_dep_scheme_kind_from_prop : Ind_tables.individual Ind_tables.scheme_kind end module Tactics : @@ -3990,7 +5055,8 @@ sig type change_arg = Pattern.patvar_map -> Evd.evar_map -> Evd.evar_map * EConstr.constr type tactic_reduction = Environ.env -> Evd.evar_map -> EConstr.constr -> EConstr.constr - type elim_scheme = Tactics.elim_scheme = + + type elim_scheme = { elimc: EConstr.constr Misctypes.with_bindings option; elimt: EConstr.types; @@ -4020,7 +5086,7 @@ sig val simplest_elim : EConstr.constr -> unit tactic val introf : unit tactic val cut : EConstr.types -> unit tactic - val convert_concl : ?check:bool -> EConstr.types -> Term.cast_kind -> unit tactic + val convert_concl : ?check:bool -> EConstr.types -> Constr.cast_kind -> unit tactic val intro_using : Names.Id.t -> unit tactic val intro : unit tactic val fresh_id_in_env : Names.Id.t list -> Names.Id.t -> Environ.env -> Names.Id.t @@ -4030,7 +5096,7 @@ sig val apply_with_delayed_bindings_gen : Misctypes.advanced_flag -> Misctypes.evars_flag -> (Misctypes.clear_flag * Tactypes.delayed_open_constr_with_bindings Loc.located) list -> unit Proofview.tactic val apply_delayed_in : - Misctypes.advanced_flag -> Misctypes.evars_flag -> Names.Id.t -> + Misctypes.advanced_flag -> Misctypes.evars_flag -> Names.Id.t -> (Misctypes.clear_flag * Tactypes.delayed_open_constr_with_bindings Loc.located) list -> Tactypes.intro_pattern option -> unit Proofview.tactic val elim : @@ -4095,8 +5161,8 @@ sig val generalize : EConstr.constr list -> unit Proofview.tactic val simplest_case : EConstr.constr -> unit Proofview.tactic val introduction : ?check:bool -> Names.Id.t -> unit Proofview.tactic - val convert_concl_no_check : EConstr.types -> Term.cast_kind -> unit Proofview.tactic - val reduct_in_concl : tactic_reduction * Term.cast_kind -> unit Proofview.tactic + val convert_concl_no_check : EConstr.types -> Constr.cast_kind -> unit Proofview.tactic + val reduct_in_concl : tactic_reduction * Constr.cast_kind -> unit Proofview.tactic val reduct_in_hyp : ?check:bool -> tactic_reduction -> Locus.hyp_location -> unit Proofview.tactic val convert_hyp_no_check : EConstr.named_declaration -> unit Proofview.tactic val reflexivity_red : bool -> unit Proofview.tactic @@ -4113,7 +5179,7 @@ sig (Locus.occurrences * Names.evaluable_global_reference) list -> unit Proofview.tactic val intros_using : Names.Id.t list -> unit Proofview.tactic val simpl_in_concl : unit Proofview.tactic - val reduct_option : ?check:bool -> tactic_reduction * Term.cast_kind -> Locus.goal_location -> unit Proofview.tactic + val reduct_option : ?check:bool -> tactic_reduction * Constr.cast_kind -> Locus.goal_location -> unit Proofview.tactic val simplest_split : unit Proofview.tactic val unfold_in_hyp : (Locus.occurrences * Names.evaluable_global_reference) list -> Locus.hyp_location -> unit Proofview.tactic @@ -4149,83 +5215,12 @@ sig end end -module Tacticals : +module Elim : sig - open Tacmach - val tclORELSE : tactic -> tactic -> tactic - val tclDO : int -> tactic -> tactic - val tclIDTAC : tactic - val tclFAIL : int -> Pp.std_ppcmds -> tactic - val tclTHEN : tactic -> tactic -> tactic - val tclTHENLIST : tactic list -> tactic - val pf_constr_of_global : - Globnames.global_reference -> (EConstr.constr -> Tacmach.tactic) -> Tacmach.tactic - val tclMAP : ('a -> tactic) -> 'a list -> tactic - val tclTRY : tactic -> tactic - val tclCOMPLETE : tactic -> tactic - val tclTHENS : tactic -> tactic list -> tactic - val tclFIRST : tactic list -> tactic - val tclTHENFIRST : tactic -> tactic -> tactic - val tclTHENLAST : tactic -> tactic -> tactic - val tclTHENSFIRSTn : tactic -> tactic array -> tactic -> tactic - val tclTHENSLASTn : tactic -> tactic -> tactic array -> tactic - val tclSOLVE : tactic list -> tactic - - val onClause : (Names.Id.t option -> tactic) -> Locus.clause -> tactic - val onAllHypsAndConcl : (Names.Id.t option -> tactic) -> tactic - val onLastHypId : (Names.Id.t -> tactic) -> tactic - val onNthHypId : int -> (Names.Id.t -> tactic) -> tactic - val onNLastHypsId : int -> (Names.Id.t list -> tactic) -> tactic - - val tclTHENSEQ : tactic list -> tactic - [@@ocaml.deprecated "alias of API.Tacticals.tclTHENLIST"] - - val nLastDecls : int -> Goal.goal Evd.sigma -> EConstr.named_context - - val tclTHEN_i : tactic -> (int -> tactic) -> tactic - - val tclPROGRESS : tactic -> tactic - - val elimination_sort_of_goal : Goal.goal Evd.sigma -> Sorts.family - - module New : - sig - open Proofview - val tclORELSE0 : unit tactic -> unit tactic -> unit tactic - val tclFAIL : int -> Pp.std_ppcmds -> 'a tactic - val pf_constr_of_global : Globnames.global_reference -> EConstr.constr tactic - val tclTHEN : unit tactic -> unit tactic -> unit tactic - val tclTHENS : unit tactic -> unit tactic list -> unit tactic - val tclFIRST : unit tactic list -> unit tactic - val tclZEROMSG : ?loc:Loc.t -> Pp.std_ppcmds -> 'a tactic - val tclORELSE : unit tactic -> unit tactic -> unit tactic - val tclREPEAT : unit tactic -> unit tactic - val tclTRY : unit tactic -> unit tactic - val tclTHENFIRST : unit tactic -> unit tactic -> unit tactic - val tclPROGRESS : unit Proofview.tactic -> unit Proofview.tactic - val tclTHENS3PARTS : unit tactic -> unit tactic array -> unit tactic -> unit tactic array -> unit tactic - val tclDO : int -> unit tactic -> unit tactic - val tclTIMEOUT : int -> unit tactic -> unit tactic - val tclTIME : string option -> 'a tactic -> 'a tactic - val tclOR : unit tactic -> unit tactic -> unit tactic - val tclONCE : unit tactic -> unit tactic - val tclEXACTLY_ONCE : unit tactic -> unit tactic - val tclIFCATCH : - unit tactic -> - (unit -> unit tactic) -> - (unit -> unit tactic) -> unit tactic - val tclSOLVE : unit tactic list -> unit tactic - val tclCOMPLETE : 'a tactic -> 'a tactic - val tclSELECT : Vernacexpr.goal_selector -> 'a tactic -> 'a tactic - val tclWITHHOLES : bool -> 'a tactic -> Evd.evar_map -> 'a tactic - val tclDELAYEDWITHHOLES : bool -> 'a Tactypes.delayed_open -> ('a -> unit tactic) -> unit tactic - val tclTHENLIST : unit tactic list -> unit tactic - val tclTHENLAST : unit tactic -> unit tactic -> unit tactic - val tclMAP : ('a -> unit tactic) -> 'a list -> unit tactic - val tclIDTAC : unit tactic - val tclIFTHENELSE : unit tactic -> unit tactic -> unit tactic -> unit tactic - val tclIFTHENSVELSE : unit tactic -> unit tactic array -> unit tactic -> unit tactic - end + val h_decompose : Names.inductive list -> EConstr.constr -> unit Proofview.tactic + val h_double_induction : Misctypes.quantified_hypothesis -> Misctypes.quantified_hypothesis-> unit Proofview.tactic + val h_decompose_or : EConstr.constr -> unit Proofview.tactic + val h_decompose_and : EConstr.constr -> unit Proofview.tactic end module Equality : @@ -4269,14 +5264,15 @@ sig orientation -> Locus.occurrences -> freeze_evars_flag -> dep_proof_flag -> ?tac:(unit Proofview.tactic * conditions) -> EConstr.constr Misctypes.with_bindings -> Misctypes.evars_flag -> unit Proofview.tactic val subst : Names.Id.t list -> unit Proofview.tactic - type subst_tactic_flags = Equality.subst_tactic_flags = { + + type subst_tactic_flags = { only_leibniz : bool; rewrite_dependent_proof : bool } val subst_all : ?flags:subst_tactic_flags -> unit -> unit Proofview.tactic val general_rewrite_in : - orientation -> Locus.occurrences -> freeze_evars_flag -> dep_proof_flag -> + orientation -> Locus.occurrences -> freeze_evars_flag -> dep_proof_flag -> ?tac:(unit Proofview.tactic * conditions) -> Names.Id.t -> EConstr.constr -> Misctypes.evars_flag -> unit Proofview.tactic val general_setoid_rewrite_clause : @@ -4302,43 +5298,63 @@ sig val absurd : EConstr.constr -> unit Proofview.tactic end -module Clenv : +module Inv : sig - type hole = Clenv.hole = { - hole_evar : EConstr.constr; - hole_type : EConstr.types; - hole_deps : bool; - hole_name : Names.Name.t; - } - type clause = Clenv.clause = { - cl_holes : hole list; - cl_concl : EConstr.types; - } - val make_evar_clause : Environ.env -> Evd.evar_map -> ?len:int -> EConstr.types -> - (Evd.evar_map * clause) - val solve_evar_clause : Environ.env -> Evd.evar_map -> bool -> clause -> EConstr.constr Misctypes.bindings -> - Evd.evar_map - type clausenv = Clenv.clausenv - val pr_clenv : Clenv.clausenv -> Pp.std_ppcmds + val dinv : + Misctypes.inversion_kind -> EConstr.constr option -> + Tactypes.or_and_intro_pattern option -> Misctypes.quantified_hypothesis -> unit Proofview.tactic + val inv_clause : + Misctypes.inversion_kind -> Tactypes.or_and_intro_pattern option -> Names.Id.t list -> + Misctypes.quantified_hypothesis -> unit Proofview.tactic + val inv_clear_tac : Names.Id.t -> unit Proofview.tactic + val inv_tac : Names.Id.t -> unit Proofview.tactic + val dinv_tac : Names.Id.t -> unit Proofview.tactic + val dinv_clear_tac : Names.Id.t -> unit Proofview.tactic + val inv : Misctypes.inversion_kind -> Tactypes.or_and_intro_pattern option -> + Misctypes.quantified_hypothesis -> unit Proofview.tactic +end + +module Leminv : +sig + val lemInv_clause : + Misctypes.quantified_hypothesis -> EConstr.constr -> Names.Id.t list -> unit Proofview.tactic + val add_inversion_lemma_exn : + Names.Id.t -> Constrexpr.constr_expr -> Misctypes.glob_sort -> bool -> (Names.Id.t -> unit Proofview.tactic) -> + unit end module Hints : sig - type hint = Hints.hint - type debug = Hints.debug = - | Debug | Info | Off - type 'a hints_path_atom_gen = 'a Hints.hints_path_atom_gen = + + type raw_hint = EConstr.t * EConstr.types * Univ.universe_context_set + + type 'a hint_ast = + | Res_pf of 'a (* Hint Apply *) + | ERes_pf of 'a (* Hint EApply *) + | Give_exact of 'a + | Res_pf_THEN_trivial_fail of 'a (* Hint Immediate *) + | Unfold_nth of Names.evaluable_global_reference (* Hint Unfold *) + | Extern of Genarg.glob_generic_argument (* Hint Extern *) + + type hint + + type debug = + | Debug | Info | Off + + type 'a hints_path_atom_gen = | PathHints of 'a list | PathAny - type hint_term = Hints.hint_term = + + type hint_term = | IsGlobRef of Globnames.global_reference | IsConstr of EConstr.constr * Univ.ContextSet.t + type hint_db_name = string type hint_info = (Names.Id.t list * Pattern.constr_pattern) Vernacexpr.hint_info_gen type hnf = bool type hints_path_atom = Globnames.global_reference hints_path_atom_gen - type 'a hints_path_gen = 'a Hints.hints_path_gen = + type 'a hints_path_gen = | PathAtom of 'a hints_path_atom_gen | PathStar of 'a hints_path_gen | PathSeq of 'a hints_path_gen * 'a hints_path_gen @@ -4348,7 +5364,7 @@ sig type hints_path = Globnames.global_reference hints_path_gen - type hints_entry = Hints.hints_entry = + type hints_entry = | HintsResolveEntry of (hint_info * Decl_kinds.polymorphic * hnf * hints_path_atom * hint_term) list | HintsImmediateEntry of (hints_path_atom * Decl_kinds.polymorphic * hint_term) list | HintsCutEntry of hints_path @@ -4357,15 +5373,7 @@ sig | HintsModeEntry of Globnames.global_reference * Vernacexpr.hint_mode list | HintsExternEntry of hint_info * Genarg.glob_generic_argument - type 'a hint_ast = 'a Hints.hint_ast = - | Res_pf of 'a - | ERes_pf of 'a - | Give_exact of 'a - | Res_pf_THEN_trivial_fail of 'a - | Unfold_nth of Names.evaluable_global_reference - | Extern of Genarg.glob_generic_argument - type raw_hint = EConstr.constr * EConstr.types * Univ.ContextSet.t - type 'a with_metadata = 'a Hints.with_metadata = private { + type 'a with_metadata = private { pri : int; poly : Decl_kinds.polymorphic; pat : Pattern.constr_pattern option; @@ -4378,7 +5386,7 @@ sig module Hint_db : sig - type t = Hints.Hint_db.t + type t val empty : ?name:hint_db_name -> Names.transparent_state -> bool -> t val transparent_state : t -> Names.transparent_state val iter : (Globnames.global_reference option -> @@ -4386,21 +5394,23 @@ sig end type hint_db = Hint_db.t - val add_hints : Vernacexpr.locality_flag -> hint_db_name list -> hints_entry -> unit + val add_hints : bool -> hint_db_name list -> hints_entry -> unit val searchtable_map : hint_db_name -> hint_db - val pp_hints_path_atom : ('a -> Pp.std_ppcmds) -> 'a hints_path_atom_gen -> Pp.std_ppcmds - val pp_hints_path_gen : ('a -> Pp.std_ppcmds) -> 'a hints_path_gen -> Pp.std_ppcmds + val pp_hints_path_atom : ('a -> Pp.t) -> 'a hints_path_atom_gen -> Pp.t + val pp_hints_path_gen : ('a -> Pp.t) -> 'a hints_path_gen -> Pp.t val glob_hints_path_atom : - Prelude.reference hints_path_atom_gen -> Globnames.global_reference hints_path_atom_gen - val pp_hints_path : hints_path -> Pp.std_ppcmds + Libnames.reference hints_path_atom_gen -> Globnames.global_reference hints_path_atom_gen + val pp_hints_path : hints_path -> Pp.t val glob_hints_path : - Prelude.reference hints_path_gen -> Globnames.global_reference hints_path_gen + Libnames.reference hints_path_gen -> Globnames.global_reference hints_path_gen + val run_hint : hint -> + ((raw_hint * Clenv.clausenv) hint_ast -> 'r Proofview.tactic) -> 'r Proofview.tactic val typeclasses_db : hint_db_name val add_hints_init : (unit -> unit) -> unit 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 : Hint_db.t -> Pp.std_ppcmds + val pr_hint_db : Hint_db.t -> Pp.t end module Auto : @@ -4421,140 +5431,6 @@ sig val default_full_auto : unit Proofview.tactic end -module Hipattern : -sig - exception NoEquationFound - type 'a matching_function = Evd.evar_map -> EConstr.constr -> 'a option - type testing_function = Evd.evar_map -> EConstr.constr -> bool - val is_disjunction : ?strict:bool -> ?onlybinary:bool -> testing_function - val match_with_disjunction : ?strict:bool -> ?onlybinary:bool -> (EConstr.constr * EConstr.constr list) matching_function - val match_with_equality_type : (EConstr.constr * EConstr.constr list) matching_function - val is_empty_type : testing_function - val is_unit_type : testing_function - val is_unit_or_eq_type : testing_function - val is_conjunction : ?strict:bool -> ?onlybinary:bool -> testing_function - val match_with_conjunction : ?strict:bool -> ?onlybinary:bool -> (EConstr.constr * EConstr.constr list) matching_function - val match_with_imp_term : (EConstr.constr * EConstr.constr) matching_function - val match_with_forall_term : (Names.Name.t * EConstr.constr * EConstr.constr) matching_function - val match_with_nodep_ind : (EConstr.constr * EConstr.constr list * int) matching_function - val match_with_sigma_type : (EConstr.constr * EConstr.constr list) matching_function -end - -module Inv : -sig - val dinv : - Misctypes.inversion_kind -> EConstr.constr option -> - Tactypes.or_and_intro_pattern option -> Misctypes.quantified_hypothesis -> unit Proofview.tactic - val inv_clause : - Misctypes.inversion_kind -> Tactypes.or_and_intro_pattern option -> Names.Id.t list -> - Misctypes.quantified_hypothesis -> unit Proofview.tactic - val inv_clear_tac : Names.Id.t -> unit Proofview.tactic - val inv_tac : Names.Id.t -> unit Proofview.tactic - val dinv_tac : Names.Id.t -> unit Proofview.tactic - val dinv_clear_tac : Names.Id.t -> unit Proofview.tactic - val inv : Misctypes.inversion_kind -> Tactypes.or_and_intro_pattern option -> - Misctypes.quantified_hypothesis -> unit Proofview.tactic -end - -module Leminv : -sig - val lemInv_clause : - Misctypes.quantified_hypothesis -> EConstr.constr -> Names.Id.t list -> unit Proofview.tactic - val add_inversion_lemma_exn : - Names.Id.t -> Constrexpr.constr_expr -> Misctypes.glob_sort -> bool -> (Names.Id.t -> unit Proofview.tactic) -> - unit -end - -module Vernacentries : -sig - val dump_global : Prelude.reference Misctypes.or_by_notation -> unit - val interp_redexp_hook : (Environ.env -> Evd.evar_map -> Genredexpr.raw_red_expr -> - Evd.evar_map * Redexpr.red_expr) Hook.t - val command_focus : unit Proof.focus_kind -end - -module Evar_refiner : -sig - val w_refine : Evar.t * Evd.evar_info -> - Pretyping.glob_constr_ltac_closure -> Evd.evar_map -> Evd.evar_map -end - -module Obligations : -sig - val default_tactic : unit Proofview.tactic ref - val obligation : int * Names.Id.t option * Constrexpr.constr_expr option -> - Genarg.glob_generic_argument option -> unit - val next_obligation : Names.Id.t option -> Genarg.glob_generic_argument option -> unit - val try_solve_obligation : int -> Names.Id.t option -> unit Proofview.tactic option -> unit - val try_solve_obligations : Names.Id.t option -> unit Proofview.tactic option -> unit - val solve_all_obligations : unit Proofview.tactic option -> unit - val admit_obligations : Names.Id.t option -> unit - val show_obligations : ?msg:bool -> Names.Id.t option -> unit - val show_term : Names.Id.t option -> Pp.std_ppcmds -end - -module Elim : -sig - val h_decompose : Names.inductive list -> EConstr.constr -> unit Proofview.tactic - val h_double_induction : Misctypes.quantified_hypothesis -> Misctypes.quantified_hypothesis-> unit Proofview.tactic - val h_decompose_or : EConstr.constr -> unit Proofview.tactic - val h_decompose_and : EConstr.constr -> unit Proofview.tactic -end - -module Redops : -sig - val all_flags : 'a Genredexpr.glob_red_flag - val make_red_flag : 'a Genredexpr.red_atom list -> 'a Genredexpr.glob_red_flag -end - -module Autorewrite : -sig - type rew_rule = { rew_lemma: Term.constr; - rew_type: Term.types; - rew_pat: Term.constr; - rew_ctx: Univ.ContextSet.t; - rew_l2r: bool; - rew_tac: Genarg.glob_generic_argument option } - type raw_rew_rule = (Term.constr Univ.in_universe_context_set * bool * - Genarg.raw_generic_argument option) - Loc.located - val auto_multi_rewrite : ?conds:Equality.conditions -> string list -> Locus.clause -> unit Proofview.tactic - val auto_multi_rewrite_with : ?conds:Equality.conditions -> unit Proofview.tactic -> string list -> Locus.clause -> unit Proofview.tactic - val add_rew_rules : string -> raw_rew_rule list -> unit - val find_rewrites : string -> rew_rule list - val find_matches : string -> Term.constr -> rew_rule list - val print_rewrite_hintdb : string -> Pp.std_ppcmds -end - -module Refine : -sig - val refine : typecheck:bool -> (Evd.evar_map -> Evd.evar_map * EConstr.t) -> unit Proofview.tactic - val solve_constraints : unit Proofview.tactic -end - -module Find_subterm : -sig - val error_invalid_occurrence : int list -> 'a -end - -module Vernac_classifier : -sig - val declare_vernac_classifier : - Vernacexpr.extend_name -> (Genarg.raw_generic_argument list -> unit -> Vernacexpr.vernac_classification) -> unit - val classify_as_proofstep : Vernacexpr.vernac_classification - val classify_as_query : Vernacexpr.vernac_classification - val classify_as_sideeff : Vernacexpr.vernac_classification - val classify_vernac : Vernacexpr.vernac_expr -> Vernacexpr.vernac_classification -end - -module Keys : -sig - type key = Keys.key - val constr_key : ('a -> ('a, 't, 'u, 'i) Term.kind_of_term) -> 'a -> key option - val declare_equiv_keys : key -> key -> unit - val pr_keys : (Globnames.global_reference -> Pp.std_ppcmds) -> Pp.std_ppcmds -end - module Eauto : sig val e_assumption : unit Proofview.tactic @@ -4566,14 +5442,16 @@ sig val autounfold_tac : Hints.hint_db_name list option -> Locus.clause -> unit Proofview.tactic val autounfold_one : Hints.hint_db_name list -> Locus.hyp_location option -> unit Proofview.tactic val eauto_with_bases : - ?debug:Hints.debug -> bool * int -> Tactypes.delayed_open_constr list -> Hints.hint_db list -> Tacmach.tactic + ?debug:Hints.debug -> bool * int -> Tactypes.delayed_open_constr list -> Hints.hint_db list -> Proof_type.tactic end module Class_tactics : sig - type search_strategy = Class_tactics.search_strategy = + + type search_strategy = | Dfs | Bfs + val set_typeclasses_debug : bool -> unit val set_typeclasses_strategy : search_strategy -> unit val set_typeclasses_depth : int option -> unit @@ -4587,34 +5465,56 @@ sig val catchable : exn -> bool end -module Ind_tables : +module Eqdecide : sig - type individual = Ind_tables.individual - type 'a scheme_kind = 'a Ind_tables.scheme_kind + val compare : EConstr.constr -> EConstr.constr -> unit Proofview.tactic + val decideEqualityGoal : unit Proofview.tactic +end - val check_scheme : 'a scheme_kind -> Names.inductive -> bool - val find_scheme : ?mode:Declare.internal_flag -> 'a scheme_kind -> Names.inductive -> Names.Constant.t * Safe_typing.private_constants - val pr_scheme_kind : 'a scheme_kind -> Pp.std_ppcmds +module Autorewrite : +sig + type rew_rule = { rew_lemma: Constr.t; + rew_type: Term.types; + rew_pat: Constr.t; + rew_ctx: Univ.ContextSet.t; + rew_l2r: bool; + rew_tac: Genarg.glob_generic_argument option } + type raw_rew_rule = (Constr.t Univ.in_universe_context_set * bool * + Genarg.raw_generic_argument option) + Loc.located + val auto_multi_rewrite : ?conds:Equality.conditions -> string list -> Locus.clause -> unit Proofview.tactic + val auto_multi_rewrite_with : ?conds:Equality.conditions -> unit Proofview.tactic -> string list -> Locus.clause -> unit Proofview.tactic + 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 end -module Elimschemes : +(************************************************************************) +(* End of modules from tactics/ *) +(************************************************************************) + +(************************************************************************) +(* Modules from vernac/ *) +(************************************************************************) + +module Ppvernac : sig - val case_scheme_kind_from_prop : Ind_tables.individual Ind_tables.scheme_kind - val case_dep_scheme_kind_from_type_in_prop : Ind_tables.individual Ind_tables.scheme_kind - val case_scheme_kind_from_type : Ind_tables.individual Ind_tables.scheme_kind - val case_dep_scheme_kind_from_type : Ind_tables.individual Ind_tables.scheme_kind - val case_dep_scheme_kind_from_prop : Ind_tables.individual Ind_tables.scheme_kind + val pr_vernac : Vernacexpr.vernac_expr -> Pp.t + val pr_rec_definition : (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) -> Pp.t end module Lemmas : sig - type 'a declaration_hook = 'a Lemmas.declaration_hook + + type 'a declaration_hook + val mk_hook : (Decl_kinds.locality -> Globnames.global_reference -> 'a) -> 'a declaration_hook val start_proof : Names.Id.t -> ?pl:Proof_global.universe_binders -> Decl_kinds.goal_kind -> Evd.evar_map -> ?terminator:(Proof_global.lemma_possible_guards -> unit declaration_hook -> Proof_global.proof_terminator) -> ?sign:Environ.named_context_val -> EConstr.types -> - ?init_tac:unit Proofview.tactic -> ?compute_guard:Proof_global.lemma_possible_guards -> + ?init_tac:unit Proofview.tactic -> ?compute_guard:Proof_global.lemma_possible_guards -> unit declaration_hook -> unit val call_hook : Future.fix_exn -> 'a declaration_hook -> Decl_kinds.locality -> Globnames.global_reference -> 'a @@ -4622,150 +5522,94 @@ sig val get_current_context : unit -> Evd.evar_map * Environ.env end -module Eqdecide : +module Himsg : sig - val compare : EConstr.constr -> EConstr.constr -> unit Proofview.tactic - val decideEqualityGoal : unit Proofview.tactic + val explain_refiner_error : Logic.refiner_error -> Pp.t + val explain_pretype_error : Environ.env -> Evd.evar_map -> Pretype_errors.pretype_error -> Pp.t end -module Locusops : +module ExplainErr : sig - val clause_with_generic_occurrences : 'a Locus.clause_expr -> bool - val nowhere : 'a Locus.clause_expr - val allHypsAndConcl : 'a Locus.clause_expr - val is_nowhere : 'a Locus.clause_expr -> bool - val occurrences_map : - ('a list -> 'b list) -> 'a Locus.occurrences_gen -> 'b Locus.occurrences_gen - val convert_occs : Locus.occurrences -> bool * int list - val onConcl : 'a Locus.clause_expr - val onHyp : 'a -> 'a Locus.clause_expr + val process_vernac_interp_error : ?allow_uncaught:bool -> Util.iexn -> Util.iexn + val register_additional_error_info : (Util.iexn -> Pp.t option Loc.located option) -> unit end -module Topfmt : +module Locality : sig - val std_ft : Format.formatter ref - val with_output_to : out_channel -> Format.formatter - val get_margin : unit -> int option + val make_section_locality : bool option -> bool + module LocalityFixme : sig + val consume : unit -> bool option + end + val make_module_locality : bool option -> bool end -module Nameops : +module Metasyntax : sig - val atompart_of_id : Names.Id.t -> string - val pr_id : Names.Id.t -> Pp.std_ppcmds - [@@ocaml.deprecated "alias of API.Names.Id.print"] + val add_token_obj : string -> unit - val pr_name : Names.Name.t -> Pp.std_ppcmds - [@@ocaml.deprecated "alias of API.Names.Name.print"] + type any_entry = AnyEntry : 'a Pcoq.Gram.entry -> any_entry + val register_grammar : string -> any_entry list -> unit - val name_fold : (Names.Id.t -> 'a -> 'a) -> Names.Name.t -> 'a -> 'a - val name_app : (Names.Id.t -> Names.Id.t) -> Names.Name.t -> Names.Name.t - val add_suffix : Names.Id.t -> string -> Names.Id.t - val increment_subscript : Names.Id.t -> Names.Id.t - val make_ident : string -> int option -> Names.Id.t - val out_name : Names.Name.t -> Names.Id.t - val pr_lab : Names.Label.t -> Pp.std_ppcmds - module Name : - sig - include module type of struct include Names.Name end - val get_id : t -> Names.Id.t - val fold_right : (Names.Id.t -> 'a -> 'a) -> t -> 'a -> 'a - end end -module Declareops : +module Search : sig - val constant_has_body : Declarations.constant_body -> bool - val is_opaque : Declarations.constant_body -> bool - val eq_recarg : Declarations.recarg -> Declarations.recarg -> bool + type glob_search_about_item = + | GlobSearchSubPattern of Pattern.constr_pattern + | GlobSearchString of string + type filter_function = Globnames.global_reference -> Environ.env -> Constr.t -> bool + type display_function = Globnames.global_reference -> Environ.env -> Constr.t -> unit + val search_about_filter : glob_search_about_item -> filter_function + val module_filter : Names.DirPath.t list * bool -> filter_function + val generic_search : int option -> display_function -> unit end -module Constr : +module Obligations : sig - type t = Term.constr - [@@ocaml.deprecated "alias of API.Term.constr"] - - type constr = Term.constr - [@@ocaml.deprecated "alias of API.Term.constr"] - - type types = Term.constr - [@@ocaml.deprecated "alias of API.Term.types"] - - type cast_kind = Term.cast_kind = - | VMcast - | NATIVEcast - | DEFAULTcast - | REVERTcast - type ('constr, 'types, 'sort, 'univs) kind_of_term = ('constr, 'types, 'sort, 'univs) Term.kind_of_term = - | Rel of int - | Var of Names.Id.t - | Meta of Term.metavariable - | Evar of 'constr Term.pexistential - | Sort of 'sort - | Cast of '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 - | App of 'constr * 'constr array - | Const of (Names.Constant.t * 'univs) - | Ind of (Names.inductive * 'univs) - | Construct of (Names.constructor * 'univs) - | Case of Term.case_info * 'constr * 'constr * 'constr array - | Fix of ('constr, 'types) Term.pfixpoint - | CoFix of ('constr, 'types) Term.pcofixpoint - | Proj of Names.Projection.t * 'constr - [@@ocaml.deprecated "alias of API.Term.cast_kind"] - - val equal : Term.constr -> Term.constr -> bool - [@@ocaml.deprecated "alias of API.Term.eq_constr"] - - val mkIndU : Term.pinductive -> Term.constr - [@@ocaml.deprecated "alias of API.Term.mkIndU"] - - val mkConstU : Term.pconstant -> Term.constr - [@@ocaml.deprecated "alias of API.Term.mkConstU"] - - val mkConst : Names.Constant.t -> Term.constr - [@@ocaml.deprecated "alias of API.Term.mkConst"] - - val mkVar : Names.Id.t -> Term.constr - [@@ocaml.deprecated "alias of API.Term.mkVar"] - - val compare : Term.constr -> Term.constr -> int - [@@ocaml.deprecated "alias of API.Term.constr_ord"] - - val mkApp : Term.constr * Term.constr array -> Term.constr - [@@ocaml.deprecated "alias of API.Term.mkApp"] + val default_tactic : unit Proofview.tactic ref + val obligation : int * Names.Id.t option * Constrexpr.constr_expr option -> + Genarg.glob_generic_argument option -> unit + val next_obligation : Names.Id.t option -> Genarg.glob_generic_argument option -> unit + val try_solve_obligation : int -> Names.Id.t option -> unit Proofview.tactic option -> unit + val try_solve_obligations : Names.Id.t option -> unit Proofview.tactic option -> unit + val solve_all_obligations : unit Proofview.tactic option -> unit + val admit_obligations : Names.Id.t option -> unit + val show_obligations : ?msg:bool -> Names.Id.t option -> unit + val show_term : Names.Id.t option -> Pp.t end -[@@ocaml.deprecated "alias of API.Term"] -module Coq_config : +module Command : sig - val exec_extension : string -end + open Names + open Constrexpr + open Vernacexpr + + type structured_fixpoint_expr = { + fix_name : Id.t; + fix_univs : lident list option; + fix_annot : Id.t Loc.located option; + fix_binders : local_binder_expr list; + fix_body : constr_expr option; + fix_type : constr_expr + } -module Kindops : -sig - val logical_kind_of_goal_kind : Decl_kinds.goal_object_kind -> Decl_kinds.logical_kind -end + type structured_one_inductive_expr = { + ind_name : Id.t; + ind_univs : lident list option; + ind_arity : constr_expr; + ind_lc : (Id.t * constr_expr) list + } -module States : -sig - val with_state_protection_on_exception : ('a -> 'b) -> 'a -> 'b - val with_state_protection : ('a -> 'b) -> 'a -> 'b -end + type structured_inductive_expr = + local_binder_expr list * structured_one_inductive_expr list -module Command : -sig - type structured_fixpoint_expr = Command.structured_fixpoint_expr - type recursive_preentry = Names.Id.t list * Term.constr option list * Term.types list - type structured_inductive_expr = Command.structured_inductive_expr - type one_inductive_impls = Command.one_inductive_impls + type recursive_preentry = Names.Id.t list * Constr.t option list * Constr.types list + + type one_inductive_impls val do_mutual_inductive : - (Vernacexpr.one_inductive_expr * Vernacexpr.decl_notation list) list -> - Decl_kinds.cumulative_inductive_flag -> - Decl_kinds.polymorphic -> + (Vernacexpr.one_inductive_expr * Vernacexpr.decl_notation list) list -> Decl_kinds.cumulative_inductive_flag -> Decl_kinds.polymorphic -> Decl_kinds.private_flag -> Decl_kinds.recursivity_kind -> unit val do_definition : Names.Id.t -> Decl_kinds.definition_kind -> Vernacexpr.lident list option -> @@ -4781,7 +5625,7 @@ sig val interp_fixpoint : structured_fixpoint_expr list -> Vernacexpr.decl_notation list -> - recursive_preentry * Vernacexpr.lident list option * UState.t * + recursive_preentry * Vernacexpr.lident list option * UState.t * (EConstr.rel_context * Impargs.manual_implicits * int option) list val extract_mutual_inductive_declaration_components : @@ -4800,14 +5644,108 @@ sig Names.MutInd.t end -module Ppvernac : +module Classes : sig - val pr_vernac : Vernacexpr.vernac_expr -> Pp.std_ppcmds - val pr_rec_definition : (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) -> Pp.std_ppcmds + val set_typeclass_transparency : Names.evaluable_global_reference -> bool -> bool -> unit + val new_instance : + ?abstract:bool -> + ?global:bool -> + ?refine:bool -> + Decl_kinds.polymorphic -> + Constrexpr.local_binder_expr list -> + Constrexpr.typeclass_constraint -> + (bool * Constrexpr.constr_expr) option -> + ?generalize:bool -> + ?tac:unit Proofview.tactic -> + ?hook:(Globnames.global_reference -> unit) -> + Vernacexpr.hint_info_expr -> + Names.Id.t end -module Topconstr : +module Vernacinterp : sig - val replace_vars_constr_expr : - Names.Id.t Names.Id.Map.t -> Constrexpr.constr_expr -> Constrexpr.constr_expr + type deprecation = bool + + type vernac_command = Genarg.raw_generic_argument list -> unit -> unit + + val vinterp_add : deprecation -> Vernacexpr.extend_name -> + vernac_command -> unit + +end + +module Mltop : +sig + val declare_cache_obj : (unit -> unit) -> string -> unit + val add_known_plugin : (unit -> unit) -> string -> unit + val add_known_module : string -> unit + val module_is_known : string -> bool +end + +module Topfmt : +sig + val std_ft : Format.formatter ref + val with_output_to : out_channel -> Format.formatter + val get_margin : unit -> int option +end + +module Vernacentries : +sig + val dump_global : Libnames.reference Misctypes.or_by_notation -> unit + val interp_redexp_hook : (Environ.env -> Evd.evar_map -> Genredexpr.raw_red_expr -> + Evd.evar_map * Redexpr.red_expr) Hook.t + val command_focus : unit Proof.focus_kind end + +(************************************************************************) +(* End of modules from vernac/ *) +(************************************************************************) + +(************************************************************************) +(* Modules from stm/ *) +(************************************************************************) + +module Vernac_classifier : +sig + val declare_vernac_classifier : + Vernacexpr.extend_name -> (Genarg.raw_generic_argument list -> unit -> Vernacexpr.vernac_classification) -> unit + val classify_as_proofstep : Vernacexpr.vernac_classification + val classify_as_query : Vernacexpr.vernac_classification + val classify_as_sideeff : Vernacexpr.vernac_classification + val classify_vernac : Vernacexpr.vernac_expr -> Vernacexpr.vernac_classification +end + +module Stm : +sig + type state + val state_of_id : + Stateid.t -> [ `Valid of state option | `Expired | `Error of exn ] +end + +(************************************************************************) +(* End of modules from stm/ *) +(************************************************************************) + +(************************************************************************) +(* Modules from highparsing/ *) +(************************************************************************) + +module G_vernac : +sig + + val def_body : Vernacexpr.definition_expr Pcoq.Gram.entry + val section_subset_expr : Vernacexpr.section_subset_expr Pcoq.Gram.entry + val query_command : (Vernacexpr.goal_selector option -> Vernacexpr.vernac_expr) Pcoq.Gram.entry + +end + +module G_proofs : +sig + + val hint : Vernacexpr.hints_expr Pcoq.Gram.entry + val hint_proof_using : 'a Pcoq.Gram.entry -> 'a option -> 'a option + +end + +(************************************************************************) +(* End of modules from highparsing/ *) +(************************************************************************) diff --git a/API/API.mllib b/API/API.mllib index f4bdf83db7..25275c7046 100644 --- a/API/API.mllib +++ b/API/API.mllib @@ -1,2 +1 @@ API -Grammar_API diff --git a/API/grammar_API.ml b/API/grammar_API.ml deleted file mode 100644 index 485c166657..0000000000 --- a/API/grammar_API.ml +++ /dev/null @@ -1,63 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -module G_proofs = G_proofs -module Metasyntax = Metasyntax -module Egramcoq = Egramcoq -module G_vernac = G_vernac -module Pcoq = Pcoq -module Tok = Tok -module CLexer = CLexer -module Egramml = Egramml -module Mltop = Mltop -module Vernacinterp = Vernacinterp -module Genintern = Genintern - -module Extend = - struct - type 'a entry = 'a Extend.entry - type ('self, 'a) symbol = ('self, 'a) Extend.symbol = - | Atoken : Tok.t -> ('self, string) symbol - | Alist1 : ('self, 'a) symbol -> ('self, 'a list) symbol - | Alist1sep : ('self, 'a) symbol * ('self, _) symbol -> ('self, 'a list) symbol - | Alist0 : ('self, 'a) symbol -> ('self, 'a list) symbol - | Alist0sep : ('self, 'a) symbol * ('self, _) symbol -> ('self, 'a list) symbol - | Aopt : ('self, 'a) symbol -> ('self, 'a option) symbol - | Aself : ('self, 'self) symbol - | Anext : ('self, 'self) symbol - | Aentry : 'a entry -> ('self, 'a) symbol - | Aentryl : 'a entry * int -> ('self, 'a) symbol - | Arules : 'a rules list -> ('self, 'a) symbol - and ('self, 'a, 'r) rule = ('self, 'a, 'r) Extend.rule = - | Stop : ('self, 'r, 'r) rule - | Next : ('self, 'a, 'r) rule * ('self, 'b) symbol -> ('self, 'b -> 'a, 'r) rule - and ('a, 'r) norec_rule = ('a, 'r) Extend.norec_rule = - { norec_rule : 's. ('s, 'a, 'r) rule } - and 'a rules = 'a Extend.rules = - | Rules : ('act, Loc.t -> 'a) norec_rule * 'act -> 'a rules - type gram_assoc = Extend.gram_assoc = NonA | RightA | LeftA - type 'a production_rule = 'a Extend.production_rule = - | Rule : ('a, 'act, Loc.t -> 'a) rule * 'act -> 'a production_rule - type 'a single_extend_statment = string option * gram_assoc option * 'a production_rule list - type gram_position = Extend.gram_position = - | First - | Last - | Before of string - | After of string - | Level of string - type 'a extend_statment = Extend.gram_position option * 'a single_extend_statment list - - type 'a user_symbol = 'a Extend.user_symbol = - | Ulist1 of 'a user_symbol - | Ulist1sep of 'a user_symbol * string - | Ulist0 of 'a user_symbol - | Ulist0sep of 'a user_symbol * string - | Uopt of 'a user_symbol - | Uentry of 'a - | Uentryl of 'a * int - end diff --git a/API/grammar_API.mli b/API/grammar_API.mli deleted file mode 100644 index c2115a506b..0000000000 --- a/API/grammar_API.mli +++ /dev/null @@ -1,249 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -module Extend : -sig - type 'a entry = 'a Pcoq.Gram.Entry.e - type ('self, 'a) symbol = ('self, 'a) Extend.symbol = - | Atoken : Tok.t -> ('self, string) symbol - | Alist1 : ('self, 'a) symbol -> ('self, 'a list) symbol - | Alist1sep : ('self, 'a) symbol * ('self, _) symbol -> ('self, 'a list) symbol - | Alist0 : ('self, 'a) symbol -> ('self, 'a list) symbol - | Alist0sep : ('self, 'a) symbol * ('self, _) symbol -> ('self, 'a list) symbol - | Aopt : ('self, 'a) symbol -> ('self, 'a option) symbol - | Aself : ('self, 'self) symbol - | Anext : ('self, 'self) symbol - | Aentry : 'a entry -> ('self, 'a) symbol - | Aentryl : 'a entry * int -> ('self, 'a) symbol - | Arules : 'a rules list -> ('self, 'a) symbol - and ('self, 'a, 'r) rule = ('self, 'a, 'r) Extend.rule = - | Stop : ('self, 'r, 'r) rule - | Next : ('self, 'a, 'r) rule * ('self, 'b) symbol -> ('self, 'b -> 'a, 'r) rule - and ('a, 'r) norec_rule = ('a, 'r) Extend.norec_rule = - { norec_rule : 's. ('s, 'a, 'r) rule } - and 'a rules = 'a Extend.rules = - | Rules : ('act, Loc.t -> 'a) norec_rule * 'act -> 'a rules - type gram_assoc = Extend.gram_assoc = NonA | RightA | LeftA - type 'a production_rule = 'a Extend.production_rule = - | Rule : ('a, 'act, Loc.t -> 'a) rule * 'act -> 'a production_rule - type 'a single_extend_statment = string option * gram_assoc option * 'a production_rule list - type gram_position = Extend.gram_position = - | First - | Last - | Before of string - | After of string - | Level of string - type 'a extend_statment = gram_position option * 'a single_extend_statment list - type 'a user_symbol = 'a Extend.user_symbol = - | Ulist1 of 'a user_symbol - | Ulist1sep of 'a user_symbol * string - | Ulist0 of 'a user_symbol - | Ulist0sep of 'a user_symbol * string - | Uopt of 'a user_symbol - | Uentry of 'a - | Uentryl of 'a * int -end - -module Genintern : -sig - open API - module Store : module type of struct include Genintern.Store end - type glob_sign = Genintern.glob_sign = - { ltacvars : Names.Id.Set.t; - genv : Environ.env; - extra : Store.t } - type ('raw, 'glb) intern_fun = glob_sign -> 'raw -> glob_sign * 'glb - type 'glb subst_fun = Mod_subst.substitution -> 'glb -> 'glb - type 'glb ntn_subst_fun = Tactypes.glob_constr_and_expr Names.Id.Map.t -> 'glb -> 'glb - val empty_glob_sign : Environ.env -> glob_sign - val register_intern0 : ('raw, 'glb, 'top) Genarg.genarg_type -> - ('raw, 'glb) intern_fun -> unit - val register_subst0 : ('raw, 'glb, 'top) Genarg.genarg_type -> - 'glb subst_fun -> unit - val register_ntn_subst0 : ('raw, 'glb, 'top) Genarg.genarg_type -> - 'glb ntn_subst_fun -> unit - val generic_substitute : Genarg.glob_generic_argument subst_fun - val generic_intern : (Genarg.raw_generic_argument, Genarg.glob_generic_argument) intern_fun -end - -module Tok : -sig - type t = Tok.t = - | KEYWORD of string - | PATTERNIDENT of string - | IDENT of string - | FIELD of string - | INT of string - | STRING of string - | LEFTQMARK - | BULLET of string - | EOI -end - -module Pcoq : -sig - type gram_universe = Pcoq.gram_universe - module Gram : - sig - type te = Tok.t - module Entry : - sig - type 'a e = 'a Extend.entry - val of_parser : string -> (te Stream.t -> 'a) -> 'a e - val obj : 'a e -> te Gramext.g_entry - val create : string -> 'a e - end - type 'a entry = 'a Entry.e - val extend : 'a Pcoq.Gram.Entry.e -> Gramext.position option -> - (string option * Gramext.g_assoc option * - (Tok.t Gramext.g_symbol list * Gramext.g_action) list) list -> unit - val entry_create : string -> 'a Entry.e - end - module Prim : sig - open Names - open Loc - val preident : string Gram.Entry.e - val ident : Names.Id.t Gram.Entry.e - val name : Name.t located Gram.Entry.e - val identref : Names.Id.t located Gram.Entry.e - val pidentref : (Names.Id.t located * (Names.Id.t located list) option) Gram.Entry.e - val pattern_ident : Names.Id.t Gram.Entry.e - val pattern_identref : Names.Id.t located Gram.Entry.e - val base_ident : Names.Id.t Gram.Entry.e - val natural : int Gram.Entry.e - val bigint : Constrexpr.raw_natural_number Gram.Entry.e - val integer : int Gram.Entry.e - val string : string Gram.Entry.e - val qualid : API.Libnames.qualid located Gram.Entry.e - val fullyqualid : Names.Id.t list located Gram.Entry.e - val reference : API.Libnames.reference Gram.Entry.e - val by_notation : (string * string option) Loc.located Gram.entry - val smart_global : API.Libnames.reference API.Misctypes.or_by_notation Gram.Entry.e - val dirpath : DirPath.t Gram.Entry.e - val ne_string : string Gram.Entry.e - val ne_lstring : string located Gram.Entry.e - val var : Names.Id.t located Gram.Entry.e - end - - val eoi_entry : 'a Gram.Entry.e -> 'a Gram.Entry.e - val create_generic_entry : gram_universe -> string -> - ('a, Genarg.rlevel) Genarg.abstract_argument_type -> 'a Gram.Entry.e - val utactic : gram_universe - type gram_reinit = Extend.gram_assoc * Extend.gram_position - val grammar_extend : 'a Gram.Entry.e -> gram_reinit option -> - 'a Extend.extend_statment -> unit - val genarg_grammar : ('raw, 'glb, 'top) Genarg.genarg_type -> 'raw Gram.Entry.e - val register_grammar : ('raw, 'glb, 'top) Genarg.genarg_type -> 'raw Gram.Entry.e -> unit - module Constr : - sig - val sort : API.Misctypes.glob_sort Gram.Entry.e - val lconstr : API.Constrexpr.constr_expr Gram.Entry.e - val lconstr_pattern : API.Constrexpr.constr_expr Gram.Entry.e - val ident : API.Names.Id.t Gram.Entry.e - val constr : API.Constrexpr.constr_expr Gram.Entry.e - val closed_binder : API.Constrexpr.local_binder_expr list Gram.Entry.e - val constr_pattern : API.Constrexpr.constr_expr Gram.Entry.e - val global : API.Libnames.reference Gram.Entry.e - val binder_constr : API.Constrexpr.constr_expr Gram.Entry.e - val operconstr : API.Constrexpr.constr_expr Gram.Entry.e - val pattern : API.Constrexpr.cases_pattern_expr Gram.Entry.e - val binders : API.Constrexpr.local_binder_expr list Gram.Entry.e - end - module Vernac_ : - sig - val gallina : API.Vernacexpr.vernac_expr Gram.Entry.e - val gallina_ext : API.Vernacexpr.vernac_expr Gram.Entry.e - val red_expr : API.Genredexpr.raw_red_expr Gram.Entry.e - val noedit_mode : API.Vernacexpr.vernac_expr Gram.Entry.e - val command : API.Vernacexpr.vernac_expr Gram.Entry.e - val rec_definition : (API.Vernacexpr.fixpoint_expr * API.Vernacexpr.decl_notation list) Gram.Entry.e - val vernac : API.Vernacexpr.vernac_expr Gram.Entry.e - end - - type extend_rule = - | ExtendRule : 'a Gram.Entry.e * gram_reinit option * 'a Extend.extend_statment -> extend_rule - - module GramState : module type of struct include Pcoq.GramState end - type 'a grammar_command = 'a Pcoq.grammar_command - type 'a grammar_extension = 'a -> GramState.t -> extend_rule list * GramState.t - val create_grammar_command : string -> 'a grammar_extension -> 'a grammar_command - val extend_grammar_command : 'a grammar_command -> 'a -> unit - val epsilon_value : ('a -> 'self) -> ('self, 'a) Extend.symbol -> 'self option - val parse_string : 'a Gram.Entry.e -> string -> 'a - val (!@) : Ploc.t -> Loc.t - val set_command_entry : API.Vernacexpr.vernac_expr Gram.Entry.e -> unit - val to_coqloc : Ploc.t -> Loc.t -end - -module CLexer : -sig - type keyword_state = CLexer.keyword_state - val terminal : string -> Tok.t - val add_keyword : string -> unit - val is_keyword : string -> bool - val check_ident : string -> unit - val get_keyword_state : unit -> keyword_state - val set_keyword_state : keyword_state -> unit -end - -module Egramml : -sig - type 's grammar_prod_item = 's Egramml.grammar_prod_item = - | GramTerminal of string - | GramNonTerminal : ('a Genarg.raw_abstract_argument_type option * - ('s, 'a) Extend.symbol) Loc.located -> 's grammar_prod_item - - - val extend_vernac_command_grammar : - API.Vernacexpr.extend_name -> Vernacexpr.vernac_expr Pcoq.Gram.Entry.e option -> - Vernacexpr.vernac_expr grammar_prod_item list -> unit - - val make_rule : - (Loc.t -> Genarg.raw_generic_argument list -> 'a) -> - 'a grammar_prod_item list -> 'a Extend.production_rule -end - -module Mltop : -sig - val add_known_module : string -> unit - val module_is_known : string -> bool - val declare_cache_obj : (unit -> unit) -> string -> unit -end -module Vernacinterp : -sig - type deprecation = bool - type vernac_command = Genarg.raw_generic_argument list -> unit -> unit - val vinterp_add : deprecation -> API.Vernacexpr.extend_name -> - vernac_command -> unit -end - -module G_vernac : -sig - val def_body : API.Vernacexpr.definition_expr Pcoq.Gram.Entry.e - val section_subset_expr : API.Vernacexpr.section_subset_expr Pcoq.Gram.Entry.e - val query_command : (Vernacexpr.goal_selector option -> Vernacexpr.vernac_expr) - Pcoq.Gram.Entry.e -end - -module G_proofs : -sig - val hint : Vernacexpr.hints_expr Pcoq.Gram.Entry.e - val hint_proof_using : 'a Pcoq.Gram.Entry.e -> 'a option -> 'a option -end - -module Egramcoq : -sig -end - -module Metasyntax : -sig - type any_entry = Metasyntax.any_entry = - | AnyEntry : 'a Pcoq.Gram.Entry.e -> any_entry - val register_grammar : string -> any_entry list -> unit - val add_token_obj : string -> unit -end @@ -1,3 +1,10 @@ +To be inserted at the proper place: + +Notations + +- Recursive notations with the recursive pattern repeating on the + right (e.g. "( x ; .. ; y ; z )") now supported. + Changes beyond V8.6 =================== @@ -42,9 +42,9 @@ # to communicate between make sub-calls (in Win32, 8kb max per env variable, # 32kb total) -# !! Before using FIND_VCS_CLAUSE, please read how you should in the !! -# !! FIND_VCS_CLAUSE section of dev/doc/build-system.dev.txt !! -FIND_VCS_CLAUSE:='(' \ +# !! Before using FIND_SKIP_DIRS, please read how you should in the !! +# !! FIND_SKIP_DIRS section of dev/doc/build-system.dev.txt !! +FIND_SKIP_DIRS:='(' \ -name '{arch}' -o \ -name '.svn' -o \ -name '_darcs' -o \ @@ -55,25 +55,23 @@ FIND_VCS_CLAUSE:='(' \ -name '_build' -o \ -name '_build_ci' -o \ -name 'coq-makefile' -o \ - -name '.opamcache' \ + -name '.opamcache' -o \ + -name '.coq-native' \ ')' -prune -o define find - $(shell find . $(FIND_VCS_CLAUSE) '(' -name $(1) ')' -print | sed 's|^\./||') + $(shell find . $(FIND_SKIP_DIRS) '(' -name $(1) ')' -print | sed 's|^\./||') endef define findindir - $(shell find $(1) $(FIND_VCS_CLAUSE) '(' -name $(2) ')' -print | sed 's|^\./||') -endef - -define findx - $(shell find . $(FIND_VCS_CLAUSE) '(' -name $(1) ')' -exec $(2) {} \; | sed 's|^\./||') + $(shell find $(1) $(FIND_SKIP_DIRS) '(' -name $(2) ')' -print | sed 's|^\./||') endef ## Files in the source tree LEXFILES := $(call find, '*.mll') -export MLLIBFILES := $(call find, '*.mllib') $(call find, '*.mlpack') +export MLLIBFILES := $(call find, '*.mllib') +export MLPACKFILES := $(call find, '*.mlpack') export ML4FILES := $(call find, '*.ml4') export CFILES := $(call findindir, 'kernel/byterun', '*.c') @@ -97,11 +95,7 @@ export GENFILES:=$(GENMLFILES) $(GENMLIFILES) $(GENHFILES) ## More complex file lists -define diff - $(strip $(foreach f, $(1), $(if $(filter $(f),$(2)),,$f))) -endef - -export MLSTATICFILES := $(call diff, $(EXISTINGML), $(GENMLFILES) $(GENML4FILES)) +export MLSTATICFILES := $(filter-out $(GENMLFILES) $(GENML4FILES), $(EXISTINGML)) export MLIFILES := $(sort $(GENMLIFILES) $(EXISTINGMLI)) include Makefile.common @@ -139,6 +133,36 @@ Then, you may want to consider whether you want to restore the autosaves) #run. endif +# Check that every compiled file around has a known source file. +# This should help preventing weird compilation failures caused by leftover +# compiled files after deleting or moving some source files. + +ifndef ACCEPT_ALIEN_VO +EXISTINGVO:=$(call find, '*.vo') +KNOWNVO:=$(patsubst %.v,%.vo,$(call find, '*.v')) +ALIENVO:=$(filter-out $(KNOWNVO),$(EXISTINGVO)) +ifdef ALIENVO +$(error Leftover compiled Coq files without known sources: $(ALIENVO); \ +remove them first, for instance via 'make voclean' \ +(or skip this check via 'make ACCEPT_ALIEN_VO=1')) +endif +endif + +ifndef ACCEPT_ALIEN_OBJ +EXISTINGOBJS:=$(call find, '*.cm[oxia]' -o -name '*.cmxa') +KNOWNML:=$(EXISTINGML) $(GENMLFILES) $(GENML4FILES) $(MLPACKFILES:.mlpack=.ml) \ + $(patsubst %.mlp,%.ml,$(wildcard grammar/*.mlp)) +KNOWNOBJS:=$(KNOWNML:.ml=.cmo) $(KNOWNML:.ml=.cmx) $(KNOWNML:.ml=.cmi) \ + $(MLIFILES:.mli=.cmi) \ + $(MLLIBFILES:.mllib=.cma) $(MLLIBFILES:.mllib=.cmxa) grammar/grammar.cma +ALIENOBJS:=$(filter-out $(KNOWNOBJS),$(EXISTINGOBJS)) +ifdef ALIENOBJS +$(error Leftover compiled OCaml files without known sources: $(ALIENOBJS); \ +remove them first, for instance via 'make clean' \ +(or skip this check via 'make ACCEPT_ALIEN_OBJ=1')) +endif +endif + # Apart from clean and tags, everything will be done in a sub-call to make # on Makefile.build. This way, we avoid doing here the -include of .d : # since they trigger some compilations, we do not want them for a mere clean. @@ -218,7 +242,7 @@ archclean: clean-ide optclean voclean optclean: rm -f $(COQTOPEXE) $(COQMKTOP) $(CHICKEN) rm -f $(TOOLS) $(PRIVATEBINARIES) $(CSDPCERT) - find . -name '*.cmx' -o -name '*.cmxs' -o -name '*.cmxa' -o -name '*.[soa]' -o -name '*.so' | xargs rm -f + find . -name '*.cmx' -o -name '*.cmx[as]' -o -name '*.[soa]' -o -name '*.so' | xargs rm -f clean-ide: rm -f $(COQIDECMO) $(COQIDECMX) $(COQIDECMO:.cmo=.cmi) $(COQIDEBYTE) $(COQIDE) @@ -231,7 +255,7 @@ ml4clean: rm -f $(GENML4FILES) depclean: - find . $(FIND_VCS_CLAUSE) '(' -name '*.d' ')' -print | xargs rm -f + find . $(FIND_SKIP_DIRS) '(' -name '*.d' ')' -print | xargs rm -f cacheclean: find theories plugins test-suite -name '.*.aux' -delete diff --git a/Makefile.build b/Makefile.build index 7703df08fc..7961092fa4 100644 --- a/Makefile.build +++ b/Makefile.build @@ -151,7 +151,7 @@ endif # coqdep_boot (for the .v.d files) or grammar.cma (for .ml4 -> .ml -> .ml.d). DEPENDENCIES := \ - $(addsuffix .d, $(MLFILES) $(MLIFILES) $(MLLIBFILES) $(CFILES) $(VFILES)) + $(addsuffix .d, $(MLFILES) $(MLIFILES) $(MLLIBFILES) $(MLPACKFILES) $(CFILES) $(VFILES)) -include $(DEPENDENCIES) @@ -564,6 +564,12 @@ kernel/kernel.cma: kernel/kernel.mllib $(SHOW)'OCAMLC -a -o $@' $(HIDE)$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) $(VMBYTEFLAGS) -a -o $@ $(filter-out %.mllib, $^) +# Specific rule for API/API.cmi +# Make sure that API/API.mli cannot leak types from the Coq codebase. +API/API.cmi : API/API.mli + $(SHOW)'OCAMLC $<' + $(HIDE)$(OCAMLC) -I lib -I $(MYCAMLP4LIB) -c $< + %.cma: %.mllib $(SHOW)'OCAMLC -a -o $@' $(HIDE)$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) -a -o $@ $(filter-out %.mllib, $^) diff --git a/Makefile.ci b/Makefile.ci index c8bc09fdc4..1b09905cc7 100644 --- a/Makefile.ci +++ b/Makefile.ci @@ -24,4 +24,9 @@ CI_TARGETS=ci-all \ # Generic rule, we use make to easy travis integraton with mixed rules $(CI_TARGETS): ci-%: - +./dev/ci/ci-$*.sh + rm -f ci-$*.ok + +(./dev/ci/ci-$*.sh 2>&1 && touch ci-$*.ok) | tee time-of-build.log + echo 'Aggregating timing log...' && echo -en 'travis_fold:start:coq.test.timing\\r' + python ./tools/make-one-time-file.py time-of-build.log + echo -en 'travis_fold:end:coq.test.timing\\r' + rm ci-$*.ok # must not be -f; we're checking to see that it exists diff --git a/Makefile.ide b/Makefile.ide index 0cfbdeb4e0..b534b385b9 100644 --- a/Makefile.ide +++ b/Makefile.ide @@ -61,12 +61,16 @@ GTKLIBS=$(shell pkg-config --variable=libdir gtk+-2.0) # CoqIde special targets ########################################################################### -.PHONY: coqide coqide-opt coqide-byte coqide-files +.PHONY: coqide coqide-opt coqide-byte coqide-files coqide-binaries .PHONY: ide-toploop ide-byteloop ide-optloop -# target to build CoqIde +# target to build CoqIde (native version) and the stuff needed to lauch it coqide: coqide-files coqide-opt theories/Init/Prelude.vo +# target to build CoqIde (in native and byte versions), and no more +# NB: this target is used in the opam package coq-coqide +coqide-binaries: coqide-opt coqide-byte + ifeq ($(HASCOQIDE),opt) coqide-opt: $(COQIDE) ide-toploop else diff --git a/checker/cic.mli b/checker/cic.mli index 14fa7c7746..59dd5bc4d3 100644 --- a/checker/cic.mli +++ b/checker/cic.mli @@ -182,8 +182,6 @@ type ('a, 'b) declaration_arity = | RegularArity of 'a | TemplateArity of 'b -type constant_type = (constr, rel_context * template_arity) declaration_arity - (** Inlining level of parameters at functor applications. This is ignored by the checker. *) @@ -226,7 +224,7 @@ type typing_flags = { type constant_body = { const_hyps : section_context; (** New: younger hyp at top *) const_body : constant_def; - const_type : constant_type; + const_type : constr; const_body_code : to_patch_substituted; const_universes : constant_universes; const_proj : projection_body option; diff --git a/checker/declarations.ml b/checker/declarations.ml index 2eefe47816..093d999a34 100644 --- a/checker/declarations.ml +++ b/checker/declarations.ml @@ -515,12 +515,6 @@ let subst_rel_declaration sub = let subst_rel_context sub = List.smartmap (subst_rel_declaration sub) -let subst_template_cst_arity sub (ctx,s as arity) = - let ctx' = subst_rel_context sub ctx in - if ctx==ctx' then arity else (ctx',s) - -let subst_arity sub s = subst_decl_arity subst_mps subst_template_cst_arity sub s - let constant_is_polymorphic cb = match cb.const_universes with | Monomorphic_const _ -> false @@ -531,7 +525,7 @@ let constant_is_polymorphic cb = let subst_const_body sub cb = { cb with const_body = subst_constant_def sub cb.const_body; - const_type = subst_arity sub cb.const_type } + const_type = subst_mps sub cb.const_type } let subst_regular_ind_arity sub s = diff --git a/checker/environ.ml b/checker/environ.ml index d3f393c651..a0818012c7 100644 --- a/checker/environ.ml +++ b/checker/environ.ml @@ -124,12 +124,6 @@ let constraints_of cb u = | Monomorphic_const _ -> Univ.Constraint.empty | Polymorphic_const ctx -> Univ.AUContext.instantiate u ctx -let map_regular_arity f = function - | RegularArity a as ar -> - let a' = f a in - if a' == a then ar else RegularArity a' - | TemplateArity _ -> assert false - (* constant_type gives the type of a constant *) let constant_type env (kn,u) = let cb = lookup_constant kn env in @@ -137,7 +131,7 @@ let constant_type env (kn,u) = | Monomorphic_const _ -> cb.const_type, Univ.Constraint.empty | Polymorphic_const ctx -> let csts = constraints_of cb u in - (map_regular_arity (subst_instance_constr u) cb.const_type, csts) + (subst_instance_constr u cb.const_type, csts) exception NotEvaluableConst of const_evaluation_result diff --git a/checker/environ.mli b/checker/environ.mli index 754c295d27..8e8d0fd49c 100644 --- a/checker/environ.mli +++ b/checker/environ.mli @@ -46,7 +46,7 @@ val check_constraints : Univ.constraints -> env -> bool (* Constants *) val lookup_constant : constant -> env -> Cic.constant_body val add_constant : constant -> Cic.constant_body -> env -> env -val constant_type : env -> constant puniverses -> constant_type Univ.constrained +val constant_type : env -> constant puniverses -> constr Univ.constrained type const_evaluation_result = NoBody | Opaque | IsProj exception NotEvaluableConst of const_evaluation_result val constant_value : env -> constant puniverses -> constr diff --git a/checker/indtypes.mli b/checker/indtypes.mli index 7eaaf65f22..b0554989ef 100644 --- a/checker/indtypes.mli +++ b/checker/indtypes.mli @@ -12,8 +12,8 @@ open Cic open Environ (*i*) -val prkn : kernel_name -> Pp.std_ppcmds -val prcon : constant -> Pp.std_ppcmds +val prkn : kernel_name -> Pp.t +val prcon : constant -> Pp.t (*s The different kinds of errors that may result of a malformed inductive definition. *) diff --git a/checker/mod_checking.ml b/checker/mod_checking.ml index 4948f6008f..b6816dd484 100644 --- a/checker/mod_checking.ml +++ b/checker/mod_checking.ml @@ -35,15 +35,11 @@ let check_constant_declaration env kn cb = push_context ~strict:false ctx env in let envty, ty = - match cb.const_type with - RegularArity ty -> - let ty', cu = refresh_arity ty in - let envty = push_context_set cu env' in - let _ = infer_type envty ty' in envty, ty - | TemplateArity(ctxt,par) -> - let _ = check_ctxt env' ctxt in - check_polymorphic_arity env' ctxt par; - env', it_mkProd_or_LetIn (Sort(Type par.template_level)) ctxt + let ty = cb.const_type in + let ty', cu = refresh_arity ty in + let envty = push_context_set cu env' in + let _ = infer_type envty ty' in + envty, ty in let () = match body_of_constant cb with diff --git a/checker/subtyping.ml b/checker/subtyping.ml index 3097c3a0b9..68a467bea2 100644 --- a/checker/subtyping.ml +++ b/checker/subtyping.ml @@ -294,8 +294,8 @@ let check_constant env mp1 l info1 cb2 spec2 subst1 subst2 = let cb1 = subst_const_body subst1 cb1 in let cb2 = subst_const_body subst2 cb2 in (*Start by checking types*) - let typ1 = Typeops.type_of_constant_type env cb1.const_type in - let typ2 = Typeops.type_of_constant_type env cb2.const_type in + let typ1 = cb1.const_type in + let typ2 = cb2.const_type in check_type env typ1 typ2; (* Now we check the bodies: - A transparent constant can only be implemented by a compatible diff --git a/checker/typeops.ml b/checker/typeops.ml index f2cbfec7db..9f39d588a7 100644 --- a/checker/typeops.ml +++ b/checker/typeops.ml @@ -69,35 +69,16 @@ let judge_of_relative env n = (* Type of constants *) - -let type_of_constant_type_knowing_parameters env t paramtyps = - match t with - | RegularArity t -> t - | TemplateArity (sign,ar) -> - let ctx = List.rev sign in - let ctx,s = instantiate_universes env ctx ar paramtyps in - mkArity (List.rev ctx,s) - -let type_of_constant_knowing_parameters env cst paramtyps = - let ty, cu = constant_type env cst in - type_of_constant_type_knowing_parameters env ty paramtyps, cu - -let type_of_constant_type env t = - type_of_constant_type_knowing_parameters env t [||] - -let judge_of_constant_knowing_parameters env (kn,u as cst) paramstyp = +let judge_of_constant env (kn,u as cst) = let _cb = try lookup_constant kn env with Not_found -> failwith ("Cannot find constant: "^Constant.to_string kn) in - let ty, cu = type_of_constant_knowing_parameters env cst paramstyp in + let ty, cu = constant_type env cst in let () = check_constraints cu env in ty -let judge_of_constant env cst = - judge_of_constant_knowing_parameters env cst [||] - (* Type of an application. *) let judge_of_apply env (f,funj) argjv = @@ -276,8 +257,6 @@ let rec execute env cstr = match f with | Ind ind -> judge_of_inductive_knowing_parameters env ind jl - | Const cst -> - judge_of_constant_knowing_parameters env cst jl | _ -> (* No template polymorphism *) execute env f diff --git a/checker/typeops.mli b/checker/typeops.mli index 2be461b052..d9f2915a30 100644 --- a/checker/typeops.mli +++ b/checker/typeops.mli @@ -18,6 +18,3 @@ val infer_type : env -> constr -> sorts val check_ctxt : env -> rel_context -> env val check_polymorphic_arity : env -> rel_context -> template_arity -> unit - -val type_of_constant_type : env -> constant_type -> constr - diff --git a/checker/univ.ml b/checker/univ.ml index e3abc436f0..558315c2c1 100644 --- a/checker/univ.ml +++ b/checker/univ.ml @@ -1071,7 +1071,7 @@ module Instance : sig val equal : t -> t -> bool val subst_fn : universe_level_subst_fn -> t -> t val subst : universe_level_subst -> t -> t - val pr : t -> Pp.std_ppcmds + val pr : t -> Pp.t val check_eq : t check_function val length : t -> int val append : t -> t -> t diff --git a/checker/univ.mli b/checker/univ.mli index 7f5aa76260..0a21019b1b 100644 --- a/checker/univ.mli +++ b/checker/univ.mli @@ -20,7 +20,7 @@ sig val var : int -> t - val pr : t -> Pp.std_ppcmds + val pr : t -> Pp.t (** Pretty-printing *) val equal : t -> t -> bool @@ -53,7 +53,7 @@ type universe = Universe.t (** Alias name. *) -val pr_uni : universe -> Pp.std_ppcmds +val pr_uni : universe -> Pp.t (** The universes hierarchy: Type 0- = Prop <= Type 0 = Set <= Type 1 <= ... Typing of universes: Type 0-, Type 0 : Type 1; Type i : Type (i+1) if i>0 *) @@ -172,7 +172,7 @@ sig val subst : universe_level_subst -> t -> t (** Substitution by a level-to-level function. *) - val pr : t -> Pp.std_ppcmds + val pr : t -> Pp.t (** Pretty-printing, no comments *) val check_eq : t check_function @@ -274,8 +274,8 @@ val check_subtype : universes -> AUContext.t -> AUContext.t -> bool (** {6 Pretty-printing of universes. } *) -val pr_constraint_type : constraint_type -> Pp.std_ppcmds -val pr_constraints : (Level.t -> Pp.std_ppcmds) -> constraints -> Pp.std_ppcmds -val pr_universe_context : (Level.t -> Pp.std_ppcmds) -> universe_context -> Pp.std_ppcmds +val pr_constraint_type : constraint_type -> Pp.t +val pr_constraints : (Level.t -> Pp.t) -> constraints -> Pp.t +val pr_universe_context : (Level.t -> Pp.t) -> universe_context -> Pp.t -val pr_universes : universes -> Pp.std_ppcmds +val pr_universes : universes -> Pp.t diff --git a/checker/values.ml b/checker/values.ml index e13430e98e..c95c3f1b2b 100644 --- a/checker/values.ml +++ b/checker/values.ml @@ -13,7 +13,7 @@ To ensure this file is up-to-date, 'make' now compares the md5 of cic.mli with a copy we maintain here: -MD5 67309b04a86b247431fd3e580ecbb50d checker/cic.mli +MD5 c802f941f368bedd96e931cda0559d67 checker/cic.mli *) @@ -201,9 +201,6 @@ let v_engagement = v_impredicative_set let v_pol_arity = v_tuple "polymorphic_arity" [|List(Opt v_level);v_univ|] -let v_cst_type = - v_sum "constant_type" 0 [|[|v_constr|]; [|v_pair v_rctxt v_pol_arity|]|] - let v_cst_def = v_sum "constant_def" 0 [|[|Opt Int|]; [|v_cstr_subst|]; [|v_lazy_constr|]|] @@ -222,7 +219,7 @@ let v_const_univs = v_sum "constant_universes" 0 [|[|v_context|]; [|v_abs_contex let v_cb = v_tuple "constant_body" [|v_section_ctxt; v_cst_def; - v_cst_type; + v_constr; Any; v_const_univs; Opt v_projbody; diff --git a/configure.ml b/configure.ml index e13fa80fda..4eac8eaccf 100644 --- a/configure.ml +++ b/configure.ml @@ -300,27 +300,17 @@ let args_options = Arg.align [ "<dir> Where to install doc files"; "-emacslib", arg_string_option Prefs.emacslib, "<dir> Where to install emacs files"; - "-emacs", Arg.String (fun s -> - prerr_endline "Warning: -emacs option is deprecated. Use -emacslib instead."; - Prefs.emacslib := Some s), - "<dir> Deprecated: same as -emacslib"; "-coqdocdir", arg_string_option Prefs.coqdocdir, "<dir> Where to install Coqdoc style files"; "-ocamlfind", arg_string_option Prefs.ocamlfindcmd, "<dir> Specifies the ocamlfind command to use"; "-lablgtkdir", arg_string_option Prefs.lablgtkdir, "<dir> Specifies the path to the Lablgtk library"; - "-usecamlp5", Arg.Unit (fun () -> - prerr_endline "Warning: -usecamlp5 option is deprecated. Camlp5 is already a required dependency."), - " Deprecated: Camlp5 is a required dependency (Camlp4 is not supported anymore)"; "-camlp5dir", Arg.String (fun s -> Prefs.camlp5dir:=Some s), "<dir> Specifies where is the Camlp5 library and tells to use it"; "-arch", arg_string_option Prefs.arch, "<arch> Specifies the architecture"; - "-opt", Arg.Unit (fun () -> - prerr_endline "Warning: -opt option is deprecated. Native OCaml executables are detected automatically."), - " Deprecated: native OCaml executables detected automatically"; "-natdynlink", arg_bool Prefs.natdynlink, "(yes|no) Use dynamic loading of native code or not"; "-coqide", Arg.String (fun s -> Prefs.coqide := Some (get_ide s)), @@ -329,33 +319,18 @@ let args_options = Arg.align [ " Do not try to build CoqIDE MacOS integration"; "-browser", arg_string_option Prefs.browser, "<command> Use <command> to open URL %s"; - "-nodoc", Arg.Unit (fun () -> - prerr_endline "Warning: -nodoc option is deprecated. Use -with-doc no instead."; - Prefs.withdoc := false), - " Deprecated: use -with-doc no instead"; "-with-doc", arg_bool Prefs.withdoc, "(yes|no) Compile the documentation or not"; "-with-geoproof", arg_bool Prefs.geoproof, "(yes|no) Use Geoproof binding or not"; "-byte-only", Arg.Set Prefs.byteonly, " Compiles only bytecode version of Coq"; - "-byteonly", Arg.Unit (fun () -> - prerr_endline "Warning: -byteonly option is deprecated. Use -byte-only instead."; - Prefs.byteonly := true), - " Deprecated: use -byte-only instead"; - "-debug", Arg.Unit (fun () -> - prerr_endline "Warning: -debug option is deprecated. Coq is compiled in debug mode by default."; - Prefs.debug := true), - " Deprecated: Coq is compiled in debug mode by default"; "-nodebug", Arg.Clear Prefs.debug, " Do not add debugging information in the Coq executables"; "-profile", Arg.Set Prefs.profile, " Add profiling information in the Coq executables"; "-annotate", Arg.Set Prefs.annotate, " Dumps ml annotation files while compiling Coq"; - "-makecmd", Arg.String (fun _ -> - prerr_endline "Warning: -makecmd option is deprecated and doesn't have any effect."), - "<command> Deprecated"; "-native-compiler", arg_bool Prefs.nativecompiler, "(yes|no) Compilation to native code for conversion and normalization"; "-coqwebsite", Arg.Set_string Prefs.coqwebsite, diff --git a/dev/base_include b/dev/base_include index bfbf6bb5d8..79ecd73e0d 100644 --- a/dev/base_include +++ b/dev/base_include @@ -194,8 +194,8 @@ let qid = Libnames.qualid_of_string;; (* parsing of terms *) let parse_constr = Pcoq.parse_string Pcoq.Constr.constr;; -let parse_tac = Pcoq.parse_string Ltac_plugin.Pltac.tactic;; let parse_vernac = Pcoq.parse_string Pcoq.Vernac_.vernac;; +let parse_tac = API.Pcoq.parse_string Ltac_plugin.Pltac.tactic;; (* build a term of type glob_constr without type-checking or resolution of implicit syntax *) diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index 6560305433..4b3b44875f 100644 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -85,8 +85,8 @@ ######################################################################## # fiat_parsers ######################################################################## -: ${fiat_parsers_CI_BRANCH:=trunk__API} -: ${fiat_parsers_CI_GITURL:=https://github.com/matejkosik/fiat.git} +: ${fiat_parsers_CI_BRANCH:=master} +: ${fiat_parsers_CI_GITURL:=https://github.com/mit-plv/fiat.git} ######################################################################## # fiat_crypto diff --git a/dev/ci/ci-hott.sh b/dev/ci/ci-hott.sh index 693135a4c9..1bf6e9a872 100755 --- a/dev/ci/ci-hott.sh +++ b/dev/ci/ci-hott.sh @@ -7,4 +7,4 @@ HoTT_CI_DIR=${CI_BUILD_DIR}/HoTT git_checkout ${HoTT_CI_BRANCH} ${HoTT_CI_GITURL} ${HoTT_CI_DIR} -( cd ${HoTT_CI_DIR} && ./autogen.sh && ./configure && make ) +( cd ${HoTT_CI_DIR} && ./autogen.sh && ./configure && make -j ${NJOBS} ) diff --git a/dev/doc/build-system.dev.txt b/dev/doc/build-system.dev.txt index fefcb0937a..f3fc13e969 100644 --- a/dev/doc/build-system.dev.txt +++ b/dev/doc/build-system.dev.txt @@ -74,25 +74,25 @@ The Makefile is separated in several files : - Makefile.doc : specific rules for compiling the documentation. -FIND_VCS_CLAUSE +FIND_SKIP_DIRS --------------- -The recommended style of using FIND_VCS_CLAUSE is for example +The recommended style of using FIND_SKIP_DIRS is for example - find . $(FIND_VCS_CLAUSE) '(' -name '*.example' ')' -print - find . $(FIND_VCS_CLAUSE) '(' -name '*.example' -or -name '*.foo' ')' -print + find . $(FIND_SKIP_DIRS) '(' -name '*.example' ')' -print + find . $(FIND_SKIP_DIRS) '(' -name '*.example' -or -name '*.foo' ')' -print 1) The parentheses even in the one-criteria case is so that if one adds other conditions, e.g. change the first example to the second - find . $(FIND_VCS_CLAUSE) '(' -name '*.example' -and -not -name '*.bak.example' ')' -print + find . $(FIND_SKIP_DIRS) '(' -name '*.example' -and -not -name '*.bak.example' ')' -print one is not tempted to write - find . $(FIND_VCS_CLAUSE) -name '*.example' -and -not -name '*.bak.example' -print + find . $(FIND_SKIP_DIRS) -name '*.example' -and -not -name '*.bak.example' -print -because this will not necessarily work as expected; $(FIND_VCS_CLAUSE) +because this will not necessarily work as expected; $(FIND_SKIP_DIRS) ends with an -or, and how it combines with what comes later depends on operator precedence and all that. Much safer to override it with parentheses. @@ -105,13 +105,13 @@ As to the -print at the end, yes it is necessary. Here's why. You are used to write: find . -name '*.example' and it works fine. But the following will not: - find . $(FIND_VCS_CLAUSE) -name '*.example' -it will also list things directly matched by FIND_VCS_CLAUSE + find . $(FIND_SKIP_DIRS) -name '*.example' +it will also list things directly matched by FIND_SKIP_DIRS (directories we want to prune, in which we don't want to find anything). C'est subtil... Il y a effectivement un -print implicite ร la fin, qui fait que la commande habituelle sans print fonctionne bien, mais dรจs que l'on introduit d'autres commandes dans le lot (le --prune de FIND_VCS_CLAUSE), รงa se corse ร cause d'histoires de +-prune de FIND_SKIP_DIRS), รงa se corse ร cause d'histoires de parenthรจses du -print implicite par rapport au parenthรฉsage dans la forme recommandรฉe d'utilisation: diff --git a/dev/doc/changes.txt b/dev/doc/changes.txt index 57c7a97d58..a48c491d33 100644 --- a/dev/doc/changes.txt +++ b/dev/doc/changes.txt @@ -18,6 +18,10 @@ We changed the type of the following functions: The returned term contains De Bruijn universe variables. - Global.body_of_constant: same as above. +We renamed the following datatypes: + + Pp.std_ppcmds -> Pp.t + ========================================= = CHANGES BETWEEN COQ V8.6 AND COQ V8.7 = ========================================= diff --git a/dev/doc/debugging.txt b/dev/doc/debugging.txt index 79cde48849..3e2b435b3e 100644 --- a/dev/doc/debugging.txt +++ b/dev/doc/debugging.txt @@ -1,7 +1,7 @@ Debugging from Coq toplevel using Caml trace mechanism ====================================================== - 1. Launch bytecode version of Coq (coqtop.byte or coqtop -byte) + 1. Launch bytecode version of Coq (coqtop.byte) 2. Access Ocaml toplevel using vernacular command 'Drop.' 3. Install load paths and pretty printers for terms, idents, ... using Ocaml command '#use "base_include";;' (use '#use "include";;' for diff --git a/dev/doc/naming-conventions.tex b/dev/doc/naming-conventions.tex index 349164948d..337b9226df 100644 --- a/dev/doc/naming-conventions.tex +++ b/dev/doc/naming-conventions.tex @@ -267,7 +267,7 @@ If the conclusion is in the other way than listed below, add suffix {forall x y:D, op (op' x y) = op' x (op y)} \itemrule{Idempotency of binary operator {\op} on domain {\D}}{Dop\_idempotent} -{forall x:D, op x n = x} +{forall x:D, op x x = x} \itemrule{Idempotency of unary operator {\op} on domain {\D}}{Dop\_idempotent} {forall x:D, op (op x) = op x} diff --git a/dev/top_printers.ml b/dev/top_printers.ml index 9884a0109a..ffa8fffdf5 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -229,7 +229,7 @@ let ppenvwithcst e = pp str "[" ++ pr_rel_context e Evd.empty (rel_context e) ++ str "]" ++ spc() ++ str "{" ++ Cmap_env.fold (fun a _ s -> pr_con a ++ spc () ++ s) (Obj.magic e).Pre_env.env_globals.Pre_env.env_constants (mt ()) ++ str "}") -let pptac = (fun x -> pp(Ltac_plugin.Pptactic.pr_glob_tactic (Global.env()) x)) +let pptac = (fun x -> pp(Ltac_plugin.Pptactic.pr_glob_tactic (API.Global.env()) x)) let ppobj obj = Format.print_string (Libobject.object_tag obj) @@ -494,7 +494,6 @@ VERNAC COMMAND EXTEND PrintConstr END *) -open Grammar_API open Genarg open Stdarg open Egramml diff --git a/doc/refman/AsyncProofs.tex b/doc/refman/AsyncProofs.tex index 7ffe252253..b93ca29577 100644 --- a/doc/refman/AsyncProofs.tex +++ b/doc/refman/AsyncProofs.tex @@ -6,7 +6,7 @@ This chapter explains how proofs can be asynchronously processed by Coq. This feature improves the reactivity of the system when used in interactive -mode via CoqIDE. In addition to that, it allows Coq to take advantage of +mode via CoqIDE. In addition, it allows Coq to take advantage of parallel hardware when used as a batch compiler by decoupling the checking of statements and definitions from the construction and checking of proofs objects. @@ -22,7 +22,12 @@ For example, in interactive mode, some errors coming from the kernel of Coq are signaled late. The type of errors belonging to this category are universe inconsistencies. -Last, at the time of writing, only opaque proofs (ending with \texttt{Qed} or \texttt{Admitted}) can be processed asynchronously. +At the time of writing, only opaque proofs (ending with \texttt{Qed} or \texttt{Admitted}) can be processed asynchronously. + +Finally, asynchronous processing is disabled when running CoqIDE in Windows. The +current implementation of the feature is not stable on Windows. It can be +enabled, as described below at \ref{interactivecaveats}, though doing so is not +recommended. \section{Proof annotations} @@ -112,6 +117,7 @@ the kernel to check all the proof objects, one has to click the button with the gears. Only then are all the universe constraints checked. \subsubsection{Caveats} +\label{interactivecaveats} The number of worker processes can be increased by passing CoqIDE the \texttt{-async-proofs-j $n$} flag. Note that the memory consumption @@ -120,7 +126,8 @@ the master process. Also note that increasing the number of workers may reduce the reactivity of the master process to user commands. To disable this feature, one can pass the \texttt{-async-proofs off} flag to -CoqIDE. +CoqIDE. Conversely, on Windows, where the feature is disabled by default, +pass the \texttt{-async-proofs on} flag to enable it. Proofs that are known to take little time to process are not delegated to a worker process. The threshold can be configure with \texttt{-async-proofs-delegation-threshold}. Default is 0.03 seconds. diff --git a/doc/refman/RefMan-oth.tex b/doc/refman/RefMan-oth.tex index 3daaac88b1..bf48057cdf 100644 --- a/doc/refman/RefMan-oth.tex +++ b/doc/refman/RefMan-oth.tex @@ -656,7 +656,7 @@ dynamically. searched into the current {\ocaml} loadpath (see the command {\tt Add ML Path} in the Section~\ref{loadpath}). Loading of {\ocaml} files is only possible under the bytecode version of {\tt coqtop} -(i.e. {\tt coqtop} called with options {\tt -byte}, see chapter +(i.e. {\tt coqtop.byte}, see chapter \ref{Addoc-coqc}), or when {\Coq} has been compiled with a version of {\ocaml} that supports native {\tt Dynlink} ($\ge$ 3.11). @@ -739,7 +739,7 @@ the command {\tt Declare ML Module} in the Section~\ref{compiled}). \subsection[\tt Print ML Path {\str}.]{\tt Print ML Path {\str}.\comindex{Print ML Path}} This command displays the current {\ocaml} loadpath. This command makes sense only under the bytecode version of {\tt -coqtop}, i.e. using option {\tt -byte} (see the +coqtop}, i.e. {\tt coqtop.byte} (see the command {\tt Declare ML Module} in the section \ref{compiled}). diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index 48f82f2d92..48048b7a0f 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -591,5 +591,6 @@ through the <tt>Require Import</tt> command.</p> theories/Compat/AdmitAxiom.v theories/Compat/Coq85.v theories/Compat/Coq86.v + theories/Compat/Coq87.v </dd> </dl> diff --git a/engine/geninterp.ml b/engine/geninterp.ml index 9964433a80..e79e258fbc 100644 --- a/engine/geninterp.ml +++ b/engine/geninterp.ml @@ -32,7 +32,7 @@ struct let repr = ValT.repr let create = ValT.create - let pr : type a. a typ -> Pp.std_ppcmds = fun t -> Pp.str (repr t) + let pr : type a. a typ -> Pp.t = fun t -> Pp.str (repr t) let typ_list = ValT.create "list" let typ_opt = ValT.create "option" diff --git a/engine/geninterp.mli b/engine/geninterp.mli index 9a925dcd89..492e372adb 100644 --- a/engine/geninterp.mli +++ b/engine/geninterp.mli @@ -30,7 +30,7 @@ sig val eq : 'a typ -> 'b typ -> ('a, 'b) CSig.eq option val repr : 'a typ -> string - val pr : 'a typ -> Pp.std_ppcmds + val pr : 'a typ -> Pp.t val typ_list : t list typ val typ_opt : t option typ diff --git a/engine/logic_monad.mli b/engine/logic_monad.mli index aaebe4c1b0..8c8f9fe935 100644 --- a/engine/logic_monad.mli +++ b/engine/logic_monad.mli @@ -57,11 +57,11 @@ module NonLogical : sig val print_char : char -> unit t (** Loggers. The buffer is also flushed. *) - val print_debug : Pp.std_ppcmds -> unit t - val print_warning : Pp.std_ppcmds -> unit t - val print_notice : Pp.std_ppcmds -> unit t - val print_info : Pp.std_ppcmds -> unit t - val print_error : Pp.std_ppcmds -> unit t + val print_debug : Pp.t -> unit t + val print_warning : Pp.t -> unit t + val print_notice : Pp.t -> unit t + val print_info : Pp.t -> unit t + val print_error : Pp.t -> unit t (** [Pervasives.raise]. Except that exceptions are wrapped with {!Exception}. *) diff --git a/engine/proofview.ml b/engine/proofview.ml index b4e2160f4e..eef2b83f44 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -332,7 +332,7 @@ exception NoSuchGoals of int (* This hook returns a string to be appended to the usual message. Primarily used to add a suggestion about the right bullet to use to focus the next goal, if applicable. *) -let nosuchgoals_hook:(int -> std_ppcmds) ref = ref (fun n -> mt ()) +let nosuchgoals_hook:(int -> Pp.t) ref = ref (fun n -> mt ()) let set_nosuchgoals_hook f = nosuchgoals_hook := f diff --git a/engine/proofview.mli b/engine/proofview.mli index 957c9213c4..d92d0a7d53 100644 --- a/engine/proofview.mli +++ b/engine/proofview.mli @@ -235,7 +235,7 @@ val tclBREAK : (iexn -> iexn option) -> 'a tactic -> 'a tactic This hook is used to add a suggestion about bullets when applicable. *) exception NoSuchGoals of int -val set_nosuchgoals_hook: (int -> Pp.std_ppcmds) -> unit +val set_nosuchgoals_hook: (int -> Pp.t) -> unit val tclFOCUS : int -> int -> 'a tactic -> 'a tactic @@ -526,7 +526,7 @@ module Trace : sig val log : Proofview_monad.lazy_msg -> unit tactic val name_tactic : Proofview_monad.lazy_msg -> 'a tactic -> 'a tactic - val pr_info : ?lvl:int -> Proofview_monad.Info.tree -> Pp.std_ppcmds + val pr_info : ?lvl:int -> Proofview_monad.Info.tree -> Pp.t end diff --git a/engine/proofview_monad.ml b/engine/proofview_monad.ml index 1b737b6f4d..d0f4712258 100644 --- a/engine/proofview_monad.ml +++ b/engine/proofview_monad.ml @@ -62,7 +62,7 @@ end (** We typically label nodes of [Trace.tree] with messages to print. But we don't want to compute the result. *) -type lazy_msg = unit -> Pp.std_ppcmds +type lazy_msg = unit -> Pp.t let pr_lazy_msg msg = msg () (** Info trace. *) diff --git a/engine/proofview_monad.mli b/engine/proofview_monad.mli index 554583421b..e7123218b1 100644 --- a/engine/proofview_monad.mli +++ b/engine/proofview_monad.mli @@ -43,7 +43,7 @@ end (** We typically label nodes of [Trace.tree] with messages to print. But we don't want to compute the result. *) -type lazy_msg = unit -> Pp.std_ppcmds +type lazy_msg = unit -> Pp.t (** Info trace. *) module Info : sig @@ -58,7 +58,7 @@ module Info : sig type state = tag Trace.incr type tree = tag Trace.forest - val print : tree -> Pp.std_ppcmds + val print : tree -> Pp.t (** [collapse n t] flattens the first [n] levels of [Tactic] in an info trace, effectively forgetting about the [n] top level of diff --git a/engine/termops.ml b/engine/termops.ml index 1aba2bbdd1..2bd0c06d6d 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -994,12 +994,14 @@ let rec strip_outer_cast sigma c = match EConstr.kind sigma c with (* flattens application lists throwing casts in-between *) let collapse_appl sigma c = match EConstr.kind sigma c with | App (f,cl) -> + if EConstr.isCast sigma f then let rec collapse_rec f cl2 = match EConstr.kind sigma (strip_outer_cast sigma f) with | App (g,cl1) -> collapse_rec g (Array.append cl1 cl2) | _ -> EConstr.mkApp (f,cl2) in collapse_rec f cl + else c | _ -> c (* First utilities for avoiding telescope computation for subst_term *) @@ -1145,9 +1147,6 @@ let is_template_polymorphic env sigma f = | Ind (ind, u) -> if not (EConstr.EInstance.is_empty u) then false else Environ.template_polymorphic_ind ind env - | Const (cst, u) -> - if not (EConstr.EInstance.is_empty u) then false - else Environ.template_polymorphic_constant cst env | _ -> false let base_sort_cmp pb s0 s1 = diff --git a/engine/termops.mli b/engine/termops.mli index c19a2d15a5..2624afd30d 100644 --- a/engine/termops.mli +++ b/engine/termops.mli @@ -9,16 +9,15 @@ (** This file defines various utilities for term manipulation that are not needed in the kernel. *) -open Pp open Names open Term open Environ open EConstr (** printers *) -val print_sort : sorts -> std_ppcmds -val pr_sort_family : sorts_family -> std_ppcmds -val pr_fix : ('a -> std_ppcmds) -> ('a, 'a) pfixpoint -> std_ppcmds +val print_sort : sorts -> Pp.t +val pr_sort_family : sorts_family -> Pp.t +val pr_fix : ('a -> Pp.t) -> ('a, 'a) pfixpoint -> Pp.t (** about contexts *) val push_rel_assum : Name.t * types -> env -> env @@ -279,25 +278,25 @@ val on_judgment_type : ('t -> 't) -> ('c, 't) punsafe_judgment -> ('c, 't) puns open Evd -val pr_existential_key : evar_map -> evar -> Pp.std_ppcmds +val pr_existential_key : evar_map -> evar -> Pp.t val pr_evar_suggested_name : existential_key -> evar_map -> Id.t -val pr_evar_info : evar_info -> Pp.std_ppcmds -val pr_evar_constraints : evar_map -> evar_constraint list -> Pp.std_ppcmds -val pr_evar_map : ?with_univs:bool -> int option -> evar_map -> Pp.std_ppcmds +val pr_evar_info : evar_info -> Pp.t +val pr_evar_constraints : evar_map -> evar_constraint list -> Pp.t +val pr_evar_map : ?with_univs:bool -> int option -> evar_map -> Pp.t val pr_evar_map_filter : ?with_univs:bool -> (Evar.t -> evar_info -> bool) -> - evar_map -> Pp.std_ppcmds -val pr_metaset : Metaset.t -> Pp.std_ppcmds -val pr_evar_universe_context : evar_universe_context -> Pp.std_ppcmds -val pr_evd_level : evar_map -> Univ.Level.t -> Pp.std_ppcmds + evar_map -> Pp.t +val pr_metaset : Metaset.t -> Pp.t +val pr_evar_universe_context : evar_universe_context -> Pp.t +val pr_evd_level : evar_map -> Univ.Level.t -> Pp.t (** debug printer: do not use to display terms to the casual user... *) -val set_print_constr : (env -> Evd.evar_map -> constr -> std_ppcmds) -> unit -val print_constr : constr -> std_ppcmds -val print_constr_env : env -> Evd.evar_map -> constr -> std_ppcmds -val print_named_context : env -> std_ppcmds -val pr_rel_decl : env -> Context.Rel.Declaration.t -> std_ppcmds -val print_rel_context : env -> std_ppcmds -val print_env : env -> std_ppcmds +val set_print_constr : (env -> Evd.evar_map -> constr -> Pp.t) -> unit +val print_constr : constr -> Pp.t +val print_constr_env : env -> Evd.evar_map -> constr -> Pp.t +val print_named_context : env -> Pp.t +val pr_rel_decl : env -> Context.Rel.Declaration.t -> Pp.t +val print_rel_context : env -> Pp.t +val print_env : env -> Pp.t diff --git a/engine/uState.mli b/engine/uState.mli index 3776e4c9fd..d198fbfbe9 100644 --- a/engine/uState.mli +++ b/engine/uState.mli @@ -123,4 +123,4 @@ val update_sigma_env : t -> Environ.env -> t (** {5 Pretty-printing} *) -val pr_uctx_level : t -> Univ.Level.t -> Pp.std_ppcmds +val pr_uctx_level : t -> Univ.Level.t -> Pp.t diff --git a/engine/universes.ml b/engine/universes.ml index 08461a2186..719af43edf 100644 --- a/engine/universes.ml +++ b/engine/universes.ml @@ -419,7 +419,7 @@ let type_of_reference env r = | VarRef id -> Environ.named_type id env, ContextSet.empty | ConstRef c -> let cb = Environ.lookup_constant c env in - let ty = Typeops.type_of_constant_type env cb.const_type in + let ty = cb.const_type in begin match cb.const_universes with | Monomorphic_const _ -> ty, ContextSet.empty diff --git a/engine/universes.mli b/engine/universes.mli index 0f6e419d00..fe40f82385 100644 --- a/engine/universes.mli +++ b/engine/universes.mli @@ -17,7 +17,7 @@ val is_set_minimization : unit -> bool (** Universes *) -val pr_with_global_universes : Level.t -> Pp.std_ppcmds +val pr_with_global_universes : Level.t -> Pp.t (** Local universe name <-> level mapping *) @@ -52,7 +52,7 @@ type universe_constraint = universe * universe_constraint_type * universe module Constraints : sig include Set.S with type elt = universe_constraint - val pr : t -> Pp.std_ppcmds + val pr : t -> Pp.t end type universe_constraints = Constraints.t @@ -203,7 +203,7 @@ val refresh_constraints : UGraph.t -> universe_context_set -> universe_context_s (** Pretty-printing *) -val pr_universe_opt_subst : universe_opt_subst -> Pp.std_ppcmds +val pr_universe_opt_subst : universe_opt_subst -> Pp.t (** {6 Support for template polymorphism } *) diff --git a/grammar/argextend.mlp b/grammar/argextend.mlp index cc92680fcf..12b7b171b7 100644 --- a/grammar/argextend.mlp +++ b/grammar/argextend.mlp @@ -46,17 +46,17 @@ let make_act loc act pil = make (List.rev pil) let make_prod_item = function - | ExtTerminal s -> <:expr< Grammar_API.Extend.Atoken (Grammar_API.CLexer.terminal $mlexpr_of_string s$) >> + | ExtTerminal s -> <:expr< Extend.Atoken (CLexer.terminal $mlexpr_of_string s$) >> | ExtNonTerminal (g, _) -> let base s = <:expr< $lid:s$ >> in mlexpr_of_prod_entry_key base g let rec make_prod = function -| [] -> <:expr< Grammar_API.Extend.Stop >> -| item :: prods -> <:expr< Grammar_API.Extend.Next $make_prod prods$ $make_prod_item item$ >> +| [] -> <:expr< Extend.Stop >> +| item :: prods -> <:expr< Extend.Next $make_prod prods$ $make_prod_item item$ >> let make_rule loc (prods,act) = - <:expr< Grammar_API.Extend.Rule $make_prod (List.rev prods)$ $make_act loc act prods$ >> + <:expr< Extend.Rule $make_prod (List.rev prods)$ $make_act loc act prods$ >> let is_ident x = function | <:expr< $lid:s$ >> -> (s : string) = x @@ -67,7 +67,7 @@ let make_extend loc s cl wit = match cl with (** Special handling of identity arguments by not redeclaring an entry *) <:str_item< value $lid:s$ = - let () = Grammar_API.Pcoq.register_grammar $wit$ $lid:e$ in + let () = Pcoq.register_grammar $wit$ $lid:e$ in $lid:e$ >> | _ -> @@ -75,8 +75,8 @@ let make_extend loc s cl wit = match cl with let rules = mlexpr_of_list (make_rule loc) (List.rev cl) in <:str_item< value $lid:s$ = - let $lid:s$ = Grammar_API.Pcoq.create_generic_entry Grammar_API.Pcoq.utactic $se$ (Genarg.rawwit $wit$) in - let () = Grammar_API.Pcoq.grammar_extend $lid:s$ None (None, [(None, None, $rules$)]) in + let $lid:s$ = Pcoq.create_generic_entry Pcoq.utactic $se$ (Genarg.rawwit $wit$) in + let () = Pcoq.grammar_extend $lid:s$ None (None, [(None, None, $rules$)]) in $lid:s$ >> let warning_redundant prefix s = @@ -127,7 +127,7 @@ let declare_tactic_argument loc s (typ, f, g, h) cl = begin match globtyp with | None -> let typ = match globtyp with None -> ExtraArgType s | Some typ -> typ in - <:expr< fun ist v -> API.Ftactic.return (API.Geninterp.Val.inject (API.Geninterp.val_tag $make_topwit loc typ$) v) >> + <:expr< fun ist v -> Ftactic.return (Geninterp.Val.inject (Geninterp.val_tag $make_topwit loc typ$) v) >> | Some globtyp -> <:expr< fun ist x -> Tacinterp.interp_genarg ist (Genarg.in_gen $make_globwit loc globtyp$ x) >> @@ -137,10 +137,11 @@ let declare_tactic_argument loc s (typ, f, g, h) cl = let typ = match globtyp with None -> ExtraArgType s | Some typ -> typ in <:expr< let f = $lid:f$ in - fun ist v -> API.Ftactic.nf_enter (fun gl -> - let (sigma, v) = API.Tacmach.New.of_old (fun gl -> f ist gl v) gl in - let v = API.Geninterp.Val.inject (API.Geninterp.val_tag $make_topwit loc typ$) v in - API.Proofview.tclTHEN (API.Proofview.Unsafe.tclEVARS sigma) (API.Ftactic.return v) + fun ist v -> Ftactic.enter (fun gl -> + let gl = Proofview.Goal.assume gl in + let (sigma, v) = Tacmach.New.of_old (fun gl -> f ist gl v) gl in + let v = Geninterp.Val.inject (Geninterp.val_tag $make_topwit loc typ$) v in + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (Ftactic.return v) ) >> in let subst = match h with @@ -156,15 +157,15 @@ let declare_tactic_argument loc s (typ, f, g, h) cl = | Some f -> <:expr< $lid:f$>> in let dyn = match typ with | None -> <:expr< None >> - | Some typ -> <:expr< Some (API.Geninterp.val_tag $make_topwit loc typ$) >> + | Some typ -> <:expr< Some (Geninterp.val_tag $make_topwit loc typ$) >> in let wit = <:expr< $lid:"wit_"^s$ >> in declare_str_items loc [ <:str_item< value ($lid:"wit_"^s$) = Genarg.make0 $se$ >>; - <:str_item< Grammar_API.Genintern.register_intern0 $wit$ $glob$ >>; - <:str_item< Grammar_API.Genintern.register_subst0 $wit$ $subst$ >>; - <:str_item< API.Geninterp.register_interp0 $wit$ $interp$ >>; - <:str_item< API.Geninterp.register_val0 $wit$ $dyn$ >>; + <:str_item< Genintern.register_intern0 $wit$ $glob$ >>; + <:str_item< Genintern.register_subst0 $wit$ $subst$ >>; + <:str_item< Geninterp.register_interp0 $wit$ $interp$ >>; + <:str_item< Geninterp.register_val0 $wit$ $dyn$ >>; make_extend loc s cl wit; <:str_item< do { Pptactic.declare_extra_genarg_pprule diff --git a/grammar/q_util.mlp b/grammar/q_util.mlp index 51a4c35738..536ee7ca56 100644 --- a/grammar/q_util.mlp +++ b/grammar/q_util.mlp @@ -57,23 +57,23 @@ let mlexpr_of_option f = function | Some e -> <:expr< Some $f e$ >> let mlexpr_of_name f = function - | None -> <:expr< API.Names.Name.Anonymous >> - | Some e -> <:expr< API.Names.Name.Name $f e$ >> + | None -> <:expr< Names.Name.Anonymous >> + | Some e -> <:expr< Names.Name.Name $f e$ >> -let symbol_of_string s = <:expr< Grammar_API.Extend.Atoken (Grammar_API.CLexer.terminal $str:s$) >> +let symbol_of_string s = <:expr< Extend.Atoken (CLexer.terminal $str:s$) >> let rec mlexpr_of_prod_entry_key f = function - | Ulist1 s -> <:expr< Grammar_API.Extend.Alist1 $mlexpr_of_prod_entry_key f s$ >> - | Ulist1sep (s,sep) -> <:expr< Grammar_API.Extend.Alist1sep $mlexpr_of_prod_entry_key f s$ $symbol_of_string sep$ >> - | Ulist0 s -> <:expr< Grammar_API.Extend.Alist0 $mlexpr_of_prod_entry_key f s$ >> - | Ulist0sep (s,sep) -> <:expr< Grammar_API.Extend.Alist0sep $mlexpr_of_prod_entry_key f s$ $symbol_of_string sep$ >> - | Uopt s -> <:expr< Grammar_API.Extend.Aopt $mlexpr_of_prod_entry_key f s$ >> - | Uentry e -> <:expr< Grammar_API.Extend.Aentry ($f e$) >> + | Ulist1 s -> <:expr< Extend.Alist1 $mlexpr_of_prod_entry_key f s$ >> + | Ulist1sep (s,sep) -> <:expr< Extend.Alist1sep $mlexpr_of_prod_entry_key f s$ $symbol_of_string sep$ >> + | Ulist0 s -> <:expr< Extend.Alist0 $mlexpr_of_prod_entry_key f s$ >> + | Ulist0sep (s,sep) -> <:expr< Extend.Alist0sep $mlexpr_of_prod_entry_key f s$ $symbol_of_string sep$ >> + | Uopt s -> <:expr< Extend.Aopt $mlexpr_of_prod_entry_key f s$ >> + | Uentry e -> <:expr< Extend.Aentry ($f e$) >> | Uentryl (e, l) -> (** Keep in sync with Pcoq! *) assert (e = "tactic"); - if l = 5 then <:expr< Grammar_API.Extend.Aentry Pltac.binder_tactic >> - else <:expr< Grammar_API.Extend.Aentryl (Pltac.tactic_expr) $mlexpr_of_int l$ >> + if l = 5 then <:expr< Extend.Aentry Pltac.binder_tactic >> + else <:expr< Extend.Aentryl (Pltac.tactic_expr) $mlexpr_of_int l$ >> let rec type_of_user_symbol = function | Ulist1 s | Ulist1sep (s, _) | Ulist0 s | Ulist0sep (s, _) -> diff --git a/grammar/tacextend.mlp b/grammar/tacextend.mlp index 079d2e4e47..0b33dab051 100644 --- a/grammar/tacextend.mlp +++ b/grammar/tacextend.mlp @@ -25,7 +25,7 @@ let plugin_name = <:expr< __coq_plugin_name >> let mlexpr_of_ident id = (** Workaround for badly-designed generic arguments lacking a closure *) let id = "$" ^ id in - <:expr< API.Names.Id.of_string_soft $str:id$ >> + <:expr< Names.Id.of_string_soft $str:id$ >> let rec make_patt = function | [] -> <:patt< [] >> @@ -57,18 +57,18 @@ let make_fun_clauses loc s l = let get_argt e = <:expr< (fun e -> match e with [ Genarg.ExtraArg tag -> tag | _ -> assert False ]) $e$ >> let rec mlexpr_of_symbol = function -| Ulist1 s -> <:expr< Grammar_API.Extend.Ulist1 $mlexpr_of_symbol s$ >> -| Ulist1sep (s,sep) -> <:expr< Grammar_API.Extend.Ulist1sep $mlexpr_of_symbol s$ $str:sep$ >> -| Ulist0 s -> <:expr< Grammar_API.Extend.Ulist0 $mlexpr_of_symbol s$ >> -| Ulist0sep (s,sep) -> <:expr< Grammar_API.Extend.Ulist0sep $mlexpr_of_symbol s$ $str:sep$ >> -| Uopt s -> <:expr< Grammar_API.Extend.Uopt $mlexpr_of_symbol s$ >> +| Ulist1 s -> <:expr< Extend.Ulist1 $mlexpr_of_symbol s$ >> +| Ulist1sep (s,sep) -> <:expr< Extend.Ulist1sep $mlexpr_of_symbol s$ $str:sep$ >> +| Ulist0 s -> <:expr< Extend.Ulist0 $mlexpr_of_symbol s$ >> +| Ulist0sep (s,sep) -> <:expr< Extend.Ulist0sep $mlexpr_of_symbol s$ $str:sep$ >> +| Uopt s -> <:expr< Extend.Uopt $mlexpr_of_symbol s$ >> | Uentry e -> let arg = get_argt <:expr< $lid:"wit_"^e$ >> in - <:expr< Grammar_API.Extend.Uentry (Genarg.ArgT.Any $arg$) >> + <:expr< Extend.Uentry (Genarg.ArgT.Any $arg$) >> | Uentryl (e, l) -> assert (e = "tactic"); let arg = get_argt <:expr< Tacarg.wit_tactic >> in - <:expr< Grammar_API.Extend.Uentryl (Genarg.ArgT.Any $arg$) $mlexpr_of_int l$>> + <:expr< Extend.Uentryl (Genarg.ArgT.Any $arg$) $mlexpr_of_int l$>> let make_prod_item = function | ExtTerminal s -> <:expr< Tacentries.TacTerm $str:s$ >> @@ -113,12 +113,12 @@ let declare_tactic loc tacname ~level classification clause = match clause with the ML tactic retrieves its arguments in the [ist] environment instead. This is the rรดle of the [lift_constr_tac_to_ml_tac] function. *) let body = <:expr< Tacexpr.TacFun ($vars$, Tacexpr.TacML (Loc.tag ( $ml$ , []))) >> in - let name = <:expr< API.Names.Id.of_string $name$ >> in + let name = <:expr< Names.Id.of_string $name$ >> in declare_str_items loc [ <:str_item< do { let obj () = Tacenv.register_ltac True False $name$ $body$ in let () = Tacenv.register_ml_tactic $se$ [|$tac$|] in - API.Mltop.declare_cache_obj obj $plugin_name$ } >> + Mltop.declare_cache_obj obj $plugin_name$ } >> ] | _ -> (** Otherwise we add parsing and printing rules to generate a call to a @@ -131,7 +131,7 @@ let declare_tactic loc tacname ~level classification clause = match clause with declare_str_items loc [ <:str_item< do { Tacenv.register_ml_tactic $se$ (Array.of_list $make_fun_clauses loc tacname clause$); - Grammar_API.Mltop.declare_cache_obj $obj$ $plugin_name$; } >> + Mltop.declare_cache_obj $obj$ $plugin_name$; } >> ] open Pcaml diff --git a/grammar/vernacextend.mlp b/grammar/vernacextend.mlp index af4d0dfe81..a529185dd6 100644 --- a/grammar/vernacextend.mlp +++ b/grammar/vernacextend.mlp @@ -100,12 +100,12 @@ let make_fun_classifiers loc s c l = mlexpr_of_list (fun x -> x) cl let make_prod_item = function - | ExtTerminal s -> <:expr< Grammar_API.Egramml.GramTerminal $str:s$ >> + | ExtTerminal s -> <:expr< Egramml.GramTerminal $str:s$ >> | ExtNonTerminal (g, ido) -> let nt = type_of_user_symbol g in - let base s = <:expr< Grammar_API.Pcoq.genarg_grammar ($mk_extraarg loc s$) >> in + let base s = <:expr< Pcoq.genarg_grammar ($mk_extraarg loc s$) >> in let typ = match ido with None -> None | Some _ -> Some nt in - <:expr< Grammar_API.Egramml.GramNonTerminal ( Loc.tag ( $mlexpr_of_option (make_rawwit loc) typ$ , + <:expr< Egramml.GramNonTerminal ( Loc.tag ( $mlexpr_of_option (make_rawwit loc) typ$ , $mlexpr_of_prod_entry_key base g$ ) ) >> let mlexpr_of_clause cl = @@ -122,9 +122,9 @@ let declare_command loc s c nt cl = let classl = make_fun_classifiers loc s c cl in declare_str_items loc [ <:str_item< do { - CList.iteri (fun i (depr, f) -> Grammar_API.Vernacinterp.vinterp_add depr ($se$, i) f) $funcl$; - CList.iteri (fun i f -> API.Vernac_classifier.declare_vernac_classifier ($se$, i) f) $classl$; - CList.iteri (fun i r -> Grammar_API.Egramml.extend_vernac_command_grammar ($se$, i) $nt$ r) $gl$; + CList.iteri (fun i (depr, f) -> Vernacinterp.vinterp_add depr ($se$, i) f) $funcl$; + CList.iteri (fun i f -> Vernac_classifier.declare_vernac_classifier ($se$, i) f) $classl$; + CList.iteri (fun i r -> Egramml.extend_vernac_command_grammar ($se$, i) $nt$ r) $gl$; } >> ] open Pcaml @@ -143,16 +143,16 @@ EXTEND | "DECLARE"; "PLUGIN"; name = STRING -> declare_str_items loc [ <:str_item< value __coq_plugin_name = $str:name$ >>; - <:str_item< value _ = Grammar_API.Mltop.add_known_module __coq_plugin_name >>; + <:str_item< value _ = Mltop.add_known_module __coq_plugin_name >>; ] ] ] ; classification: [ [ "CLASSIFIED"; "BY"; c = LIDENT -> <:expr< $lid:c$ >> | "CLASSIFIED"; "AS"; "SIDEFF" -> - <:expr< fun _ -> API.Vernac_classifier.classify_as_sideeff >> + <:expr< fun _ -> Vernac_classifier.classify_as_sideeff >> | "CLASSIFIED"; "AS"; "QUERY" -> - <:expr< fun _ -> API.Vernac_classifier.classify_as_query >> + <:expr< fun _ -> Vernac_classifier.classify_as_query >> ] ] ; deprecation: diff --git a/ide/coq.ml b/ide/coq.ml index 8ecdf9caa3..0fe831ab36 100644 --- a/ide/coq.ml +++ b/ide/coq.ml @@ -366,7 +366,14 @@ let bind_self_as f = (** This launches a fresh handle from its command line arguments. *) let spawn_handle args respawner feedback_processor = let prog = coqtop_path () in - let args = Array.of_list ("--xml_format=Ppcmds" :: "-async-proofs" :: "on" :: "-ideslave" :: args) in + let async_default = + (* disable async processing by default in Windows *) + if List.mem Sys.os_type ["Win32"; "Cygwin"] then + "off" + else + "on" + in + let args = Array.of_list ("--xml_format=Ppcmds" :: "-async-proofs" :: async_default :: "-ideslave" :: args) in let env = match !Flags.ideslave_coqtop_flags with | None -> None diff --git a/ide/coqOps.ml b/ide/coqOps.ml index 3eb5b0753d..364fc883ba 100644 --- a/ide/coqOps.ml +++ b/ide/coqOps.ml @@ -58,7 +58,7 @@ module SentenceId : sig val connect : sentence -> signals val dbg_to_string : - GText.buffer -> bool -> Stateid.t option -> sentence -> Pp.std_ppcmds + GText.buffer -> bool -> Stateid.t option -> sentence -> Pp.t end = struct @@ -163,7 +163,7 @@ let flags_to_color f = else `NAME Preferences.processed_color#get (* Move to utils? *) -let rec validate (s : Pp.std_ppcmds) = match Pp.repr s with +let rec validate (s : Pp.t) = match Pp.repr s with | Pp.Ppcmd_empty | Pp.Ppcmd_print_break _ | Pp.Ppcmd_force_newline -> true diff --git a/ide/document.mli b/ide/document.mli index fb96cb6d76..ab8e71808c 100644 --- a/ide/document.mli +++ b/ide/document.mli @@ -102,7 +102,7 @@ val context : 'a document -> (id * 'a) list * (id * 'a) list (** debug print *) val print : - 'a document -> (bool -> id option -> 'a -> Pp.std_ppcmds) -> Pp.std_ppcmds + 'a document -> (bool -> id option -> 'a -> Pp.t) -> Pp.t (** Callbacks on documents *) diff --git a/ide/ideutils.ml b/ide/ideutils.ml index 2573b6d6ff..83e5da9509 100644 --- a/ide/ideutils.ml +++ b/ide/ideutils.ml @@ -316,7 +316,7 @@ let textview_width (view : #GText.view_skel) = let char_width = GPango.to_pixels metrics#approx_char_width in pixel_width / char_width -type logger = Feedback.level -> Pp.std_ppcmds -> unit +type logger = Feedback.level -> Pp.t -> unit let default_logger level message = let level = match level with diff --git a/ide/ideutils.mli b/ide/ideutils.mli index 458b8e0a59..f06a48aebe 100644 --- a/ide/ideutils.mli +++ b/ide/ideutils.mli @@ -67,7 +67,7 @@ val requote : string -> string val textview_width : #GText.view_skel -> int (** Returns an approximate value of the character width of a textview *) -type logger = Feedback.level -> Pp.std_ppcmds -> unit +type logger = Feedback.level -> Pp.t -> unit val default_logger : logger (** Default logger. It logs messages that the casual user should not see. *) diff --git a/ide/interface.mli b/ide/interface.mli index aab1d82728..1939a8427c 100644 --- a/ide/interface.mli +++ b/ide/interface.mli @@ -17,9 +17,9 @@ type verbose = bool type goal = { goal_id : string; (** Unique goal identifier *) - goal_hyp : Pp.std_ppcmds list; + goal_hyp : Pp.t list; (** List of hypotheses *) - goal_ccl : Pp.std_ppcmds; + goal_ccl : Pp.t; (** Goal conclusion *) } @@ -121,7 +121,7 @@ type edit_id = int should probably retract to that point *) type 'a value = | Good of 'a - | Fail of (state_id * location * Pp.std_ppcmds) + | Fail of (state_id * location * Pp.t) type ('a, 'b) union = ('a, 'b) Util.union @@ -213,7 +213,7 @@ type about_sty = unit type about_rty = coq_info type handle_exn_sty = Exninfo.iexn -type handle_exn_rty = state_id * location * Pp.std_ppcmds +type handle_exn_rty = state_id * location * Pp.t (* Retrocompatibility stuff *) type interp_sty = (raw * verbose) * string diff --git a/ide/minilib.mli b/ide/minilib.mli index 4517a23744..c96e59b226 100644 --- a/ide/minilib.mli +++ b/ide/minilib.mli @@ -22,7 +22,7 @@ type level = [ (** debug printing *) val debug : bool ref -val log_pp : ?level:level -> Pp.std_ppcmds -> unit +val log_pp : ?level:level -> Pp.t -> unit val log : ?level:level -> string -> unit val coqide_config_home : unit -> string diff --git a/ide/richpp.mli b/ide/richpp.mli index f2ba15d222..84adc61ca2 100644 --- a/ide/richpp.mli +++ b/ide/richpp.mli @@ -24,7 +24,7 @@ type 'annotation located = { that represents (located) annotations of this string. The [get_annotations] function is used to convert tags into the desired annotation. [width] sets the printing witdh of the formatter. *) -val rich_pp : int -> Pp.std_ppcmds -> Pp.pp_tag located Xml_datatype.gxml +val rich_pp : int -> Pp.t -> Pp.pp_tag located Xml_datatype.gxml (** [annotations_positions ssdoc] returns a list associating each annotations with its position in the string from which [ssdoc] is @@ -47,5 +47,5 @@ type richpp = Xml_datatype.xml (** Type of text with style annotations *) -val richpp_of_pp : int -> Pp.std_ppcmds -> richpp +val richpp_of_pp : int -> Pp.t -> richpp (** Extract style information from formatted text *) diff --git a/ide/wg_MessageView.ml b/ide/wg_MessageView.ml index d2a09dd945..65df2b8494 100644 --- a/ide/wg_MessageView.ml +++ b/ide/wg_MessageView.ml @@ -28,9 +28,9 @@ class type message_view = inherit GObj.widget method connect : message_view_signals method clear : unit - method add : Pp.std_ppcmds -> unit + method add : Pp.t -> unit method add_string : string -> unit - method set : Pp.std_ppcmds -> unit + method set : Pp.t -> unit method refresh : bool -> unit method push : Ideutils.logger (** same as [add], but with an explicit level instead of [Notice] *) diff --git a/ide/wg_MessageView.mli b/ide/wg_MessageView.mli index 0ce257c3dd..6bd0625f0e 100644 --- a/ide/wg_MessageView.mli +++ b/ide/wg_MessageView.mli @@ -18,9 +18,9 @@ class type message_view = inherit GObj.widget method connect : message_view_signals method clear : unit - method add : Pp.std_ppcmds -> unit + method add : Pp.t -> unit method add_string : string -> unit - method set : Pp.std_ppcmds -> unit + method set : Pp.t -> unit method refresh : bool -> unit method push : Ideutils.logger (** same as [add], but with an explicit level instead of [Notice] *) diff --git a/ide/xmlprotocol.ml b/ide/xmlprotocol.ml index 06c695c772..4b521a9682 100644 --- a/ide/xmlprotocol.ml +++ b/ide/xmlprotocol.ml @@ -117,7 +117,7 @@ let to_box = let open Pp in | x -> raise (Marshal_error("*ppbox",PCData x)) ) -let rec of_pp (pp : Pp.std_ppcmds) = let open Pp in match Pp.repr pp with +let rec of_pp (pp : Pp.t) = let open Pp in match Pp.repr pp with | Ppcmd_empty -> constructor "ppdoc" "empty" [] | Ppcmd_string s -> constructor "ppdoc" "string" [of_string s] | Ppcmd_glue sl -> constructor "ppdoc" "glue" [of_list of_pp sl] @@ -149,7 +149,7 @@ let rec to_pp xpp = let open Pp in let of_richpp x = Element ("richpp", [], [x]) (* Run-time Selectable *) -let of_pp (pp : Pp.std_ppcmds) = +let of_pp (pp : Pp.t) = match !msg_format with | Richpp margin -> of_richpp (Richpp.richpp_of_pp margin pp) | Ppcmds -> of_pp pp diff --git a/interp/constrintern.ml b/interp/constrintern.ml index f360fb192f..c9fc3aa4f3 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -664,11 +664,11 @@ let instantiate_notation_constr loc intern ntnvars subst infos c = | NProd (Name id, NHole _, c') when option_mem_assoc id binderopt -> let a,letins = snd (Option.get binderopt) in let e = make_letins letins (aux subst' infos c') in - let (loc,(na,bk,t)) = a in + let (_loc,(na,bk,t)) = a in CAst.make ?loc @@ GProd (na,bk,t,e) | NLambda (Name id,NHole _,c') when option_mem_assoc id binderopt -> let a,letins = snd (Option.get binderopt) in - let (loc,(na,bk,t)) = a in + let (_loc,(na,bk,t)) = a in CAst.make ?loc @@ GLambda (na,bk,t,make_letins letins (aux subst' infos c')) (* Two special cases to keep binder name synchronous with BinderType *) | NProd (na,NHole(Evar_kinds.BinderType na',naming,arg),c') diff --git a/interp/declare.ml b/interp/declare.ml index 154793a32d..70f422b514 100644 --- a/interp/declare.ml +++ b/interp/declare.ml @@ -63,8 +63,12 @@ let cache_variable ((sp,_),o) = impl, true, poly, ctx | SectionLocalDef (de) -> let univs = Global.push_named_def (id,de) in + let poly = match de.const_entry_universes with + | Monomorphic_const_entry _ -> false + | Polymorphic_const_entry _ -> true + in Explicit, de.const_entry_opaque, - de.const_entry_polymorphic, univs in + poly, univs in Nametab.push (Nametab.Until 1) (restrict_path 0 sp) (VarRef id); add_section_variable id impl poly ctx; Dischargedhypsmap.set_discharged_hyps sp []; @@ -98,14 +102,12 @@ let declare_variable id obj = (** Declaration of constants and parameters *) type constant_obj = { - cst_decl : global_declaration; + cst_decl : global_declaration option; + (** [None] when the declaration is a side-effect and has already been defined + in the global environment. *) cst_hyps : Dischargedhypsmap.discharged_hyps; cst_kind : logical_kind; cst_locl : bool; - mutable cst_exported : Safe_typing.exported_private_constant list; - (* mutable: to avoid change the libobject API, since cache_function - * does not return an updated object *) - mutable cst_was_seff : bool } type constant_declaration = Safe_typing.private_constants constant_entry * logical_kind @@ -145,16 +147,15 @@ let cache_constant ((sp,kn), obj) = let id = basename sp in let _,dir,_ = repr_kn kn in let kn' = - if obj.cst_was_seff then begin - obj.cst_was_seff <- false; + match obj.cst_decl with + | None -> if Global.exists_objlabel (Label.of_id (basename sp)) then constant_of_kn kn else CErrors.anomaly Pp.(str"Ex seff not found: " ++ Id.print(basename sp) ++ str".") - end else + | Some decl -> let () = check_exists sp in - let kn', exported = Global.add_constant dir id obj.cst_decl in - obj.cst_exported <- exported; - kn' in + Global.add_constant dir id decl + in assert (eq_constant kn' (constant_of_kn kn)); Nametab.push (Nametab.Until 1) sp (ConstRef (constant_of_kn kn)); let cst = Global.lookup_constant kn' in @@ -175,26 +176,20 @@ let discharge_constant ((sp, kn), obj) = let new_hyps = (discharged_hyps kn hyps) @ obj.cst_hyps in let abstract = (named_of_variable_context hyps, subst, uctx) in let new_decl = GlobalRecipe{ from; info = { Opaqueproof.modlist; abstract}} in - Some { obj with cst_hyps = new_hyps; cst_decl = new_decl; } + Some { obj with cst_hyps = new_hyps; cst_decl = Some new_decl; } (* Hack to reduce the size of .vo: we keep only what load/open needs *) -let dummy_constant_entry = - ConstantEntry - (false, ParameterEntry (None,false,(mkProp,Univ.UContext.empty),None)) - let dummy_constant cst = { - cst_decl = dummy_constant_entry; + cst_decl = None; cst_hyps = []; cst_kind = cst.cst_kind; cst_locl = cst.cst_locl; - cst_exported = []; - cst_was_seff = cst.cst_was_seff; } let classify_constant cst = Substitute (dummy_constant cst) -let (inConstant, outConstant : (constant_obj -> obj) * (obj -> constant_obj)) = - declare_object_full { (default_object "CONSTANT") with +let (inConstant : constant_obj -> obj) = + declare_object { (default_object "CONSTANT") with cache_function = cache_constant; load_function = load_constant; open_function = open_constant; @@ -205,31 +200,14 @@ let (inConstant, outConstant : (constant_obj -> obj) * (obj -> constant_obj)) = let declare_scheme = ref (fun _ _ -> assert false) let set_declare_scheme f = declare_scheme := f +let update_tables c = + declare_constant_implicits c; + Heads.declare_head (EvalConstRef c); + Notation.declare_ref_arguments_scope (ConstRef c) + let declare_constant_common id cst = - let update_tables c = -(* Printf.eprintf "tables: %s\n%!" (Names.Constant.to_string c); *) - declare_constant_implicits c; - Heads.declare_head (EvalConstRef c); - Notation.declare_ref_arguments_scope (ConstRef c) in let o = inConstant cst in let _, kn as oname = add_leaf id o in - List.iter (fun (c,ce,role) -> - (* handling of private_constants just exported *) - let o = inConstant { - cst_decl = ConstantEntry (false, ce); - cst_hyps = [] ; - cst_kind = IsProof Theorem; - cst_locl = false; - cst_exported = []; - cst_was_seff = true; } in - let id = Label.to_id (pi3 (Constant.repr3 c)) in - ignore(add_leaf id o); - update_tables c; - let () = if_xml (Hook.get f_xml_declare_constant) (InternalTacticRequest, c) in - match role with - | Safe_typing.Subproof -> () - | Safe_typing.Schema (ind, kind) -> !declare_scheme kind [|ind,c|]) - (outConstant o).cst_exported; pull_to_head oname; let c = Global.constant_of_delta_kn kn in update_tables c; @@ -237,34 +215,58 @@ let declare_constant_common id cst = let definition_entry ?fix_exn ?(opaque=false) ?(inline=false) ?types ?(poly=false) ?(univs=Univ.UContext.empty) ?(eff=Safe_typing.empty_private_constants) body = + let univs = + if poly then Polymorphic_const_entry univs + else Monomorphic_const_entry univs + in { const_entry_body = Future.from_val ?fix_exn ((body,Univ.ContextSet.empty), eff); const_entry_secctx = None; const_entry_type = types; - const_entry_polymorphic = poly; const_entry_universes = univs; const_entry_opaque = opaque; const_entry_feedback = None; const_entry_inline_code = inline} let declare_constant ?(internal = UserIndividualRequest) ?(local = false) id ?(export_seff=false) (cd, kind) = - let export = (* We deal with side effects *) + let is_poly de = match de.const_entry_universes with + | Monomorphic_const_entry _ -> false + | Polymorphic_const_entry _ -> true + in + let in_section = Lib.sections_are_opened () in + let export, decl = (* We deal with side effects *) match cd with | DefinitionEntry de when export_seff || not de.const_entry_opaque || - de.const_entry_polymorphic -> - let bo = de.const_entry_body in - let _, seff = Future.force bo in - Safe_typing.empty_private_constants <> seff - | _ -> false + is_poly de -> + (** This globally defines the side-effects in the environment. We mark + exported constants as being side-effect not to redeclare them at + caching time. *) + let cd, export = Global.export_private_constants ~in_section cd in + export, ConstantEntry (PureEntry, cd) + | _ -> [], ConstantEntry (EffectEntry, cd) + in + let iter_eff (c, role) = + let o = inConstant { + cst_decl = None; + cst_hyps = [] ; + cst_kind = IsProof Theorem; + cst_locl = false; + } in + let id = Label.to_id (pi3 (Constant.repr3 c)) in + ignore(add_leaf id o); + update_tables c; + let () = if_xml (Hook.get f_xml_declare_constant) (InternalTacticRequest, c) in + match role with + | Safe_typing.Subproof -> () + | Safe_typing.Schema (ind, kind) -> !declare_scheme kind [|ind,c|] in + let () = List.iter iter_eff export in let cst = { - cst_decl = ConstantEntry (export,cd); + cst_decl = Some decl; cst_hyps = [] ; cst_kind = kind; cst_locl = local; - cst_exported = []; - cst_was_seff = false; } in let kn = declare_constant_common id cst in let () = if_xml (Hook.get f_xml_declare_constant) (internal, kn) in diff --git a/interp/impargs.ml b/interp/impargs.ml index b7125fc85d..d8241c0443 100644 --- a/interp/impargs.ml +++ b/interp/impargs.ml @@ -414,7 +414,7 @@ let compute_semi_auto_implicits env f manual t = let compute_constant_implicits flags manual cst = let env = Global.env () in let cb = Environ.lookup_constant cst env in - let ty = Typeops.type_of_constant_type env cb.const_type in + let ty = cb.const_type in let impls = compute_semi_auto_implicits env flags manual ty in impls diff --git a/interp/notation.mli b/interp/notation.mli index dd0144e8d0..e63ad10cde 100644 --- a/interp/notation.mli +++ b/interp/notation.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Pp open Bigint open Names open Libnames @@ -189,13 +188,13 @@ val make_notation_key : symbol list -> notation val decompose_notation_key : notation -> symbol list (** Prints scopes (expects a pure aconstr printer) *) -val pr_scope_class : scope_class -> std_ppcmds -val pr_scope : (glob_constr -> std_ppcmds) -> scope_name -> std_ppcmds -val pr_scopes : (glob_constr -> std_ppcmds) -> std_ppcmds -val locate_notation : (glob_constr -> std_ppcmds) -> notation -> - scope_name option -> std_ppcmds +val pr_scope_class : scope_class -> Pp.t +val pr_scope : (glob_constr -> Pp.t) -> scope_name -> Pp.t +val pr_scopes : (glob_constr -> Pp.t) -> Pp.t +val locate_notation : (glob_constr -> Pp.t) -> notation -> + scope_name option -> Pp.t -val pr_visibility: (glob_constr -> std_ppcmds) -> scope_name option -> std_ppcmds +val pr_visibility: (glob_constr -> Pp.t) -> scope_name option -> Pp.t (** {6 Printing rules for notations} *) diff --git a/interp/ppextend.mli b/interp/ppextend.mli index 4874989cd9..a347a5c7b7 100644 --- a/interp/ppextend.mli +++ b/interp/ppextend.mli @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Pp - (** {6 Pretty-print. } *) (** Dealing with precedences *) @@ -28,9 +26,9 @@ type ppcut = | PpBrk of int * int | PpFnl -val ppcmd_of_box : ppbox -> std_ppcmds -> std_ppcmds +val ppcmd_of_box : ppbox -> Pp.t -> Pp.t -val ppcmd_of_cut : ppcut -> std_ppcmds +val ppcmd_of_cut : ppcut -> Pp.t type unparsing = | UnpMetaVar of int * parenRelation diff --git a/intf/notation_term.ml b/intf/notation_term.ml index 0fa0afdad7..cee96040bd 100644 --- a/intf/notation_term.ml +++ b/intf/notation_term.ml @@ -83,9 +83,10 @@ type notation_interp_env = { type grammar_constr_prod_item = | GramConstrTerminal of Tok.t | GramConstrNonTerminal of Extend.constr_prod_entry_key * Id.t option - | GramConstrListMark of int * bool + | GramConstrListMark of int * bool * int (* tells action rule to make a list of the n previous parsed items; - concat with last parsed list if true *) + concat with last parsed list when true; additionally release + the p last items as if they were parsed autonomously *) type notation_grammar = { notgram_level : int; diff --git a/kernel/cbytecodes.mli b/kernel/cbytecodes.mli index 8f38e9d34e..718917ab35 100644 --- a/kernel/cbytecodes.mli +++ b/kernel/cbytecodes.mli @@ -34,7 +34,7 @@ type structured_constant = | Const_univ_level of Univ.universe_level | Const_type of Univ.universe -val pp_struct_const : structured_constant -> Pp.std_ppcmds +val pp_struct_const : structured_constant -> Pp.t type reloc_table = (tag * int) array @@ -163,8 +163,8 @@ type comp_env = { in_env : vm_env ref (** the variables that are accessed *) } -val pp_bytecodes : bytecodes -> Pp.std_ppcmds -val pp_fv_elem : fv_elem -> Pp.std_ppcmds +val pp_bytecodes : bytecodes -> Pp.t +val pp_fv_elem : fv_elem -> Pp.t (*spiwack: moved this here because I needed it for retroknowledge *) type block = diff --git a/kernel/cooking.ml b/kernel/cooking.ml index 95822fac68..80d41847cd 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -18,7 +18,6 @@ open Util open Names open Term open Declarations -open Environ open Univ module NamedDecl = Context.Named.Declaration @@ -151,9 +150,14 @@ let abstract_constant_body = type recipe = { from : constant_body; info : Opaqueproof.cooking_info } type inline = bool -type result = - constant_def * constant_type * projection_body option * - constant_universes * inline * Context.Named.t option +type result = { + cook_body : constant_def; + cook_type : types; + cook_proj : projection_body option; + cook_universes : constant_universes; + cook_inline : inline; + cook_context : Context.Named.t option; +} let on_body ml hy f = function | Undef _ as x -> x @@ -162,11 +166,6 @@ let on_body ml hy f = function OpaqueDef (Opaqueproof.discharge_direct_opaque ~cook_constr:f { Opaqueproof.modlist = ml; abstract = hy } o) -let constr_of_def otab = function - | Undef _ -> assert false - | Def cs -> Mod_subst.force_constr cs - | OpaqueDef lc -> Opaqueproof.force_proof otab lc - let expmod_constr_subst cache modlist subst c = let c = expmod_constr cache modlist c in Vars.subst_univs_level_constr subst c @@ -215,17 +214,7 @@ let cook_constant ~hcons env { from = cb; info } = List.filter (fun decl' -> not (Id.equal (NamedDecl.get_id decl) (NamedDecl.get_id decl'))) hyps) hyps ~init:cb.const_hyps in - let typ = match cb.const_type with - | RegularArity t -> - let typ = - abstract_constant_type (expmod t) hyps in - RegularArity typ - | TemplateArity (ctx,s) -> - let t = mkArity (ctx,Type s.template_level) in - let typ = abstract_constant_type (expmod t) hyps in - let j = make_judge (constr_of_def (opaque_tables env) body) typ in - Typeops.make_polymorphic_if_constant_for_ind env j - in + let typ = abstract_constant_type (expmod cb.const_type) hyps in let projection pb = let c' = abstract_constant_body (expmod pb.proj_body) hyps in let etab = abstract_constant_body (expmod (fst pb.proj_eta)) hyps in @@ -239,9 +228,6 @@ let cook_constant ~hcons env { from = cb; info } = | _ -> assert false with Not_found -> (((pb.proj_ind,0),Univ.Instance.empty), 0) in - let typ = (* By invariant, a regular arity *) - match typ with RegularArity t -> t | TemplateArity _ -> assert false - in let ctx, ty' = decompose_prod_n (n' + pb.proj_npars + 1) typ in { proj_ind = mind; proj_npars = pb.proj_npars + n'; proj_arg = pb.proj_arg; proj_eta = etab, etat; @@ -254,9 +240,14 @@ let cook_constant ~hcons env { from = cb; info } = | Polymorphic_const auctx -> Polymorphic_const (AUContext.union abs_ctx auctx) in - (body, typ, Option.map projection cb.const_proj, - univs, cb.const_inline_code, - Some const_hyps) + { + cook_body = body; + cook_type = typ; + cook_proj = Option.map projection cb.const_proj; + cook_universes = univs; + cook_inline = cb.const_inline_code; + cook_context = Some const_hyps; + } (* let cook_constant_key = Profile.declare_profile "cook_constant" *) (* let cook_constant = Profile.profile2 cook_constant_key cook_constant *) diff --git a/kernel/cooking.mli b/kernel/cooking.mli index 79a028d760..6d1b776c05 100644 --- a/kernel/cooking.mli +++ b/kernel/cooking.mli @@ -16,9 +16,14 @@ type recipe = { from : constant_body; info : Opaqueproof.cooking_info } type inline = bool -type result = - constant_def * constant_type * projection_body option * - constant_universes * inline * Context.Named.t option +type result = { + cook_body : constant_def; + cook_type : types; + cook_proj : projection_body option; + cook_universes : constant_universes; + cook_inline : inline; + cook_context : Context.Named.t option; +} val cook_constant : hcons:bool -> env -> recipe -> result val cook_constr : Opaqueproof.cooking_info -> Term.constr -> Term.constr diff --git a/kernel/declarations.ml b/kernel/declarations.ml index f35438dfc4..9697b0b8b2 100644 --- a/kernel/declarations.ml +++ b/kernel/declarations.ml @@ -36,8 +36,6 @@ type ('a, 'b) declaration_arity = | RegularArity of 'a | TemplateArity of 'b -type constant_type = (types, Context.Rel.t * template_arity) declaration_arity - (** Inlining level of parameters at functor applications. None means no inlining *) @@ -83,7 +81,7 @@ type typing_flags = { type constant_body = { const_hyps : Context.Named.t; (** New: younger hyp at top *) const_body : constant_def; - const_type : constant_type; + const_type : types; const_body_code : Cemitcodes.to_patch_substituted option; const_universes : constant_universes; const_proj : projection_body option; diff --git a/kernel/declareops.ml b/kernel/declareops.ml index efce219826..85dd1e66db 100644 --- a/kernel/declareops.ml +++ b/kernel/declareops.ml @@ -69,10 +69,6 @@ let subst_rel_declaration sub = let subst_rel_context sub = List.smartmap (subst_rel_declaration sub) -let subst_template_cst_arity sub (ctx,s as arity) = - let ctx' = subst_rel_context sub ctx in - if ctx==ctx' then arity else (ctx',s) - let subst_const_type sub arity = if is_empty_subst sub then arity else subst_mps sub arity @@ -94,7 +90,7 @@ let subst_const_body sub cb = if is_empty_subst sub then cb else let body' = subst_const_def sub cb.const_body in - let type' = subst_decl_arity subst_const_type subst_template_cst_arity sub cb.const_type in + let type' = subst_const_type sub cb.const_type in let proj' = Option.smartmap (subst_const_proj sub) cb.const_proj in if body' == cb.const_body && type' == cb.const_type && proj' == cb.const_proj then cb @@ -120,14 +116,6 @@ let hcons_rel_decl = let hcons_rel_context l = List.smartmap hcons_rel_decl l -let hcons_regular_const_arity t = Term.hcons_constr t - -let hcons_template_const_arity (ctx, ar) = - (hcons_rel_context ctx, hcons_template_arity ar) - -let hcons_const_type = - map_decl_arity hcons_regular_const_arity hcons_template_const_arity - let hcons_const_def = function | Undef inl -> Undef inl | Def l_constr -> @@ -145,7 +133,7 @@ let hcons_const_universes cbu = let hcons_const_body cb = { cb with const_body = hcons_const_def cb.const_body; - const_type = hcons_const_type cb.const_type; + const_type = Term.hcons_constr cb.const_type; const_universes = hcons_const_universes cb.const_universes } (** {6 Inductive types } *) diff --git a/kernel/entries.mli b/kernel/entries.ml index 3fa25c142a..a1ccbdbc1b 100644 --- a/kernel/entries.mli +++ b/kernel/entries.ml @@ -64,6 +64,10 @@ type mutual_inductive_entry = { type 'a proof_output = constr 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 + type 'a definition_entry = { const_entry_body : 'a const_entry_body; (* List of section variables *) @@ -71,8 +75,7 @@ type 'a definition_entry = { (* State id on which the completion of type checking is reported *) const_entry_feedback : Stateid.t option; const_entry_type : types option; - const_entry_polymorphic : bool; - const_entry_universes : Univ.universe_context; + const_entry_universes : constant_universes_entry; const_entry_opaque : bool; const_entry_inline_code : bool } diff --git a/kernel/environ.ml b/kernel/environ.ml index b01b652001..d2c737ab0c 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -232,12 +232,6 @@ let constraints_of cb u = | Monomorphic_const _ -> Univ.Constraint.empty | Polymorphic_const ctx -> Univ.AUContext.instantiate u ctx -let map_regular_arity f = function - | RegularArity a as ar -> - let a' = f a in - if a' == a then ar else RegularArity a' - | TemplateArity _ -> assert false - (* constant_type gives the type of a constant *) let constant_type env (kn,u) = let cb = lookup_constant kn env in @@ -245,7 +239,7 @@ let constant_type env (kn,u) = | Monomorphic_const _ -> cb.const_type, Univ.Constraint.empty | Polymorphic_const ctx -> let csts = constraints_of cb u in - (map_regular_arity (subst_instance_constr u) cb.const_type, csts) + (subst_instance_constr u cb.const_type, csts) let constant_context env kn = let cb = lookup_constant kn env in @@ -287,7 +281,7 @@ let constant_value_and_type env (kn, u) = | OpaqueDef _ -> None | Undef _ -> None in - b', map_regular_arity (subst_instance_constr u) cb.const_type, cst + b', subst_instance_constr u cb.const_type, cst else let b' = match cb.const_body with | Def l_body -> Some (Mod_subst.force_constr l_body) @@ -303,7 +297,7 @@ let constant_value_and_type env (kn, u) = let constant_type_in env (kn,u) = let cb = lookup_constant kn env in if Declareops.constant_is_polymorphic cb then - map_regular_arity (subst_instance_constr u) cb.const_type + subst_instance_constr u cb.const_type else cb.const_type let constant_value_in env (kn,u) = @@ -337,15 +331,6 @@ let polymorphic_pconstant (cst,u) env = let type_in_type_constant cst env = not (lookup_constant cst env).const_typing_flags.check_universes -let template_polymorphic_constant cst env = - match (lookup_constant cst env).const_type with - | TemplateArity _ -> true - | RegularArity _ -> false - -let template_polymorphic_pconstant (cst,u) env = - if not (Univ.Instance.is_empty u) then false - else template_polymorphic_constant cst env - let lookup_projection cst env = match (lookup_constant (Projection.constant cst) env).const_proj with | Some pb -> pb diff --git a/kernel/environ.mli b/kernel/environ.mli index cd7a9d2791..377c61de2c 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -139,10 +139,6 @@ val polymorphic_constant : constant -> env -> bool val polymorphic_pconstant : pconstant -> env -> bool val type_in_type_constant : constant -> env -> bool -(** Old-style polymorphism *) -val template_polymorphic_constant : constant -> env -> bool -val template_polymorphic_pconstant : pconstant -> env -> bool - (** {6 ... } *) (** [constant_value env c] raises [NotEvaluableConst Opaque] if [c] is opaque and [NotEvaluableConst NoBody] if it has no @@ -153,11 +149,11 @@ type const_evaluation_result = NoBody | Opaque | IsProj exception NotEvaluableConst of const_evaluation_result val constant_value : env -> constant puniverses -> constr constrained -val constant_type : env -> constant puniverses -> constant_type constrained +val constant_type : env -> constant puniverses -> types constrained val constant_opt_value : env -> constant puniverses -> (constr * Univ.constraints) option val constant_value_and_type : env -> constant puniverses -> - constr option * constant_type * Univ.constraints + constr option * types * Univ.constraints (** The universe context associated to the constant, empty if not polymorphic *) val constant_context : env -> constant -> Univ.abstract_universe_context @@ -166,7 +162,7 @@ val constant_context : env -> constant -> Univ.abstract_universe_context already contains the constraints corresponding to the constant application. *) val constant_value_in : env -> constant puniverses -> constr -val constant_type_in : env -> constant puniverses -> constant_type +val constant_type_in : env -> constant puniverses -> types val constant_opt_value_in : env -> constant puniverses -> constr option (** {6 Primitive projections} *) diff --git a/kernel/kernel.mllib b/kernel/kernel.mllib index 0813315b5b..9946348541 100644 --- a/kernel/kernel.mllib +++ b/kernel/kernel.mllib @@ -13,9 +13,11 @@ Mod_subst Cbytecodes Copcodes Cemitcodes +Opaqueproof +Declarations +Entries Nativevalues Primitives -Opaqueproof Declareops Retroknowledge Conv_oracle @@ -41,5 +43,4 @@ Nativelibrary Safe_typing Vm Csymtable -Declarations Vconv diff --git a/kernel/mod_subst.mli b/kernel/mod_subst.mli index 3cd02fb9f8..f1d0e42796 100644 --- a/kernel/mod_subst.mli +++ b/kernel/mod_subst.mli @@ -107,9 +107,9 @@ val subst_substituted : substitution -> 'a substituted -> 'a substituted (**/**) (* debugging *) val debug_string_of_subst : substitution -> string -val debug_pr_subst : substitution -> Pp.std_ppcmds +val debug_pr_subst : substitution -> Pp.t val debug_string_of_delta : delta_resolver -> string -val debug_pr_delta : delta_resolver -> Pp.std_ppcmds +val debug_pr_delta : delta_resolver -> Pp.t (**/**) (** [subst_mp sub mp] guarantees that whenever the result of the diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml index c7f3e5c51b..0888ccc109 100644 --- a/kernel/mod_typing.ml +++ b/kernel/mod_typing.ml @@ -83,7 +83,7 @@ let rec check_with_def env struc (idl,(c,ctx)) mp equiv = let c',cst = match cb.const_body with | Undef _ | OpaqueDef _ -> let j = Typeops.infer env' c in - let typ = Typeops.type_of_constant_type env' cb.const_type in + let typ = cb.const_type in let cst' = Reduction.infer_conv_leq env' (Environ.universes env') j.uj_type typ in j.uj_val, cst' @@ -103,7 +103,7 @@ let rec check_with_def env struc (idl,(c,ctx)) mp equiv = let cst = match cb.const_body with | Undef _ | OpaqueDef _ -> let j = Typeops.infer env' c in - let typ = Typeops.type_of_constant_type env' cb.const_type in + let typ = cb.const_type in let cst' = Reduction.infer_conv_leq env' (Environ.universes env') j.uj_type typ in cst' diff --git a/kernel/names.mli b/kernel/names.mli index 74d63c0cea..d111dd3c06 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -57,7 +57,7 @@ sig val to_string : t -> string (** Converts a identifier into an string. *) - val print : t -> Pp.std_ppcmds + val print : t -> Pp.t (** Pretty-printer. *) module Set : Set.S with type elt = t @@ -105,7 +105,7 @@ sig val hcons : t -> t (** Hashconsing over names. *) - val print : t -> Pp.std_ppcmds + val print : t -> Pp.t (** Pretty-printer (print "_" for [Anonymous]. *) end @@ -187,7 +187,7 @@ sig val to_id : t -> Id.t (** Conversion to an identifier. *) - val print : t -> Pp.std_ppcmds + val print : t -> Pp.t (** Pretty-printer. *) module Set : Set.S with type elt = t @@ -286,7 +286,7 @@ sig val debug_to_string : t -> string (** Same as [to_string], but outputs information related to debug. *) - val print : t -> Pp.std_ppcmds + val print : t -> Pp.t (** Comparisons *) val compare : t -> t -> int @@ -365,9 +365,9 @@ sig (** Displaying *) val to_string : t -> string - val print : t -> Pp.std_ppcmds + val print : t -> Pp.t val debug_to_string : t -> string - val debug_print : t -> Pp.std_ppcmds + val debug_print : t -> Pp.t end @@ -447,9 +447,9 @@ sig (** Displaying *) val to_string : t -> string - val print : t -> Pp.std_ppcmds + val print : t -> Pp.t val debug_to_string : t -> string - val debug_print : t -> Pp.std_ppcmds + val debug_print : t -> Pp.t end @@ -609,7 +609,7 @@ val mk_label : string -> label val string_of_label : label -> string (** @deprecated Same as [Label.to_string]. *) -val pr_label : label -> Pp.std_ppcmds +val pr_label : label -> Pp.t (** @deprecated Same as [Label.print]. *) val label_of_id : Id.t -> label @@ -695,7 +695,7 @@ val label : kernel_name -> Label.t val string_of_kn : kernel_name -> string (** @deprecated Same as [KerName.to_string]. *) -val pr_kn : kernel_name -> Pp.std_ppcmds +val pr_kn : kernel_name -> Pp.t (** @deprecated Same as [KerName.print]. *) val kn_ord : kernel_name -> kernel_name -> int @@ -731,7 +731,7 @@ module Projection : sig val map : (constant -> constant) -> t -> t val to_string : t -> string - val print : t -> Pp.std_ppcmds + val print : t -> Pp.t end @@ -776,10 +776,10 @@ val con_with_label : constant -> Label.t -> constant val string_of_con : constant -> string (** @deprecated Same as [Constant.to_string] *) -val pr_con : constant -> Pp.std_ppcmds +val pr_con : constant -> Pp.t (** @deprecated Same as [Constant.print] *) -val debug_pr_con : constant -> Pp.std_ppcmds +val debug_pr_con : constant -> Pp.t (** @deprecated Same as [Constant.debug_print] *) val debug_string_of_con : constant -> string @@ -826,10 +826,10 @@ val mind_modpath : mutual_inductive -> ModPath.t val string_of_mind : mutual_inductive -> string (** @deprecated Same as [MutInd.to_string] *) -val pr_mind : mutual_inductive -> Pp.std_ppcmds +val pr_mind : mutual_inductive -> Pp.t (** @deprecated Same as [MutInd.print] *) -val debug_pr_mind : mutual_inductive -> Pp.std_ppcmds +val debug_pr_mind : mutual_inductive -> Pp.t (** @deprecated Same as [MutInd.debug_print] *) val debug_string_of_mind : mutual_inductive -> string diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index ed4c7d57ad..04051f2e23 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -382,12 +382,13 @@ let safe_push_named d env = let push_named_def (id,de) senv = - let c,typ,univs = - match Term_typing.translate_local_def senv.revstruct senv.env id de with - | c, typ, Monomorphic_const ctx -> c, typ, ctx - | _, _, Polymorphic_const _ -> assert false + let open Entries in + let trust = Term_typing.SideEffects senv.revstruct in + let c,typ,univs = Term_typing.translate_local_def trust senv.env id de in + let poly = match de.Entries.const_entry_universes with + | Monomorphic_const_entry _ -> false + | Polymorphic_const_entry _ -> true in - let poly = de.Entries.const_entry_polymorphic in let univs = Univ.ContextSet.of_context univs in let c, univs = match c with | Def c -> Mod_subst.force_constr c, univs @@ -492,12 +493,16 @@ let add_field ((l,sfb) as field) gn senv = let update_resolver f senv = { senv with modresolver = f senv.modresolver } (** Insertion of constants and parameters in environment *) +type 'a effect_entry = +| EffectEntry : private_constants effect_entry +| PureEntry : unit effect_entry + type global_declaration = - | ConstantEntry of bool * private_constants Entries.constant_entry + | ConstantEntry : 'a effect_entry * 'a Entries.constant_entry -> global_declaration | GlobalRecipe of Cooking.recipe type exported_private_constant = - constant * private_constants Entries.constant_entry * private_constant_role + constant * private_constant_role let add_constant_aux no_section senv (kn, cb) = let l = pi3 (Constant.repr3 kn) in @@ -521,30 +526,29 @@ let add_constant_aux no_section senv (kn, cb) = in senv'' +let export_private_constants ~in_section ce senv = + let exported, ce = Term_typing.export_side_effects senv.revstruct senv.env ce in + let bodies = List.map (fun (kn, cb, _) -> (kn, cb)) exported in + let exported = List.map (fun (kn, _, r) -> (kn, r)) exported in + let no_section = not in_section in + let senv = List.fold_left (add_constant_aux no_section) senv bodies in + (ce, exported), senv + let add_constant dir l decl senv = let kn = make_con senv.modpath dir l in let no_section = DirPath.is_empty dir in - let seff_to_export, decl = - match decl with - | ConstantEntry (true, ce) -> - let exports, ce = - Term_typing.export_side_effects senv.revstruct senv.env ce in - exports, ConstantEntry (false, ce) - | _ -> [], decl - in - let senv = - List.fold_left (add_constant_aux no_section) senv - (List.map (fun (kn,cb,_,_) -> kn, cb) seff_to_export) in let senv = let cb = match decl with - | ConstantEntry (export_seff,ce) -> - Term_typing.translate_constant senv.revstruct senv.env kn ce + | ConstantEntry (EffectEntry, ce) -> + Term_typing.translate_constant (Term_typing.SideEffects senv.revstruct) senv.env kn ce + | ConstantEntry (PureEntry, ce) -> + Term_typing.translate_constant Term_typing.Pure senv.env kn ce | GlobalRecipe r -> let cb = Term_typing.translate_recipe senv.env kn r in if no_section then Declareops.hcons_const_body cb else cb in add_constant_aux no_section senv (kn, cb) in - (kn, List.map (fun (kn,_,ce,r) -> kn, ce, r) seff_to_export), senv + kn, senv (** Insertion of inductive types *) diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index 5bb8ceb1a5..752fdd793e 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -67,7 +67,7 @@ val mk_pure_proof : Constr.constr -> private_constants Entries.proof_output val inline_private_constants_in_constr : Environ.env -> Constr.constr -> private_constants -> Constr.constr val inline_private_constants_in_definition_entry : - Environ.env -> private_constants Entries.definition_entry -> private_constants Entries.definition_entry + Environ.env -> private_constants Entries.definition_entry -> unit Entries.definition_entry val universes_of_private : private_constants -> Univ.universe_context_set list @@ -94,19 +94,26 @@ val push_named_def : (** Insertion of global axioms or definitions *) +type 'a effect_entry = +| EffectEntry : private_constants effect_entry +| PureEntry : unit effect_entry + type global_declaration = - (* bool: export private constants *) - | ConstantEntry of bool * private_constants Entries.constant_entry + | ConstantEntry : 'a effect_entry * 'a Entries.constant_entry -> global_declaration | GlobalRecipe of Cooking.recipe type exported_private_constant = - constant * private_constants Entries.constant_entry * private_constant_role + constant * private_constant_role + +val export_private_constants : in_section:bool -> + private_constants Entries.constant_entry -> + (unit Entries.constant_entry * exported_private_constant list) safe_transformer (** returns the main constant plus a list of auxiliary constants (empty unless one requires the side effects to be exported) *) val add_constant : DirPath.t -> Label.t -> global_declaration -> - (constant * exported_private_constant list) safe_transformer + constant safe_transformer (** Adding an inductive type *) diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml index bd82dd465b..b311165f10 100644 --- a/kernel/subtyping.ml +++ b/kernel/subtyping.ml @@ -313,8 +313,8 @@ let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 = error (PolymorphicStatusExpected false) in (* Now check types *) - let typ1 = Typeops.type_of_constant_type env cb1.const_type in - let typ2 = Typeops.type_of_constant_type env cb2.const_type in + let typ1 = cb1.const_type in + let typ2 = cb2.const_type in let cst = check_type poly cst env typ1 typ2 in (* Now we check the bodies: - A transparent constant can only be implemented by a compatible diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index cf82d54ec1..3f42c348fc 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -21,7 +21,6 @@ open Environ open Entries open Typeops -module RelDecl = Context.Rel.Declaration module NamedDecl = Context.Named.Declaration (* Insertion of constants and parameters in environment. *) @@ -77,6 +76,10 @@ end type side_effects = SideEffects.t +type _ trust = +| Pure : unit trust +| SideEffects : structure_body -> side_effects trust + let uniq_seff_rev = SideEffects.repr let uniq_seff l = List.rev (SideEffects.repr l) @@ -124,7 +127,7 @@ let inline_side_effects env body ctx side_eff = match cb.const_universes with | Monomorphic_const cnstctx -> (** Abstract over the term at the top of the proof *) - let ty = Typeops.type_of_constant_type env cb.const_type in + let ty = cb.const_type in let subst = Cmap_env.add c (Inr var) subst in let univs = Univ.ContextSet.of_context cnstctx in let ctx = Univ.ContextSet.union ctx univs in @@ -232,7 +235,7 @@ let abstract_constant_universes abstract uctx = let sbst, auctx = Univ.abstract_universes uctx in sbst, Polymorphic_const auctx -let infer_declaration ~trust env kn dcl = +let infer_declaration (type a) ~(trust : a trust) env kn (dcl : a constant_entry) = match dcl with | ParameterEntry (ctx,poly,(t,uctx),nl) -> let env = push_context ~strict:(not poly) uctx env in @@ -243,7 +246,14 @@ let infer_declaration ~trust env kn dcl = in let c = Typeops.assumption_of_judgment env j in let t = hcons_constr (Vars.subst_univs_level_constr usubst c) in - Undef nl, RegularArity t, None, univs, false, ctx + { + Cooking.cook_body = Undef nl; + cook_type = t; + cook_proj = None; + cook_universes = univs; + cook_inline = false; + cook_context = ctx; + } (** Definition [c] is opaque (Qed), non polymorphic and with a specified type, so we delay the typing and hash consing of its body. @@ -251,52 +261,69 @@ let infer_declaration ~trust env kn dcl = delay even in the polymorphic case. *) | DefinitionEntry ({ const_entry_type = Some typ; const_entry_opaque = true; - const_entry_polymorphic = false} as c) -> - let env = push_context ~strict:true c.const_entry_universes env in + const_entry_universes = Monomorphic_const_entry univs } as c) -> + let env = push_context ~strict:true univs env in let { const_entry_body = body; const_entry_feedback = feedback_id } = c in let tyj = infer_type env typ in let proofterm = Future.chain ~pure:true body (fun ((body,uctx),side_eff) -> - let body, uctx, signatures = - inline_side_effects env body uctx side_eff in - let valid_signatures = check_signatures trust signatures in - let env = push_context_set uctx env in - let j = + let j, uctx = match trust with + | Pure -> + let env = push_context_set uctx env in + let j = infer env body in + let _ = judge_of_cast env j DEFAULTcast tyj in + j, uctx + | SideEffects mb -> + let (body, uctx, signatures) = inline_side_effects env body uctx side_eff in + let valid_signatures = check_signatures mb signatures in + let env = push_context_set uctx env in let body,env,ectx = skip_trusted_seff valid_signatures body env in let j = infer env body in - unzip ectx j in - let _ = judge_of_cast env j DEFAULTcast tyj in + let j = unzip ectx j in + let _ = judge_of_cast env j DEFAULTcast tyj in + j, uctx + in let c = hcons_constr j.uj_val in feedback_completion_typecheck feedback_id; c, uctx) in let def = OpaqueDef (Opaqueproof.create proofterm) in - def, RegularArity typ, None, - (Monomorphic_const c.const_entry_universes), - c.const_entry_inline_code, c.const_entry_secctx + { + Cooking.cook_body = def; + cook_type = typ; + cook_proj = None; + cook_universes = Monomorphic_const univs; + cook_inline = c.const_entry_inline_code; + cook_context = c.const_entry_secctx; + } (** Other definitions have to be processed immediately. *) | DefinitionEntry c -> let { const_entry_type = typ; const_entry_opaque = opaque } = c in let { const_entry_body = body; const_entry_feedback = feedback_id } = c in let (body, ctx), side_eff = Future.join body in - let univsctx = Univ.ContextSet.of_context c.const_entry_universes in - let body, ctx, _ = inline_side_effects env body - (Univ.ContextSet.union univsctx ctx) side_eff in - let env = push_context_set ~strict:(not c.const_entry_polymorphic) ctx env in - let abstract = c.const_entry_polymorphic && not (Option.is_empty kn) in + let poly, univs = match c.const_entry_universes with + | Monomorphic_const_entry univs -> false, univs + | Polymorphic_const_entry univs -> true, univs + in + let univsctx = Univ.ContextSet.of_context univs in + let ctx = Univ.ContextSet.union univsctx ctx in + let body, ctx, _ = match trust with + | Pure -> body, ctx, [] + | SideEffects _ -> inline_side_effects env body ctx side_eff + in + let env = push_context_set ~strict:(not poly) ctx env in + let abstract = poly && not (Option.is_empty kn) in let usubst, univs = abstract_constant_universes abstract (Univ.ContextSet.to_context ctx) in let j = infer env body in let typ = match typ with | None -> - if not c.const_entry_polymorphic then (* Old-style polymorphism *) - make_polymorphic_if_constant_for_ind env j - else RegularArity (Vars.subst_univs_level_constr usubst j.uj_type) + Vars.subst_univs_level_constr usubst j.uj_type | Some t -> let tj = infer_type env t in let _ = judge_of_cast env j DEFAULTcast tj in - RegularArity (Vars.subst_univs_level_constr usubst t) + Vars.subst_univs_level_constr usubst t in let def = hcons_constr (Vars.subst_univs_level_constr usubst j.uj_val) in let def = @@ -304,7 +331,14 @@ let infer_declaration ~trust env kn dcl = else Def (Mod_subst.from_val def) in feedback_completion_typecheck feedback_id; - def, typ, None, univs, c.const_entry_inline_code, c.const_entry_secctx + { + Cooking.cook_body = def; + cook_type = typ; + cook_proj = None; + cook_universes = univs; + cook_inline = c.const_entry_inline_code; + cook_context = c.const_entry_secctx; + } | ProjectionEntry {proj_entry_ind = ind; proj_entry_arg = i} -> let mib, _ = Inductive.lookup_mind_specif env (ind,0) in @@ -324,16 +358,14 @@ let infer_declaration ~trust env kn dcl = Polymorphic_const (Univ.ACumulativityInfo.univ_context acumi) in let term, typ = pb.proj_eta in - Def (Mod_subst.from_val (hcons_constr term)), RegularArity typ, Some pb, - univs, false, None - -let global_vars_set_constant_type env = function - | RegularArity t -> global_vars_set env t - | TemplateArity (ctx,_) -> - Context.Rel.fold_outside - (RelDecl.fold_constr - (fun t c -> Id.Set.union (global_vars_set env t) c)) - ctx ~init:Id.Set.empty + { + Cooking.cook_body = Def (Mod_subst.from_val (hcons_constr term)); + cook_type = typ; + cook_proj = Some pb; + cook_universes = univs; + cook_inline = false; + cook_context = None; + } let record_aux env s_ty s_bo suggested_expr = let in_ty = keep_hyps env s_ty in @@ -349,7 +381,9 @@ let record_aux env s_ty s_bo suggested_expr = let suggest_proof_using = ref (fun _ _ _ _ _ -> "") let set_suggest_proof_using f = suggest_proof_using := f -let build_constant_declaration kn env (def,typ,proj,univs,inline_code,ctx) = +let build_constant_declaration kn env result = + let open Cooking in + let typ = result.cook_type in let check declared inferred = let mk_set l = List.fold_right Id.Set.add (List.map NamedDecl.get_id l) Id.Set.empty in let inferred_set, declared_set = mk_set inferred, mk_set declared in @@ -376,11 +410,12 @@ let build_constant_declaration kn env (def,typ,proj,univs,inline_code,ctx) = (* We try to postpone the computation of used section variables *) let hyps, def = let context_ids = List.map NamedDecl.get_id (named_context env) in - match ctx with + let def = result.cook_body in + match result.cook_context with | None when not (List.is_empty context_ids) -> (* No declared section vars, and non-empty section context: we must look at the body NOW, if any *) - let ids_typ = global_vars_set_constant_type env typ in + let ids_typ = global_vars_set env typ in let ids_def = match def with | Undef _ -> Idset.empty | Def cs -> global_vars_set env (Mod_subst.force_constr cs) @@ -408,20 +443,21 @@ let build_constant_declaration kn env (def,typ,proj,univs,inline_code,ctx) = match def with | Undef _ as x -> x (* nothing to check *) | Def cs as x -> - let ids_typ = global_vars_set_constant_type env typ in + let ids_typ = global_vars_set env typ in let ids_def = global_vars_set env (Mod_subst.force_constr cs) in let inferred = keep_hyps env (Idset.union ids_typ ids_def) in check declared inferred; x | OpaqueDef lc -> (* In this case we can postpone the check *) OpaqueDef (Opaqueproof.iter_direct_opaque (fun c -> - let ids_typ = global_vars_set_constant_type env typ in + let ids_typ = global_vars_set env typ in let ids_def = global_vars_set env c in let inferred = keep_hyps env (Idset.union ids_typ ids_def) in check declared inferred) lc) in + let univs = result.cook_universes in let tps = let res = - match proj with + match result.cook_proj with | None -> compile_constant_body env univs def | Some pb -> (* The compilation of primitive projections is a bit tricky, because @@ -434,10 +470,10 @@ let build_constant_declaration kn env (def,typ,proj,univs,inline_code,ctx) = { const_hyps = hyps; const_body = def; const_type = typ; - const_proj = proj; + const_proj = result.cook_proj; const_body_code = None; const_universes = univs; - const_inline_code = inline_code; + const_inline_code = result.cook_inline; const_typing_flags = Environ.typing_flags env; } in @@ -448,10 +484,10 @@ let build_constant_declaration kn env (def,typ,proj,univs,inline_code,ctx) = { const_hyps = hyps; const_body = def; const_type = typ; - const_proj = proj; + const_proj = result.cook_proj; const_body_code = tps; const_universes = univs; - const_inline_code = inline_code; + const_inline_code = result.cook_inline; const_typing_flags = Environ.typing_flags env } (*s Global and local constant declaration. *) @@ -461,11 +497,12 @@ let translate_constant mb env kn ce = (infer_declaration ~trust:mb env (Some kn) ce) let constant_entry_of_side_effect cb u = - let poly, univs = + let univs = match cb.const_universes with - | Monomorphic_const ctx -> false, ctx + | Monomorphic_const uctx -> + Monomorphic_const_entry uctx | Polymorphic_const auctx -> - true, Univ.AUContext.repr auctx + Polymorphic_const_entry (Univ.AUContext.repr auctx) in let pt = match cb.const_body, u with @@ -473,12 +510,10 @@ let constant_entry_of_side_effect cb u = | Def b, `Nothing -> Mod_subst.force_constr b, Univ.ContextSet.empty | _ -> assert false in DefinitionEntry { - const_entry_body = Future.from_val (pt, empty_seff); + const_entry_body = Future.from_val (pt, ()); const_entry_secctx = None; const_entry_feedback = None; - const_entry_type = - (match cb.const_type with RegularArity t -> Some t | _ -> None); - const_entry_polymorphic = poly; + const_entry_type = Some cb.const_type; const_entry_universes = univs; const_entry_opaque = Declareops.is_opaque cb; const_entry_inline_code = cb.const_inline_code } @@ -497,17 +532,18 @@ type side_effect_role = | Schema of inductive * string type exported_side_effect = - constant * constant_body * side_effects constant_entry * side_effect_role + constant * constant_body * side_effect_role let export_side_effects mb env ce = match ce with - | ParameterEntry _ | ProjectionEntry _ -> [], ce + | ParameterEntry e -> [], ParameterEntry e + | ProjectionEntry e -> [], ProjectionEntry e | DefinitionEntry c -> let { const_entry_body = body } = c in let _, eff = Future.force body in let ce = DefinitionEntry { c with const_entry_body = Future.chain ~pure:true body - (fun (b_ctx, _) -> b_ctx, empty_seff) } in + (fun (b_ctx, _) -> b_ctx, ()) } in let not_exists (c,_,_,_) = try ignore(Environ.lookup_constant c env); false with Not_found -> true in @@ -547,8 +583,8 @@ let export_side_effects mb env ce = let env, cbs = List.fold_left (fun (env,cbs) (kn, ocb, u, r) -> let ce = constant_entry_of_side_effect ocb u in - let cb = translate_constant mb env kn ce in - (push_seff env (kn, cb,`Nothing, Subproof),(kn,cb,ce,r) :: cbs)) + let cb = translate_constant Pure env kn ce in + (push_seff env (kn, cb,`Nothing, Subproof),(kn,cb,r) :: cbs)) (env,[]) cbs in translate_seff sl rest (cbs @ acc) env | Some sl, cbs :: rest -> @@ -556,7 +592,7 @@ let export_side_effects mb env ce = let cbs = List.map turn_direct cbs in let env = List.fold_left push_seff env cbs in let ecbs = List.map (fun (kn,cb,u,r) -> - kn, cb, constant_entry_of_side_effect cb u, r) cbs in + kn, cb, r) cbs in translate_seff (Some (sl-cbs_len)) rest (ecbs @ acc) env in translate_seff trusted seff [] env @@ -575,11 +611,11 @@ let translate_recipe env kn r = build_constant_declaration kn env (Cooking.cook_constant ~hcons env r) let translate_local_def mb env id centry = - let def,typ,proj,univs,inline_code,ctx = - infer_declaration ~trust:mb env None (DefinitionEntry centry) in - let typ = type_of_constant_type env typ in - if ctx = None && !Flags.compilation_mode = Flags.BuildVo then begin - match def with + let open Cooking in + let decl = infer_declaration ~trust:mb env None (DefinitionEntry centry) in + let typ = decl.cook_type in + if Option.is_empty decl.cook_context && !Flags.compilation_mode = Flags.BuildVo then begin + match decl.cook_body with | Undef _ -> () | Def _ -> () | OpaqueDef lc -> @@ -592,7 +628,11 @@ let translate_local_def mb env id centry = env ids_def ids_typ context_ids in record_aux env ids_typ ids_def expr end; - def, typ, univs + let univs = match decl.cook_universes with + | Monomorphic_const ctx -> ctx + | Polymorphic_const _ -> assert false + in + decl.cook_body, typ, univs (* Insertion of inductive types. *) @@ -602,7 +642,7 @@ let inline_entry_side_effects env ce = { ce with const_entry_body = Future.chain ~pure:true ce.const_entry_body (fun ((body, ctx), side_eff) -> let body, ctx',_ = inline_side_effects env body ctx side_eff in - (body, ctx'), empty_seff); + (body, ctx'), ()); } let inline_side_effects env body side_eff = diff --git a/kernel/term_typing.mli b/kernel/term_typing.mli index 77d126074f..24153343e7 100644 --- a/kernel/term_typing.mli +++ b/kernel/term_typing.mli @@ -14,8 +14,12 @@ open Entries type side_effects -val translate_local_def : structure_body -> env -> Id.t -> side_effects definition_entry -> - constant_def * types * constant_universes +type _ trust = +| Pure : unit trust +| SideEffects : structure_body -> side_effects trust + +val translate_local_def : 'a trust -> env -> Id.t -> 'a definition_entry -> + constant_def * types * Univ.universe_context val translate_local_assum : env -> types -> types @@ -26,7 +30,7 @@ val inline_side_effects : env -> constr -> side_effects -> constr redexes. *) val inline_entry_side_effects : - env -> side_effects definition_entry -> side_effects definition_entry + env -> side_effects definition_entry -> unit definition_entry (** Same as {!inline_side_effects} but applied to entries. Only modifies the {!Entries.const_entry_body} field. It is meant to get a term out of a not yet type checked proof. *) @@ -43,7 +47,7 @@ val uniq_seff : side_effects -> side_effect list val equal_eff : side_effect -> side_effect -> bool val translate_constant : - structure_body -> env -> constant -> side_effects constant_entry -> + 'a trust -> env -> constant -> 'a constant_entry -> constant_body type side_effect_role = @@ -51,7 +55,7 @@ type side_effect_role = | Schema of inductive * string type exported_side_effect = - constant * constant_body * side_effects constant_entry * side_effect_role + constant * constant_body * side_effect_role (* Given a constant entry containing side effects it exports them (either * by re-checking them or trusting them). Returns the constant bodies to @@ -59,10 +63,7 @@ type exported_side_effect = * needs to be translated as usual after this step. *) val export_side_effects : structure_body -> env -> side_effects constant_entry -> - exported_side_effect list * side_effects constant_entry - -val constant_entry_of_side_effect : - constant_body -> seff_env -> side_effects constant_entry + exported_side_effect list * unit constant_entry val translate_mind : env -> mutual_inductive -> mutual_inductive_entry -> mutual_inductive_body @@ -71,8 +72,8 @@ val translate_recipe : env -> constant -> Cooking.recipe -> constant_body (** Internal functions, mentioned here for debug purpose only *) -val infer_declaration : trust:structure_body -> env -> constant option -> - side_effects constant_entry -> Cooking.result +val infer_declaration : trust:'a trust -> env -> constant option -> + 'a constant_entry -> Cooking.result val build_constant_declaration : constant -> env -> Cooking.result -> constant_body diff --git a/kernel/typeops.ml b/kernel/typeops.ml index b814deb6eb..044877e82a 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -111,36 +111,17 @@ let check_hyps_inclusion env f c sign = (* Type of constants *) -let type_of_constant_type_knowing_parameters env t paramtyps = - match t with - | RegularArity t -> t - | TemplateArity (sign,ar) -> - let ctx = List.rev sign in - let ctx,s = instantiate_universes env ctx ar paramtyps in - mkArity (List.rev ctx,s) - -let type_of_constant_knowing_parameters env (kn,u as cst) args = +let type_of_constant env (kn,u as cst) = let cb = lookup_constant kn env in let () = check_hyps_inclusion env mkConstU cst cb.const_hyps in let ty, cu = constant_type env cst in - let ty = type_of_constant_type_knowing_parameters env ty args in let () = check_constraints cu env in ty -let type_of_constant_knowing_parameters_in env (kn,u as cst) args = +let type_of_constant_in env (kn,u as cst) = let cb = lookup_constant kn env in let () = check_hyps_inclusion env mkConstU cst cb.const_hyps in - let ty = constant_type_in env cst in - type_of_constant_type_knowing_parameters env ty args - -let type_of_constant env cst = - type_of_constant_knowing_parameters env cst [||] - -let type_of_constant_in env cst = - type_of_constant_knowing_parameters_in env cst [||] - -let type_of_constant_type env t = - type_of_constant_type_knowing_parameters env t [||] + constant_type_in env cst (* Type of a lambda-abstraction. *) @@ -369,9 +350,6 @@ let rec execute env cstr = | Ind ind when Environ.template_polymorphic_pind ind env -> let args = Array.map (fun t -> lazy t) argst in type_of_inductive_knowing_parameters env ind args - | Const cst when Environ.template_polymorphic_pconstant cst env -> - let args = Array.map (fun t -> lazy t) argst in - type_of_constant_knowing_parameters env cst args | _ -> (* No template polymorphism *) execute env f @@ -509,8 +487,6 @@ let judge_of_relative env k = make_judge (mkRel k) (type_of_relative env k) let judge_of_variable env x = make_judge (mkVar x) (type_of_variable env x) let judge_of_constant env cst = make_judge (mkConstU cst) (type_of_constant env cst) -let judge_of_constant_knowing_parameters env cst args = - make_judge (mkConstU cst) (type_of_constant_knowing_parameters env cst args) let judge_of_projection env p cj = make_judge (mkProj (p,cj.uj_val)) (type_of_projection env p cj.uj_val cj.uj_type) @@ -559,34 +535,3 @@ let type_of_projection_constant env (p,u) = Vars.subst_instance_constr u pb.proj_type else pb.proj_type | None -> raise (Invalid_argument "type_of_projection: not a projection") - -(* Instantiation of terms on real arguments. *) - -(* Make a type polymorphic if an arity *) - -let extract_level env p = - let _,c = dest_prod_assum env p in - match kind_of_term c with Sort (Type u) -> Univ.Universe.level u | _ -> None - -let extract_context_levels env l = - let fold l = function - | RelDecl.LocalAssum (_,p) -> extract_level env p :: l - | RelDecl.LocalDef _ -> l - in - List.fold_left fold [] l - -let make_polymorphic_if_constant_for_ind env {uj_val = c; uj_type = t} = - let params, ccl = dest_prod_assum env t in - match kind_of_term ccl with - | Sort (Type u) -> - let ind, l = decompose_app (whd_all env c) in - if isInd ind && List.is_empty l then - let mis = lookup_mind_specif env (fst (destInd ind)) in - let nparams = Inductive.inductive_params mis in - let paramsl = CList.lastn nparams params in - let param_ccls = extract_context_levels env paramsl in - let s = { template_param_levels = param_ccls; template_level = u} in - TemplateArity (params,s) - else RegularArity t - | _ -> - RegularArity t diff --git a/kernel/typeops.mli b/kernel/typeops.mli index 24521070e2..a8f7fba9a0 100644 --- a/kernel/typeops.mli +++ b/kernel/typeops.mli @@ -11,7 +11,6 @@ open Univ open Term open Environ open Entries -open Declarations (** {6 Typing functions (not yet tagged as safe) } @@ -53,9 +52,6 @@ val judge_of_variable : env -> variable -> unsafe_judgment val judge_of_constant : env -> pconstant -> unsafe_judgment -val judge_of_constant_knowing_parameters : - env -> pconstant -> types Lazy.t array -> unsafe_judgment - (** {6 type of an applied projection } *) val judge_of_projection : env -> Names.projection -> unsafe_judgment -> unsafe_judgment @@ -98,21 +94,9 @@ val judge_of_case : env -> case_info -> unsafe_judgment -> unsafe_judgment -> unsafe_judgment array -> unsafe_judgment -val type_of_constant_type : env -> constant_type -> types - val type_of_projection_constant : env -> Names.projection puniverses -> types val type_of_constant_in : env -> pconstant -> types -val type_of_constant_type_knowing_parameters : - env -> constant_type -> types Lazy.t array -> types - -val type_of_constant_knowing_parameters_in : - env -> pconstant -> types Lazy.t array -> types - -(** Make a type polymorphic if an arity *) -val make_polymorphic_if_constant_for_ind : env -> unsafe_judgment -> - constant_type - (** Check that hyps are included in env and fails with error otherwise *) val check_hyps_inclusion : env -> ('a -> constr) -> 'a -> Context.Named.t -> unit diff --git a/kernel/uGraph.mli b/kernel/uGraph.mli index 4de373eb4c..2fe5550184 100644 --- a/kernel/uGraph.mli +++ b/kernel/uGraph.mli @@ -59,7 +59,7 @@ val check_subtype : AUContext.t check_function (** {6 Pretty-printing of universes. } *) -val pr_universes : (Level.t -> Pp.std_ppcmds) -> universes -> Pp.std_ppcmds +val pr_universes : (Level.t -> Pp.t) -> universes -> Pp.t (** {6 Dumping to a file } *) diff --git a/kernel/univ.ml b/kernel/univ.ml index 02b02db893..d915fb8c98 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -892,7 +892,7 @@ module Instance : sig val subst_fn : universe_level_subst_fn -> t -> t - val pr : (Level.t -> Pp.std_ppcmds) -> t -> Pp.std_ppcmds + val pr : (Level.t -> Pp.t) -> t -> Pp.t val levels : t -> LSet.t end = struct diff --git a/kernel/univ.mli b/kernel/univ.mli index 99092a543e..a4f2e26b63 100644 --- a/kernel/univ.mli +++ b/kernel/univ.mli @@ -37,7 +37,7 @@ sig (** Create a new universe level from a unique identifier and an associated module path. *) - val pr : t -> Pp.std_ppcmds + val pr : t -> Pp.t (** Pretty-printing *) val to_string : t -> string @@ -56,7 +56,7 @@ module LSet : sig include CSig.SetS with type elt = universe_level - val pr : (Level.t -> Pp.std_ppcmds) -> t -> Pp.std_ppcmds + val pr : (Level.t -> Pp.t) -> t -> Pp.t (** Pretty-printing *) end @@ -86,10 +86,10 @@ sig val make : Level.t -> t (** Create a universe representing the given level. *) - val pr : t -> Pp.std_ppcmds + val pr : t -> Pp.t (** Pretty-printing *) - val pr_with : (Level.t -> Pp.std_ppcmds) -> t -> Pp.std_ppcmds + val pr_with : (Level.t -> Pp.t) -> t -> Pp.t val is_level : t -> bool (** Test if the universe is a level or an algebraic universe. *) @@ -127,7 +127,7 @@ type universe = Universe.t (** Alias name. *) -val pr_uni : universe -> Pp.std_ppcmds +val pr_uni : universe -> Pp.t (** The universes hierarchy: Type 0- = Prop <= Type 0 = Set <= Type 1 <= ... Typing of universes: Type 0-, Type 0 : Type 1; Type i : Type (i+1) if i>0 *) @@ -218,7 +218,7 @@ sig (** [subst_union x y] favors the bindings of the first map that are [Some], otherwise takes y's bindings. *) - val pr : ('a -> Pp.std_ppcmds) -> 'a t -> Pp.std_ppcmds + val pr : ('a -> Pp.t) -> 'a t -> Pp.t (** Pretty-printing *) end @@ -270,7 +270,7 @@ sig val subst_fn : universe_level_subst_fn -> t -> t (** Substitution by a level-to-level function. *) - val pr : (Level.t -> Pp.std_ppcmds) -> t -> Pp.std_ppcmds + val pr : (Level.t -> Pp.t) -> t -> Pp.t (** Pretty-printing, no comments *) val levels : t -> LSet.t @@ -463,18 +463,18 @@ val make_abstract_instance : abstract_universe_context -> universe_instance (** {6 Pretty-printing of universes. } *) -val pr_constraint_type : constraint_type -> Pp.std_ppcmds -val pr_constraints : (Level.t -> Pp.std_ppcmds) -> constraints -> Pp.std_ppcmds -val pr_universe_context : (Level.t -> Pp.std_ppcmds) -> universe_context -> Pp.std_ppcmds -val pr_cumulativity_info : (Level.t -> Pp.std_ppcmds) -> cumulativity_info -> Pp.std_ppcmds -val pr_abstract_universe_context : (Level.t -> Pp.std_ppcmds) -> abstract_universe_context -> Pp.std_ppcmds -val pr_abstract_cumulativity_info : (Level.t -> Pp.std_ppcmds) -> abstract_cumulativity_info -> Pp.std_ppcmds -val pr_universe_context_set : (Level.t -> Pp.std_ppcmds) -> universe_context_set -> Pp.std_ppcmds -val explain_universe_inconsistency : (Level.t -> Pp.std_ppcmds) -> - univ_inconsistency -> Pp.std_ppcmds - -val pr_universe_level_subst : universe_level_subst -> Pp.std_ppcmds -val pr_universe_subst : universe_subst -> Pp.std_ppcmds +val pr_constraint_type : constraint_type -> Pp.t +val pr_constraints : (Level.t -> Pp.t) -> constraints -> Pp.t +val pr_universe_context : (Level.t -> Pp.t) -> universe_context -> Pp.t +val pr_cumulativity_info : (Level.t -> Pp.t) -> cumulativity_info -> Pp.t +val pr_abstract_universe_context : (Level.t -> Pp.t) -> abstract_universe_context -> Pp.t +val pr_abstract_cumulativity_info : (Level.t -> Pp.t) -> abstract_cumulativity_info -> Pp.t +val pr_universe_context_set : (Level.t -> Pp.t) -> universe_context_set -> Pp.t +val explain_universe_inconsistency : (Level.t -> Pp.t) -> + univ_inconsistency -> Pp.t + +val pr_universe_level_subst : universe_level_subst -> Pp.t +val pr_universe_subst : universe_subst -> Pp.t (** {6 Hash-consing } *) diff --git a/kernel/vm.mli b/kernel/vm.mli index 6e9579aa46..df638acc1f 100644 --- a/kernel/vm.mli +++ b/kernel/vm.mli @@ -50,9 +50,9 @@ type whd = (** For debugging purposes only *) -val pr_atom : atom -> Pp.std_ppcmds -val pr_whd : whd -> Pp.std_ppcmds -val pr_stack : stack -> Pp.std_ppcmds +val pr_atom : atom -> Pp.t +val pr_whd : whd -> Pp.t +val pr_stack : stack -> Pp.t (** Constructors *) diff --git a/lib/cErrors.ml b/lib/cErrors.ml index 8ef11a2cdd..3f4e8aa12f 100644 --- a/lib/cErrors.ml +++ b/lib/cErrors.ml @@ -14,7 +14,7 @@ let push = Backtrace.add_backtrace (* Errors *) -exception Anomaly of string option * std_ppcmds (* System errors *) +exception Anomaly of string option * Pp.t (* System errors *) let _ = let pr = function @@ -33,7 +33,7 @@ let is_anomaly = function | Anomaly _ -> true | _ -> false -exception UserError of string option * std_ppcmds (* User errors *) +exception UserError of string option * Pp.t (* User errors *) let todo s = prerr_string ("TODO: "^s^"\n") @@ -41,7 +41,7 @@ let user_err ?loc ?hdr strm = Loc.raise ?loc (UserError (hdr, strm)) let invalid_arg ?loc s = Loc.raise ?loc (Invalid_argument s) -exception AlreadyDeclared of std_ppcmds (* for already declared Schemes *) +exception AlreadyDeclared of Pp.t (* for already declared Schemes *) let alreadydeclared pps = raise (AlreadyDeclared(pps)) exception Timeout diff --git a/lib/cErrors.mli b/lib/cErrors.mli index ca0838575e..f3253979f2 100644 --- a/lib/cErrors.mli +++ b/lib/cErrors.mli @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -open Pp - (** This modules implements basic manipulations of errors for use throughout Coq's code. *) @@ -21,10 +19,10 @@ val push : exn -> Exninfo.iexn [Anomaly] is used for system errors and [UserError] for the user's ones. *) -val make_anomaly : ?label:string -> std_ppcmds -> exn +val make_anomaly : ?label:string -> Pp.t -> exn (** Create an anomaly. *) -val anomaly : ?loc:Loc.t -> ?label:string -> std_ppcmds -> 'a +val anomaly : ?loc:Loc.t -> ?label:string -> Pp.t -> 'a (** Raise an anomaly, with an optional location and an optional label identifying the anomaly. *) @@ -33,16 +31,16 @@ val is_anomaly : exn -> bool This is mostly provided for compatibility. Please avoid doing specific tricks with anomalies thanks to it. See rather [noncritical] below. *) -exception UserError of string option * std_ppcmds +exception UserError of string option * Pp.t (** Main error signaling exception. It carries a header plus a pretty printing doc *) -val user_err : ?loc:Loc.t -> ?hdr:string -> std_ppcmds -> 'a +val user_err : ?loc:Loc.t -> ?hdr:string -> Pp.t -> 'a (** Main error raising primitive. [user_err ?loc ?hdr pp] signals an error [pp] with optional header and location [hdr] [loc] *) -exception AlreadyDeclared of std_ppcmds -val alreadydeclared : std_ppcmds -> 'a +exception AlreadyDeclared of Pp.t +val alreadydeclared : Pp.t -> 'a val invalid_arg : ?loc:Loc.t -> string -> 'a @@ -74,16 +72,16 @@ exception Quit exception Unhandled -val register_handler : (exn -> Pp.std_ppcmds) -> unit +val register_handler : (exn -> Pp.t) -> unit (** The standard exception printer *) -val print : ?info:Exninfo.info -> exn -> Pp.std_ppcmds -val iprint : Exninfo.iexn -> Pp.std_ppcmds +val print : ?info:Exninfo.info -> exn -> Pp.t +val iprint : Exninfo.iexn -> Pp.t (** Same as [print], except that the "Please report" part of an anomaly isn't printed (used in Ltac debugging). *) -val print_no_report : exn -> Pp.std_ppcmds -val iprint_no_report : Exninfo.iexn -> Pp.std_ppcmds +val print_no_report : exn -> Pp.t +val iprint_no_report : Exninfo.iexn -> Pp.t (** Critical exceptions should not be caught and ignored by mistake by inner functions during a [vernacinterp]. They should be handled @@ -100,9 +98,9 @@ val handled : exn -> bool val error : string -> 'a [@@ocaml.deprecated "use [user_err] instead"] -val errorlabstrm : string -> std_ppcmds -> 'a +val errorlabstrm : string -> Pp.t -> 'a [@@ocaml.deprecated "use [user_err ~hdr] instead"] -val user_err_loc : Loc.t * string * std_ppcmds -> 'a +val user_err_loc : Loc.t * string * Pp.t -> 'a [@@ocaml.deprecated "use [user_err ~loc] instead"] diff --git a/lib/cWarnings.mli b/lib/cWarnings.mli index 0622d7593b..ba152a19b6 100644 --- a/lib/cWarnings.mli +++ b/lib/cWarnings.mli @@ -11,7 +11,7 @@ type status = Disabled | Enabled | AsError val set_current_loc : Loc.t option -> unit val create : name:string -> category:string -> ?default:status -> - ('a -> Pp.std_ppcmds) -> ?loc:Loc.t -> 'a -> unit + ('a -> Pp.t) -> ?loc:Loc.t -> 'a -> unit val get_flags : unit -> string val set_flags : string -> unit diff --git a/lib/explore.ml b/lib/explore.ml index 1919af51ea..7da077e968 100644 --- a/lib/explore.ml +++ b/lib/explore.ml @@ -14,7 +14,7 @@ module type SearchProblem = sig type state val branching : state -> state list val success : state -> bool - val pp : state -> std_ppcmds + val pp : state -> Pp.t end module Make = functor(S : SearchProblem) -> struct diff --git a/lib/explore.mli b/lib/explore.mli index 3c31d07669..5875246ffc 100644 --- a/lib/explore.mli +++ b/lib/explore.mli @@ -27,7 +27,7 @@ module type SearchProblem = sig val success : state -> bool - val pp : state -> Pp.std_ppcmds + val pp : state -> Pp.t end diff --git a/lib/feedback.ml b/lib/feedback.ml index ed1d495d74..54d16a9be3 100644 --- a/lib/feedback.ml +++ b/lib/feedback.ml @@ -32,7 +32,7 @@ type feedback_content = (* Extra metadata *) | Custom of Loc.t option * string * xml (* Generic messages *) - | Message of level * Loc.t option * Pp.std_ppcmds + | Message of level * Loc.t option * Pp.t type feedback = { id : Stateid.t; diff --git a/lib/feedback.mli b/lib/feedback.mli index bd3316abb1..45a02d384a 100644 --- a/lib/feedback.mli +++ b/lib/feedback.mli @@ -40,7 +40,7 @@ type feedback_content = (* Extra metadata *) | Custom of Loc.t option * string * xml (* Generic messages *) - | Message of level * Loc.t option * Pp.std_ppcmds + | Message of level * Loc.t option * Pp.t type feedback = { id : Stateid.t; (* The document part concerned *) @@ -78,20 +78,20 @@ relaxed. *) (* Should we advertise these functions more? Should they be the ONLY allowed way to output something? *) -val msg_info : ?loc:Loc.t -> Pp.std_ppcmds -> unit +val msg_info : ?loc:Loc.t -> Pp.t -> unit (** Message that displays information, usually in verbose mode, such as [Foobar is defined] *) -val msg_notice : ?loc:Loc.t -> Pp.std_ppcmds -> unit +val msg_notice : ?loc:Loc.t -> Pp.t -> unit (** Message that should be displayed, such as [Print Foo] or [Show Bar]. *) -val msg_warning : ?loc:Loc.t -> Pp.std_ppcmds -> unit +val msg_warning : ?loc:Loc.t -> Pp.t -> unit (** Message indicating that something went wrong, but without serious consequences. *) -val msg_error : ?loc:Loc.t -> Pp.std_ppcmds -> unit +val msg_error : ?loc:Loc.t -> Pp.t -> unit (** Message indicating that something went really wrong, though still recoverable; otherwise an exception would have been raised. *) -val msg_debug : ?loc:Loc.t -> Pp.std_ppcmds -> unit +val msg_debug : ?loc:Loc.t -> Pp.t -> unit (** For debugging purposes *) diff --git a/lib/flags.ml b/lib/flags.ml index 5d9d9dcf50..0bce22f584 100644 --- a/lib/flags.ml +++ b/lib/flags.ml @@ -106,7 +106,7 @@ let we_are_parsing = ref false (* Current means no particular compatibility consideration. For correct comparisons, this constructor should remain the last one. *) -type compat_version = VOld | V8_5 | V8_6 | Current +type compat_version = VOld | V8_5 | V8_6 | V8_7 | Current let compat_version = ref Current @@ -120,6 +120,9 @@ let version_compare v1 v2 = match v1, v2 with | V8_6, V8_6 -> 0 | V8_6, _ -> -1 | _, V8_6 -> 1 + | V8_7, V8_7 -> 0 + | V8_7, _ -> -1 + | _, V8_7 -> 1 | Current, Current -> 0 let version_strictly_greater v = version_compare !compat_version v > 0 @@ -129,6 +132,7 @@ let pr_version = function | VOld -> "old" | V8_5 -> "8.5" | V8_6 -> "8.6" + | V8_7 -> "8.7" | Current -> "current" (* Translate *) diff --git a/lib/flags.mli b/lib/flags.mli index e63f1ec26d..eb4c37a548 100644 --- a/lib/flags.mli +++ b/lib/flags.mli @@ -77,7 +77,7 @@ val raw_print : bool ref (* Univ print flag, never set anywere. Maybe should belong to Univ? *) val univ_print : bool ref -type compat_version = VOld | V8_5 | V8_6 | Current +type compat_version = VOld | V8_5 | V8_6 | V8_7 | Current val compat_version : compat_version ref val version_compare : compat_version -> compat_version -> int val version_strictly_greater : compat_version -> bool diff --git a/lib/future.mli b/lib/future.mli index ce91556572..acfce51a07 100644 --- a/lib/future.mli +++ b/lib/future.mli @@ -154,7 +154,7 @@ val purify : ('a -> 'b) -> 'a -> 'b val transactify : ('a -> 'b) -> 'a -> 'b (** Debug: print a computation given an inner printing function. *) -val print : ('a -> Pp.std_ppcmds) -> 'a computation -> Pp.std_ppcmds +val print : ('a -> Pp.t) -> 'a computation -> Pp.t type freeze (* These functions are needed to get rid of side effects. @@ -162,5 +162,5 @@ type freeze deal with the whole system state. *) val set_freeze : (unit -> freeze) -> (freeze -> unit) -> unit -val customize_not_ready_msg : (string -> Pp.std_ppcmds) -> unit -val customize_not_here_msg : (string -> Pp.std_ppcmds) -> unit +val customize_not_ready_msg : (string -> Pp.t) -> unit +val customize_not_here_msg : (string -> Pp.t) -> unit diff --git a/lib/genarg.ml b/lib/genarg.ml index 1174cfe104..b78fe40373 100644 --- a/lib/genarg.ml +++ b/lib/genarg.ml @@ -58,7 +58,7 @@ fun t1 t2 -> match t1, t2 with end | _ -> None -let rec pr_genarg_type : type a b c. (a, b, c) genarg_type -> std_ppcmds = function +let rec pr_genarg_type : type a b c. (a, b, c) genarg_type -> Pp.t = function | ListArg t -> pr_genarg_type t ++ spc () ++ str "list" | OptArg t -> pr_genarg_type t ++ spc () ++ str "opt" | PairArg (t1, t2) -> diff --git a/lib/genarg.mli b/lib/genarg.mli index d7f24eac1f..7fa71299e3 100644 --- a/lib/genarg.mli +++ b/lib/genarg.mli @@ -146,7 +146,7 @@ val abstract_argument_type_eq : ('a, 'l) abstract_argument_type -> ('b, 'l) abstract_argument_type -> ('a, 'b) CSig.eq option -val pr_argument_type : argument_type -> Pp.std_ppcmds +val pr_argument_type : argument_type -> Pp.t (** Print a human-readable representation for a given type. *) val genarg_tag : 'a generic_argument -> argument_type @@ -39,7 +39,9 @@ type doc_view = (* Following discussion on #390, we play on the safe side and make the internal representation opaque here. *) type t = doc_view + type std_ppcmds = t +[@@ocaml.deprecated "alias of Pp.t"] let repr x = x let unrepr x = x diff --git a/lib/pp.mli b/lib/pp.mli index 96656c8b65..2d11cad86e 100644 --- a/lib/pp.mli +++ b/lib/pp.mli @@ -10,7 +10,7 @@ (** Pretty printing guidelines ******************************************) (* *) -(* `Pp.t` or `Pp.std_ppcmds` is the main pretty printing document type *) +(* `Pp.t` is the main pretty printing document type *) (* in the Coq system. Documents are composed laying out boxes, and *) (* users can add arbitrary tag metadata that backends are free *) (* to interpret. *) @@ -39,7 +39,9 @@ type pp_tag = string (* Following discussion on #390, we play on the safe side and make the internal representation opaque here. *) type t + type std_ppcmds = t +[@@ocaml.deprecated "alias of Pp.t"] type block_type = | Pp_hbox of int @@ -58,127 +60,127 @@ type doc_view = | Ppcmd_force_newline | Ppcmd_comment of string list -val repr : std_ppcmds -> doc_view -val unrepr : doc_view -> std_ppcmds +val repr : t -> doc_view +val unrepr : doc_view -> t (** {6 Formatting commands} *) -val str : string -> std_ppcmds -val brk : int * int -> std_ppcmds -val fnl : unit -> std_ppcmds -val ws : int -> std_ppcmds -val mt : unit -> std_ppcmds -val ismt : std_ppcmds -> bool +val str : string -> t +val brk : int * int -> t +val fnl : unit -> t +val ws : int -> t +val mt : unit -> t +val ismt : t -> bool -val comment : string list -> std_ppcmds +val comment : string list -> t (** {6 Manipulation commands} *) -val app : std_ppcmds -> std_ppcmds -> std_ppcmds +val app : t -> t -> t (** Concatenation. *) -val seq : std_ppcmds list -> std_ppcmds +val seq : t list -> t (** Multi-Concatenation. *) -val (++) : std_ppcmds -> std_ppcmds -> std_ppcmds +val (++) : t -> t -> t (** Infix alias for [app]. *) (** {6 Derived commands} *) -val spc : unit -> std_ppcmds -val cut : unit -> std_ppcmds -val align : unit -> std_ppcmds -val int : int -> std_ppcmds -val real : float -> std_ppcmds -val bool : bool -> std_ppcmds -val qstring : string -> std_ppcmds -val qs : string -> std_ppcmds -val quote : std_ppcmds -> std_ppcmds -val strbrk : string -> std_ppcmds +val spc : unit -> t +val cut : unit -> t +val align : unit -> t +val int : int -> t +val real : float -> t +val bool : bool -> t +val qstring : string -> t +val qs : string -> t +val quote : t -> t +val strbrk : string -> t (** {6 Boxing commands} *) -val h : int -> std_ppcmds -> std_ppcmds -val v : int -> std_ppcmds -> std_ppcmds -val hv : int -> std_ppcmds -> std_ppcmds -val hov : int -> std_ppcmds -> std_ppcmds +val h : int -> t -> t +val v : int -> t -> t +val hv : int -> t -> t +val hov : int -> t -> t (** {6 Tagging} *) -val tag : pp_tag -> std_ppcmds -> std_ppcmds +val tag : pp_tag -> t -> t (** {6 Printing combinators} *) -val pr_comma : unit -> std_ppcmds +val pr_comma : unit -> t (** Well-spaced comma. *) -val pr_semicolon : unit -> std_ppcmds +val pr_semicolon : unit -> t (** Well-spaced semicolon. *) -val pr_bar : unit -> std_ppcmds +val pr_bar : unit -> t (** Well-spaced pipe bar. *) -val pr_arg : ('a -> std_ppcmds) -> 'a -> std_ppcmds +val pr_arg : ('a -> t) -> 'a -> t (** Adds a space in front of its argument. *) -val pr_non_empty_arg : ('a -> std_ppcmds) -> 'a -> std_ppcmds +val pr_non_empty_arg : ('a -> t) -> 'a -> t (** Adds a space in front of its argument if non empty. *) -val pr_opt : ('a -> std_ppcmds) -> 'a option -> std_ppcmds +val pr_opt : ('a -> t) -> 'a option -> t (** Inner object preceded with a space if [Some], nothing otherwise. *) -val pr_opt_no_spc : ('a -> std_ppcmds) -> 'a option -> std_ppcmds +val pr_opt_no_spc : ('a -> t) -> 'a option -> t (** Same as [pr_opt] but without the leading space. *) -val pr_nth : int -> std_ppcmds +val pr_nth : int -> t (** Ordinal number with the correct suffix (i.e. "st", "nd", "th", etc.). *) -val prlist : ('a -> std_ppcmds) -> 'a list -> std_ppcmds +val prlist : ('a -> t) -> 'a list -> t (** Concatenation of the list contents, without any separator. Unlike all other functions below, [prlist] works lazily. If a strict behavior is needed, use [prlist_strict] instead. *) -val prlist_strict : ('a -> std_ppcmds) -> 'a list -> std_ppcmds +val prlist_strict : ('a -> t) -> 'a list -> t (** Same as [prlist], but strict. *) val prlist_with_sep : - (unit -> std_ppcmds) -> ('a -> std_ppcmds) -> 'a list -> std_ppcmds + (unit -> t) -> ('a -> t) -> 'a list -> t (** [prlist_with_sep sep pr [a ; ... ; c]] outputs [pr a ++ sep () ++ ... ++ sep () ++ pr c]. where the thunk sep is memoized, rather than being called each place its result is used. *) -val prvect : ('a -> std_ppcmds) -> 'a array -> std_ppcmds +val prvect : ('a -> t) -> 'a array -> t (** As [prlist], but on arrays. *) -val prvecti : (int -> 'a -> std_ppcmds) -> 'a array -> std_ppcmds +val prvecti : (int -> 'a -> t) -> 'a array -> t (** Indexed version of [prvect]. *) val prvect_with_sep : - (unit -> std_ppcmds) -> ('a -> std_ppcmds) -> 'a array -> std_ppcmds + (unit -> t) -> ('a -> t) -> 'a array -> t (** As [prlist_with_sep], but on arrays. *) val prvecti_with_sep : - (unit -> std_ppcmds) -> (int -> 'a -> std_ppcmds) -> 'a array -> std_ppcmds + (unit -> t) -> (int -> 'a -> t) -> 'a array -> t (** Indexed version of [prvect_with_sep]. *) -val pr_enum : ('a -> std_ppcmds) -> 'a list -> std_ppcmds +val pr_enum : ('a -> t) -> 'a list -> t (** [pr_enum pr [a ; b ; ... ; c]] outputs [pr a ++ str "," ++ pr b ++ str "," ++ ... ++ str "and" ++ pr c]. *) -val pr_sequence : ('a -> std_ppcmds) -> 'a list -> std_ppcmds +val pr_sequence : ('a -> t) -> 'a list -> t (** Sequence of objects separated by space (unless an element is empty). *) -val surround : std_ppcmds -> std_ppcmds +val surround : t -> t (** Surround with parenthesis. *) -val pr_vertical_list : ('b -> std_ppcmds) -> 'b list -> std_ppcmds +val pr_vertical_list : ('b -> t) -> 'b list -> t (** {6 Main renderers, to formatter and to string } *) (** [pp_with fmt pp] Print [pp] to [fmt] and don't flush [fmt] *) -val pp_with : Format.formatter -> std_ppcmds -> unit +val pp_with : Format.formatter -> t -> unit -val string_of_ppcmds : std_ppcmds -> string +val string_of_ppcmds : t -> string diff --git a/lib/profile.ml b/lib/profile.ml index b669161858..0bc226a450 100644 --- a/lib/profile.ml +++ b/lib/profile.ml @@ -85,6 +85,9 @@ let init_alloc = ref 0.0 let reset_profile () = List.iter reset_record !prof_table let init_profile () = + (* We test Flags.profile as a way to support declaring profiled + functions in plugins *) + if !prof_table <> [] || Flags.profile then begin let outside = create_record () in stack := [outside]; last_alloc := get_alloc (); @@ -92,6 +95,7 @@ let init_profile () = init_time := get_time (); outside.tottime <- - !init_time; outside.owntime <- - !init_time + end let ajoute n o = o.owntime <- o.owntime + n.owntime; @@ -317,15 +321,15 @@ let adjust_time ov_bc ov_ad e = owntime = e.owntime - int_of_float (ad_imm +. bc_imm) } let close_profile print = - let dw = spent_alloc () in - let t = get_time () in - match !stack with - | [outside] -> - outside.tottime <- outside.tottime + t; - outside.owntime <- outside.owntime + t; - ajoute_ownalloc outside dw; - ajoute_totalloc outside dw; - if !prof_table <> [] then begin + if !prof_table <> [] then begin + let dw = spent_alloc () in + let t = get_time () in + match !stack with + | [outside] -> + outside.tottime <- outside.tottime + t; + outside.owntime <- outside.owntime + t; + ajoute_ownalloc outside dw; + ajoute_totalloc outside dw; let ov_bc = time_overhead_B_C () (* B+C overhead *) in let ov_ad = time_overhead_A_D () (* A+D overhead *) in let adjust (n,e) = (n, adjust_time ov_bc ov_ad e) in @@ -346,8 +350,8 @@ let close_profile print = in if print then format_profile updated_data; init_profile () - end - | _ -> failwith "Inconsistency" + | _ -> failwith "Inconsistency" + end let print_profile () = close_profile true @@ -358,9 +362,6 @@ let declare_profile name = prof_table := (name,e)::!prof_table; e -(* Default initialization, may be overridden *) -let _ = init_profile () - (******************************) (* Entry points for profiling *) let profile1 e f a = diff --git a/lib/rtree.mli b/lib/rtree.mli index a1b06f38ef..1a916bbaf0 100644 --- a/lib/rtree.mli +++ b/lib/rtree.mli @@ -78,7 +78,7 @@ val map : ('a -> 'b) -> 'a t -> 'b t val smartmap : ('a -> 'a) -> 'a t -> 'a t (** A rather simple minded pretty-printer *) -val pp_tree : ('a -> Pp.std_ppcmds) -> 'a t -> Pp.std_ppcmds +val pp_tree : ('a -> Pp.t) -> 'a t -> Pp.t val eq_rtree : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool (** @deprecated Same as [Rtree.equal] *) diff --git a/lib/system.mli b/lib/system.mli index 5f800f191d..7281de97c9 100644 --- a/lib/system.mli +++ b/lib/system.mli @@ -96,7 +96,7 @@ type time val get_time : unit -> time val time_difference : time -> time -> float (** in seconds *) -val fmt_time_difference : time -> time -> Pp.std_ppcmds +val fmt_time_difference : time -> time -> Pp.t val with_time : bool -> ('a -> 'b) -> 'a -> 'b diff --git a/library/declaremods.mli b/library/declaremods.mli index 1f2aaf7b54..005594b8d8 100644 --- a/library/declaremods.mli +++ b/library/declaremods.mli @@ -121,7 +121,7 @@ val iter_all_segments : (Libnames.object_name -> Libobject.obj -> unit) -> unit -val debug_print_modtab : unit -> Pp.std_ppcmds +val debug_print_modtab : unit -> Pp.t (** For printing modules, [process_module_binding] adds names of bound module (and its components) to Nametab. It also loads diff --git a/library/global.ml b/library/global.ml index 5b17855dce..963c977417 100644 --- a/library/global.ml +++ b/library/global.ml @@ -86,6 +86,7 @@ let push_context b c = globalize0 (Safe_typing.push_context b c) let set_engagement c = globalize0 (Safe_typing.set_engagement c) let set_typing_flags c = globalize0 (Safe_typing.set_typing_flags c) +let export_private_constants ~in_section cd = globalize (Safe_typing.export_private_constants ~in_section cd) let add_constant dir id d = globalize (Safe_typing.add_constant dir (i2l id) d) let add_mind dir id mie = globalize (Safe_typing.add_mind dir (i2l id) mie) let add_modtype id me inl = globalize (Safe_typing.add_modtype (i2l id) me inl) @@ -198,8 +199,7 @@ let type_of_global_in_context env r = | ConstRef c -> let cb = Environ.lookup_constant c env in let univs = Declareops.constant_polymorphic_context cb in - let env = Environ.push_context ~strict:false (Univ.AUContext.repr univs) env in - Typeops.type_of_constant_type env cb.Declarations.const_type, univs + cb.Declarations.const_type, univs | IndRef ind -> let (mib, oib as specif) = Inductive.lookup_mind_specif env ind in let univs = Declareops.inductive_polymorphic_context mib in @@ -254,7 +254,7 @@ let is_template_polymorphic r = let env = env() in match r with | VarRef id -> false - | ConstRef c -> Environ.template_polymorphic_constant c env + | ConstRef c -> false | IndRef ind -> Environ.template_polymorphic_ind ind env | ConstructRef cstr -> Environ.template_polymorphic_ind (inductive_of_constructor cstr) env diff --git a/library/global.mli b/library/global.mli index 48bcfa989f..c777691d11 100644 --- a/library/global.mli +++ b/library/global.mli @@ -34,9 +34,12 @@ val set_typing_flags : Declarations.typing_flags -> unit val push_named_assum : (Id.t * Constr.types * bool) Univ.in_universe_context_set -> unit val push_named_def : (Id.t * Safe_typing.private_constants Entries.definition_entry) -> Univ.universe_context_set +val export_private_constants : in_section:bool -> + Safe_typing.private_constants Entries.constant_entry -> + unit Entries.constant_entry * Safe_typing.exported_private_constant list + val add_constant : - DirPath.t -> Id.t -> Safe_typing.global_declaration -> - constant * Safe_typing.exported_private_constant list + DirPath.t -> Id.t -> Safe_typing.global_declaration -> constant val add_mind : DirPath.t -> Id.t -> Entries.mutual_inductive_entry -> mutual_inductive diff --git a/library/goptions.ml b/library/goptions.ml index fe014ef68e..184c6fa119 100644 --- a/library/goptions.ml +++ b/library/goptions.ml @@ -57,10 +57,10 @@ module MakeTable = val table : (string * key table_of_A) list ref val encode : key -> t val subst : substitution -> t -> t - val printer : t -> std_ppcmds + val printer : t -> Pp.t val key : option_name val title : string - val member_message : t -> bool -> std_ppcmds + val member_message : t -> bool -> Pp.t end) -> struct type option_mark = @@ -131,7 +131,7 @@ module type StringConvertArg = sig val key : option_name val title : string - val member_message : string -> bool -> std_ppcmds + val member_message : string -> bool -> Pp.t end module StringConvert = functor (A : StringConvertArg) -> @@ -161,10 +161,10 @@ sig val compare : t -> t -> int val encode : reference -> t val subst : substitution -> t -> t - val printer : t -> std_ppcmds + val printer : t -> Pp.t val key : option_name val title : string - val member_message : t -> bool -> std_ppcmds + val member_message : t -> bool -> Pp.t end module RefConvert = functor (A : RefConvertArg) -> diff --git a/library/goptions.mli b/library/goptions.mli index 3100c1ce72..cec7250f1f 100644 --- a/library/goptions.mli +++ b/library/goptions.mli @@ -43,7 +43,6 @@ All options are synchronized with the document. *) -open Pp open Libnames open Mod_subst @@ -64,7 +63,7 @@ module MakeStringTable : (A : sig val key : option_name val title : string - val member_message : string -> bool -> std_ppcmds + val member_message : string -> bool -> Pp.t end) -> sig val active : string -> bool @@ -88,10 +87,10 @@ module MakeRefTable : val compare : t -> t -> int val encode : reference -> t val subst : substitution -> t -> t - val printer : t -> std_ppcmds + val printer : t -> Pp.t val key : option_name val title : string - val member_message : t -> bool -> std_ppcmds + val member_message : t -> bool -> Pp.t end) -> sig val active : A.t -> bool @@ -177,6 +176,6 @@ type option_state = { } val get_tables : unit -> option_state OptionMap.t -val print_tables : unit -> std_ppcmds +val print_tables : unit -> Pp.t val error_undeclared_key : option_name -> 'a diff --git a/library/keys.mli b/library/keys.mli index 6fe9efc6ec..d5dc0e2a1f 100644 --- a/library/keys.mli +++ b/library/keys.mli @@ -19,5 +19,5 @@ val equiv_keys : key -> key -> bool val constr_key : ('a -> ('a, 't, 'u, 'i) Constr.kind_of_term) -> 'a -> key option (** Compute the head key of a term. *) -val pr_keys : (global_reference -> Pp.std_ppcmds) -> Pp.std_ppcmds +val pr_keys : (global_reference -> Pp.t) -> Pp.t (** Pretty-print the mapping *) diff --git a/library/libnames.mli b/library/libnames.mli index b6d6f7f3bc..1b351290a4 100644 --- a/library/libnames.mli +++ b/library/libnames.mli @@ -7,14 +7,13 @@ (************************************************************************) open Util -open Pp open Loc open Names (** {6 Dirpaths } *) (** FIXME: ought to be in Names.dir_path *) -val pr_dirpath : DirPath.t -> Pp.std_ppcmds +val pr_dirpath : DirPath.t -> Pp.t val dirpath_of_string : string -> DirPath.t val string_of_dirpath : DirPath.t -> string @@ -58,7 +57,7 @@ val basename : full_path -> Id.t (** Parsing and printing of section path as ["coq_root.module.id"] *) val path_of_string : string -> full_path val string_of_path : full_path -> string -val pr_path : full_path -> std_ppcmds +val pr_path : full_path -> Pp.t module Spmap : CSig.MapS with type key = full_path @@ -77,7 +76,7 @@ val repr_qualid : qualid -> DirPath.t * Id.t val qualid_eq : qualid -> qualid -> bool -val pr_qualid : qualid -> std_ppcmds +val pr_qualid : qualid -> Pp.t val string_of_qualid : qualid -> string val qualid_of_string : string -> qualid @@ -124,7 +123,7 @@ type reference = val eq_reference : reference -> reference -> bool val qualid_of_reference : reference -> qualid located val string_of_reference : reference -> string -val pr_reference : reference -> std_ppcmds +val pr_reference : reference -> Pp.t val loc_of_reference : reference -> Loc.t option val join_reference : reference -> reference -> reference diff --git a/library/nameops.mli b/library/nameops.mli index 88290f4850..89aba24476 100644 --- a/library/nameops.mli +++ b/library/nameops.mli @@ -106,13 +106,13 @@ val name_max : Name.t -> Name.t -> Name.t val name_cons : Name.t -> Id.t list -> Id.t list (** @deprecated Same as [Name.cons] *) -val pr_name : Name.t -> Pp.std_ppcmds +val pr_name : Name.t -> Pp.t (** @deprecated Same as [Name.print] *) -val pr_id : Id.t -> Pp.std_ppcmds +val pr_id : Id.t -> Pp.t (** @deprecated Same as [Names.Id.print] *) -val pr_lab : Label.t -> Pp.std_ppcmds +val pr_lab : Label.t -> Pp.t (** some preset paths *) @@ -127,5 +127,5 @@ val coq_string : string (** "Coq" *) val default_root_prefix : DirPath.t (** Metavariables *) -val pr_meta : Term.metavariable -> Pp.std_ppcmds +val pr_meta : Term.metavariable -> Pp.t val string_of_meta : Term.metavariable -> string diff --git a/library/nametab.mli b/library/nametab.mli index be57f5dcc6..025a63b1ce 100644 --- a/library/nametab.mli +++ b/library/nametab.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Pp open Names open Libnames open Globnames @@ -155,7 +154,7 @@ val basename_of_global : global_reference -> Id.t (** Printing of global references using names as short as possible. @raise Not_found when the reference is not in the global tables. *) -val pr_global_env : Id.Set.t -> global_reference -> std_ppcmds +val pr_global_env : Id.Set.t -> global_reference -> Pp.t (** The [shortest_qualid] functions given an object with [user_name] diff --git a/parsing/egramcoq.ml b/parsing/egramcoq.ml index d4043f31e0..ec422c58db 100644 --- a/parsing/egramcoq.ml +++ b/parsing/egramcoq.ml @@ -354,7 +354,7 @@ type (_, _) ty_symbol = type ('self, _, 'r) ty_rule = | TyStop : ('self, 'r, 'r) ty_rule | TyNext : ('self, 'a, 'r) ty_rule * ('self, 'b) ty_symbol -> ('self, 'b -> 'a, 'r) ty_rule -| TyMark : int * bool * ('self, 'a, 'r) ty_rule -> ('self, 'a, 'r) ty_rule +| TyMark : int * bool * int * ('self, 'a, 'r) ty_rule -> ('self, 'a, 'r) ty_rule type 'r gen_eval = Loc.t -> 'r env -> 'r @@ -368,18 +368,27 @@ let rec ty_eval : type s a. (s, a, Loc.t -> s) ty_rule -> s gen_eval -> s env -> | TyNext (rem, TyNonTerm (forpat, e, _, true)) -> fun f env v -> ty_eval rem f (push_item forpat e env v) -| TyMark (n, b, rem) -> +| TyMark (n, b, p, rem) -> fun f env -> let heads, constrs = List.chop n env.constrs in - let constrlists = - if b then (heads @ List.hd env.constrlists) :: List.tl env.constrlists - else heads :: env.constrlists + let constrlists, constrs = + if b then + (* We rearrange constrs = c1..cn rem and constrlists = [d1..dr e1..ep] rem' into + constrs = e1..ep rem and constrlists [c1..cn d1..dr] rem' *) + let constrlist = List.hd env.constrlists in + let constrlist, tail = List.chop (List.length constrlist - p) constrlist in + (heads @ constrlist) :: List.tl env.constrlists, tail @ constrs + else + (* We rearrange constrs = c1..cn e1..ep rem into + constrs = e1..ep rem and add a constr list [c1..cn] *) + let constrlist, tail = List.chop (n - p) heads in + constrlist :: env.constrlists, tail @ constrs in ty_eval rem f { env with constrs; constrlists; } let rec ty_erase : type s a r. (s, a, r) ty_rule -> (s, a, r) Extend.rule = function | TyStop -> Stop -| TyMark (_, _, r) -> ty_erase r +| TyMark (_, _, _, r) -> ty_erase r | TyNext (rem, TyTerm tok) -> Next (ty_erase rem, Atoken tok) | TyNext (rem, TyNonTerm (_, _, s, _)) -> Next (ty_erase rem, s) @@ -398,9 +407,9 @@ let make_ty_rule assoc from forpat prods = let s = symbol_of_entry assoc from e in let bind = match var with None -> false | Some _ -> true in AnyTyRule (TyNext (r, TyNonTerm (forpat, e, s, bind))) - | GramConstrListMark (n, b) :: rem -> + | GramConstrListMark (n, b, p) :: rem -> let AnyTyRule r = make_ty_rule rem in - AnyTyRule (TyMark (n, b, r)) + AnyTyRule (TyMark (n, b, p, r)) in make_ty_rule (List.rev prods) diff --git a/plugins/cc/ccalgo.mli b/plugins/cc/ccalgo.mli index e6abf1ccf0..f904aa3e68 100644 --- a/plugins/cc/ccalgo.mli +++ b/plugins/cc/ccalgo.mli @@ -120,7 +120,7 @@ val term_equal : term -> term -> bool val constr_of_term : term -> constr -val debug : (unit -> Pp.std_ppcmds) -> unit +val debug : (unit -> Pp.t) -> unit val forest : state -> forest @@ -169,7 +169,7 @@ val find_instances : state -> (quant_eq * int array) list val execute : bool -> state -> explanation option -val pr_idx_term : forest -> int -> Pp.std_ppcmds +val pr_idx_term : forest -> int -> Pp.t val empty_forest: unit -> forest diff --git a/plugins/extraction/common.mli b/plugins/extraction/common.mli index d6342b59c6..356bad98ba 100644 --- a/plugins/extraction/common.mli +++ b/plugins/extraction/common.mli @@ -9,30 +9,29 @@ open Names open Globnames open Miniml -open Pp (** By default, in module Format, you can do horizontal placing of blocks even if they include newlines, as long as the number of chars in the blocks are less that a line length. To avoid this awkward situation, we attach a big virtual size to [fnl] newlines. *) -val fnl : unit -> std_ppcmds -val fnl2 : unit -> std_ppcmds -val space_if : bool -> std_ppcmds +val fnl : unit -> Pp.t +val fnl2 : unit -> Pp.t +val space_if : bool -> Pp.t -val pp_par : bool -> std_ppcmds -> std_ppcmds +val pp_par : bool -> Pp.t -> Pp.t (** [pp_apply] : a head part applied to arguments, possibly with parenthesis *) -val pp_apply : std_ppcmds -> bool -> std_ppcmds list -> std_ppcmds +val pp_apply : Pp.t -> bool -> Pp.t list -> Pp.t (** Same as [pp_apply], but with also protection of the head by parenthesis *) -val pp_apply2 : std_ppcmds -> bool -> std_ppcmds list -> std_ppcmds +val pp_apply2 : Pp.t -> bool -> Pp.t list -> Pp.t -val pp_tuple_light : (bool -> 'a -> std_ppcmds) -> 'a list -> std_ppcmds -val pp_tuple : ('a -> std_ppcmds) -> 'a list -> std_ppcmds -val pp_boxed_tuple : ('a -> std_ppcmds) -> 'a list -> std_ppcmds +val pp_tuple_light : (bool -> 'a -> Pp.t) -> 'a list -> Pp.t +val pp_tuple : ('a -> Pp.t) -> 'a list -> Pp.t +val pp_boxed_tuple : ('a -> Pp.t) -> 'a list -> Pp.t -val pr_binding : Id.t list -> std_ppcmds +val pr_binding : Id.t list -> Pp.t val rename_id : Id.t -> Id.Set.t -> Id.t @@ -80,4 +79,4 @@ val mk_ind : string -> string -> MutInd.t val is_native_char : ml_ast -> bool val get_native_char : ml_ast -> char -val pp_native_char : ml_ast -> std_ppcmds +val pp_native_char : ml_ast -> Pp.t diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index 7d69cbff1f..89c2a0ae30 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -132,7 +132,7 @@ let rec add_labels mp = function exception Impossible let check_arity env cb = - let t = Typeops.type_of_constant_type env cb.const_type in + let t = cb.const_type in if Reduction.is_arity env t then raise Impossible let check_fix env cb i = @@ -175,26 +175,32 @@ let factor_fix env l cb msb = (hack proposed by Elie) *) -let expand_mexpr env mp me = +let expand_mexpr env mpo me = let inl = Some (Flags.get_inline_level()) in - Mod_typing.translate_mse env (Some mp) inl me + Mod_typing.translate_mse env mpo inl me -(** Ad-hoc update of environment, inspired by [Mod_type.check_with_aux_def]. - To check with Elie. *) - -let rec mp_of_mexpr = function - | MEident mp -> mp - | MEwith (seb,_) -> mp_of_mexpr seb - | _ -> assert false +let expand_modtype env mp me = + let inl = Some (Flags.get_inline_level()) in + Mod_typing.translate_modtype env mp inl ([],me) let no_delta = Mod_subst.empty_delta_resolver -let env_for_mtb_with_def env mp me idl = +let flatten_modtype env mp me_alg struc_opt = + match struc_opt with + | Some me -> me, no_delta + | None -> + let mtb = expand_modtype env mp me_alg in + mtb.mod_type, mtb.mod_delta + +(** Ad-hoc update of environment, inspired by [Mod_typing.check_with_aux_def]. +*) + +let env_for_mtb_with_def env mp me reso idl = let struc = Modops.destr_nofunctor me in let l = Label.of_id (List.hd idl) in let spot = function (l',SFBconst _) -> Label.equal l l' | _ -> false in let before = fst (List.split_when spot struc) in - Modops.add_structure mp before no_delta env + Modops.add_structure mp before reso env let make_cst resolver mp l = Mod_subst.constant_of_delta_kn resolver (KerName.make2 mp l) @@ -234,20 +240,24 @@ let rec extract_structure_spec env mp reso = function [extract_mexpression_spec] should come from a [mod_type_alg] field. This way, any encountered [MEident] should be a true module type. *) -and extract_mexpr_spec env mp1 (me_struct,me_alg) = match me_alg with +and extract_mexpr_spec env mp1 (me_struct_o,me_alg) = match me_alg with | MEident mp -> Visit.add_mp_all mp; MTident mp | MEwith(me',WithDef(idl,(c,ctx)))-> - let env' = env_for_mtb_with_def env (mp_of_mexpr me') me_struct idl in - let mt = extract_mexpr_spec env mp1 (me_struct,me') in + let me_struct,delta = flatten_modtype env mp1 me' me_struct_o in + let env' = env_for_mtb_with_def env mp1 me_struct delta idl in + let mt = extract_mexpr_spec env mp1 (None,me') in (match extract_with_type env' c with (* cb may contain some kn *) | None -> mt - | Some (vl,typ) -> MTwith(mt,ML_With_type(idl,vl,typ))) + | Some (vl,typ) -> + type_iter_references Visit.add_ref typ; + MTwith(mt,ML_With_type(idl,vl,typ))) | MEwith(me',WithMod(idl,mp))-> Visit.add_mp_all mp; - MTwith(extract_mexpr_spec env mp1 (me_struct,me'), ML_With_module(idl,mp)) + MTwith(extract_mexpr_spec env mp1 (None,me'), ML_With_module(idl,mp)) | MEapply _ -> (* No higher-order module type in OCaml : we use the expanded version *) - extract_msignature_spec env mp1 no_delta (*TODO*) me_struct + let me_struct,delta = flatten_modtype env mp1 me_alg me_struct_o in + extract_msignature_spec env mp1 delta me_struct and extract_mexpression_spec env mp1 (me_struct,me_alg) = match me_alg with | MoreFunctor (mbid, mtb, me_alg') -> @@ -258,8 +268,8 @@ and extract_mexpression_spec env mp1 (me_struct,me_alg) = match me_alg with let mp = MPbound mbid in let env' = Modops.add_module_type mp mtb env in MTfunsig (mbid, extract_mbody_spec env mp mtb, - extract_mexpression_spec env' mp1 (me_struct',me_alg')) - | NoFunctor m -> extract_mexpr_spec env mp1 (me_struct,m) + extract_mexpression_spec env' mp1 (me_struct',me_alg')) + | NoFunctor m -> extract_mexpr_spec env mp1 (Some me_struct,m) and extract_msignature_spec env mp1 reso = function | NoFunctor struc -> @@ -335,7 +345,7 @@ and extract_mexpr env mp = function (* In Haskell/Scheme, we expand everything. For now, we also extract everything, dead code will be removed later (see [Modutil.optimize_struct]. *) - let sign,_,delta,_ = expand_mexpr env mp me in + let sign,_,delta,_ = expand_mexpr env (Some mp) me in extract_msignature env mp delta ~all:true sign | MEident mp -> if is_modfile mp && not (modular ()) then error_MPfile_as_mod mp false; @@ -685,3 +695,35 @@ let structure_for_compute c = let struc = optimize_struct (refs,[]) (mono_environment refs []) in let flatstruc = List.map snd (List.flatten (List.map snd struc)) in flatstruc, ast, mlt + +(* For the test-suite : + extraction to a temporary file + run ocamlc on it *) + +let compile f = + try + let args = ["ocamlc";"-I";Filename.dirname f;"-c";f^"i";f] in + let res = CUnix.sys_command (Envars.ocamlfind ()) args in + match res with + | Unix.WEXITED 0 -> () + | Unix.WEXITED n | Unix.WSIGNALED n | Unix.WSTOPPED n -> + CErrors.user_err + Pp.(str "Compilation of file " ++ str f ++ + str " failed with exit code " ++ int n) + with Unix.Unix_error (e,_,_) -> + CErrors.user_err + Pp.(str "Compilation of file " ++ str f ++ + str " failed with error " ++ str (Unix.error_message e)) + +let remove f = + if Sys.file_exists f then Sys.remove f + +let extract_and_compile l = + if lang () != Ocaml then + CErrors.user_err (Pp.str "This command only works with OCaml extraction"); + let f = Filename.temp_file "testextraction" ".ml" in + let () = full_extraction (Some f) l in + let () = compile f in + let () = remove f; remove (f^"i") in + let base = Filename.chop_suffix f ".ml" in + let () = remove (base^".cmo"); remove (base^".cmi") in + Feedback.msg_notice (str "Extracted code successfully compiled") diff --git a/plugins/extraction/extract_env.mli b/plugins/extraction/extract_env.mli index f289b63ad4..5769ff1176 100644 --- a/plugins/extraction/extract_env.mli +++ b/plugins/extraction/extract_env.mli @@ -17,6 +17,10 @@ val full_extraction : string option -> reference list -> unit val separate_extraction : reference list -> unit val extraction_library : bool -> Id.t -> unit +(* For the test-suite : extraction to a temporary file + ocamlc on it *) + +val extract_and_compile : reference list -> unit + (* For debug / external output via coqtop.byte + Drop : *) val mono_environment : @@ -25,7 +29,7 @@ val mono_environment : (* Used by the Relation Extraction plugin *) val print_one_decl : - Miniml.ml_structure -> ModPath.t -> Miniml.ml_decl -> Pp.std_ppcmds + Miniml.ml_structure -> ModPath.t -> Miniml.ml_decl -> Pp.t (* Used by Extraction Compute *) diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index 3661faadab..7644b49ceb 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -295,7 +295,11 @@ let rec extract_type env db j c args = | Ind ((kn,i),u) -> let s = (extract_ind env kn).ind_packets.(i).ip_sign in extract_type_app env db (IndRef (kn,i),s) args - | Case _ | Fix _ | CoFix _ | Proj _ -> Tunknown + | Proj (p,t) -> + (* Let's try to reduce, if it hasn't already been done. *) + if Projection.unfolded p then Tunknown + else extract_type env db j (Term.mkProj (Projection.unfold p, t)) args + | Case _ | Fix _ | CoFix _ -> Tunknown | _ -> assert false (*s Auxiliary function dealing with type application. @@ -518,7 +522,7 @@ and mlt_env env r = match r with match lookup_typedef kn cb with | Some _ as o -> o | None -> - let typ = Typeops.type_of_constant_type env cb.const_type + let typ = cb.const_type (* FIXME not sure if we should instantiate univs here *) in match flag_of_type env typ with | Info,TypeScheme -> @@ -543,7 +547,7 @@ let record_constant_type env kn opt_typ = | Some schema -> schema | None -> let typ = match opt_typ with - | None -> Typeops.type_of_constant_type env cb.const_type + | None -> cb.const_type | Some typ -> typ in let mlt = extract_type env [] 1 typ [] in @@ -969,7 +973,7 @@ let extract_fixpoint env vkn (fi,ti,ci) = let extract_constant env kn cb = let r = ConstRef kn in - let typ = Typeops.type_of_constant_type env cb.const_type in + let typ = cb.const_type in let warn_info () = if not (is_custom r) then add_info_axiom r in let warn_log () = if not (constant_has_body cb) then add_log_axiom r in @@ -1025,7 +1029,7 @@ let extract_constant env kn cb = let extract_constant_spec env kn cb = let r = ConstRef kn in - let typ = Typeops.type_of_constant_type env cb.const_type in + let typ = cb.const_type in try match flag_of_type env typ with | (Logic, TypeScheme) -> Stype (r, [], Some (Tdummy Ktype)) diff --git a/plugins/extraction/g_extraction.ml4 b/plugins/extraction/g_extraction.ml4 index 4372ea557b..23452febdc 100644 --- a/plugins/extraction/g_extraction.ml4 +++ b/plugins/extraction/g_extraction.ml4 @@ -8,7 +8,7 @@ (*i camlp4deps: "grammar/grammar.cma" i*) -open Grammar_API.Pcoq.Prim +open Pcoq.Prim DECLARE PLUGIN "extraction_plugin" @@ -65,6 +65,10 @@ VERNAC COMMAND EXTEND Extraction CLASSIFIED AS QUERY (* Monolithic extraction to a file *) | [ "Extraction" string(f) ne_global_list(l) ] -> [ full_extraction (Some f) l ] + +(* Extraction to a temporary file and OCaml compilation *) +| [ "Extraction" "TestCompile" ne_global_list(l) ] + -> [ extract_and_compile l ] END VERNAC COMMAND EXTEND SeparateExtraction CLASSIFIED AS QUERY diff --git a/plugins/extraction/miniml.mli b/plugins/extraction/miniml.mli index be8282da06..edebba49df 100644 --- a/plugins/extraction/miniml.mli +++ b/plugins/extraction/miniml.mli @@ -8,7 +8,6 @@ (*s Target language for extraction: a core ML called MiniML. *) -open Pp open Names open Globnames @@ -205,19 +204,19 @@ type language_descr = { file_naming : ModPath.t -> string; (* the second argument is a comment to add to the preamble *) preamble : - Id.t -> std_ppcmds option -> ModPath.t list -> unsafe_needs -> - std_ppcmds; - pp_struct : ml_structure -> std_ppcmds; + Id.t -> Pp.t option -> ModPath.t list -> unsafe_needs -> + Pp.t; + pp_struct : ml_structure -> Pp.t; (* Concerning a possible interface file *) sig_suffix : string option; (* the second argument is a comment to add to the preamble *) sig_preamble : - Id.t -> std_ppcmds option -> ModPath.t list -> unsafe_needs -> - std_ppcmds; - pp_sig : ml_signature -> std_ppcmds; + Id.t -> Pp.t option -> ModPath.t list -> unsafe_needs -> + Pp.t; + pp_sig : ml_signature -> Pp.t; (* for an isolated declaration print *) - pp_decl : ml_decl -> std_ppcmds; + pp_decl : ml_decl -> Pp.t; } diff --git a/plugins/extraction/mlutil.ml b/plugins/extraction/mlutil.ml index f1bcde2f3f..a4c2bcd883 100644 --- a/plugins/extraction/mlutil.ml +++ b/plugins/extraction/mlutil.ml @@ -120,7 +120,6 @@ let rec mgu = function mgu (a, a'); mgu (b, b') | Tglob (r,l), Tglob (r',l') when Globnames.eq_gr r r' -> List.iter mgu (List.combine l l') - | (Tdummy _, _ | _, Tdummy _) when lang() == Haskell -> () | Tdummy _, Tdummy _ -> () | Tvar i, Tvar j when Int.equal i j -> () | Tvar' i, Tvar' j when Int.equal i j -> () @@ -1052,6 +1051,7 @@ let rec simpl o = function | MLmagic(MLcase(typ,e,br)) -> let br' = Array.map (fun (ids,p,c) -> (ids,p,MLmagic c)) br in simpl o (MLcase(typ,e,br')) + | MLmagic(MLdummy _ as e) when lang () == Haskell -> e | MLmagic(MLexn _ as e) -> e | a -> ast_map (simpl o) a diff --git a/plugins/extraction/modutil.ml b/plugins/extraction/modutil.ml index a896a8d037..1e0c331901 100644 --- a/plugins/extraction/modutil.ml +++ b/plugins/extraction/modutil.ml @@ -17,10 +17,15 @@ open Mlutil (*S Functions upon ML modules. *) +(** Note: a syntax like [(F M) with ...] is actually legal, see for instance + bug #4720. Hence the code below tries to handle [MTsig], maybe not in + a perfect way, but that should be enough for the use of [se_iter] below. *) + let rec msid_of_mt = function | MTident mp -> mp + | MTsig(mp,_) -> mp | MTwith(mt,_)-> msid_of_mt mt - | _ -> anomaly ~label:"extraction" (Pp.str "the With operator isn't applied to a name.") + | MTfunsig _ -> assert false (* A functor cannot be inside a MTwith *) (*s Apply some functions upon all [ml_decl] and [ml_spec] found in a [ml_structure]. *) @@ -36,7 +41,7 @@ let se_iter do_decl do_spec do_mp = List.fold_left (fun mp l -> MPdot(mp,Label.of_id l)) mp_mt idl' in let r = ConstRef (Constant.make2 mp_w (Label.of_id l')) in - mt_iter mt; do_decl (Dtype(r,l,t)) + mt_iter mt; do_spec (Stype(r,l,Some t)) | MTwith (mt,ML_With_module(idl,mp))-> let mp_mt = msid_of_mt mt in let mp_w = diff --git a/plugins/extraction/modutil.mli b/plugins/extraction/modutil.mli index ad60b58d5d..17a6e8db6f 100644 --- a/plugins/extraction/modutil.mli +++ b/plugins/extraction/modutil.mli @@ -17,6 +17,7 @@ val struct_type_search : (ml_type -> bool) -> ml_structure -> bool type do_ref = global_reference -> unit +val type_iter_references : do_ref -> ml_type -> unit val ast_iter_references : do_ref -> do_ref -> do_ref -> ml_ast -> unit val decl_iter_references : do_ref -> do_ref -> do_ref -> ml_decl -> unit val spec_iter_references : do_ref -> do_ref -> do_ref -> ml_spec -> unit diff --git a/plugins/extraction/table.mli b/plugins/extraction/table.mli index 2b3007f025..7e47d0bc81 100644 --- a/plugins/extraction/table.mli +++ b/plugins/extraction/table.mli @@ -191,7 +191,7 @@ val find_custom_match : ml_branch array -> string val extraction_language : lang -> unit val extraction_inline : bool -> reference list -> unit -val print_extraction_inline : unit -> Pp.std_ppcmds +val print_extraction_inline : unit -> Pp.t val reset_extraction_inline : unit -> unit val extract_constant_inline : bool -> reference -> string list -> string -> unit @@ -206,7 +206,7 @@ val extraction_implicit : reference -> int_or_id list -> unit val extraction_blacklist : Id.t list -> unit val reset_extraction_blacklist : unit -> unit -val print_extraction_blacklist : unit -> Pp.std_ppcmds +val print_extraction_blacklist : unit -> Pp.t diff --git a/plugins/firstorder/g_ground.ml4 b/plugins/firstorder/g_ground.ml4 index c001ee3829..1e7da3250b 100644 --- a/plugins/firstorder/g_ground.ml4 +++ b/plugins/firstorder/g_ground.ml4 @@ -8,7 +8,6 @@ (*i camlp4deps: "grammar/grammar.cma" i*) -open Grammar_API open Ltac_plugin open Formula open Sequent diff --git a/plugins/firstorder/sequent.mli b/plugins/firstorder/sequent.mli index 0a2e84bb83..ca6079c8b0 100644 --- a/plugins/firstorder/sequent.mli +++ b/plugins/firstorder/sequent.mli @@ -57,4 +57,4 @@ val extend_with_ref_list : Environ.env -> Evd.evar_map -> global_reference list val extend_with_auto_hints : Environ.env -> Evd.evar_map -> Hints.hint_db_name list -> t -> t * Evd.evar_map -val print_cmap: global_reference list CM.t -> Pp.std_ppcmds +val print_cmap: global_reference list CM.t -> Pp.t diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 15ab396e31..5f6d783598 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -821,8 +821,9 @@ let build_proof | Fix _ | CoFix _ -> user_err Pp.(str ( "Anonymous local (co)fixpoints are not handled yet")) + | Proj _ -> user_err Pp.(str "Prod") - | Prod _ -> user_err Pp.(str "Prod") + | Prod _ -> do_finalize dyn_infos g | LetIn _ -> let new_infos = { dyn_infos with diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4 index c495703eeb..16d9f200f3 100644 --- a/plugins/funind/g_indfun.ml4 +++ b/plugins/funind/g_indfun.ml4 @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) (*i camlp4deps: "grammar/grammar.cma" i*) -open Grammar_API open Ltac_plugin open Util open Pp diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 379c83b245..8555a0b226 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -32,6 +32,14 @@ type binder_type = type glob_context = (binder_type*glob_constr) list + +let rec solve_trivial_holes pat_as_term e = + match pat_as_term.CAst.v,e.CAst.v with + | GHole _,_ -> e + | GApp(fp,argsp),GApp(fe,argse) when glob_constr_eq fp fe -> + CAst.make (GApp((solve_trivial_holes fp fe),List.map2 solve_trivial_holes argsp argse)) + | _,_ -> pat_as_term + (* compose_glob_context [(bt_1,n_1,t_1);......] rt returns b_1(n_1,t_1,.....,bn(n_k,t_k,rt)) where the b_i's are the @@ -226,7 +234,12 @@ let combine_lam n t b = compose_glob_context b.context b.value ) } - +let combine_prod2 n t b = + { + context = []; + value = mkGProd(n, compose_glob_context t.context t.value, + compose_glob_context b.context b.value ) + } let combine_prod n t b = { context = t.context@((Prod n,t.value)::b.context); value = b.value} @@ -604,7 +617,9 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = let t_res = build_entry_lc env funnames avoid t in let new_env = raw_push_named (n,None,t) env in let b_res = build_entry_lc new_env funnames avoid b in - combine_results (combine_prod n) t_res b_res + if List.length t_res.result = 1 && List.length b_res.result = 1 + then combine_results (combine_prod2 n) t_res b_res + else combine_results (combine_prod n) t_res b_res | GLetIn(n,v,typ,b) -> (* we first compute the list of constructor corresponding to the body of the function, @@ -806,6 +821,12 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve let typ_as_constr = EConstr.of_constr typ_as_constr in let typ = Detyping.detype false [] new_env (Evd.from_env env) typ_as_constr in let pat_as_term = pattern_to_term pat in + (* removing trivial holes *) + let pat_as_term = solve_trivial_holes pat_as_term e in + (* observe (str "those_pattern_preconds" ++ spc () ++ *) + (* str "pat" ++ spc () ++ pr_glob_constr pat_as_term ++ spc ()++ *) + (* str "e" ++ spc () ++ pr_glob_constr e ++spc ()++ *) + (* str "typ_as_constr" ++ spc () ++ pr_lconstr typ_as_constr); *) List.fold_right (fun id acc -> if Id.Set.mem id this_pat_ids diff --git a/plugins/funind/glob_termops.ml b/plugins/funind/glob_termops.ml index 7cb35838c7..003bb4e30d 100644 --- a/plugins/funind/glob_termops.ml +++ b/plugins/funind/glob_termops.ml @@ -708,9 +708,6 @@ let expand_as = in expand_as Id.Map.empty - - - (* [resolve_and_replace_implicits ?expected_type env sigma rt] solves implicits of [rt] w.r.t. [env] and [sigma] and then replace them by their solution *) @@ -749,6 +746,30 @@ If someone knows how to prevent solved existantial removal in understand, pleas Detyping.detype false [] env ctx (EConstr.of_constr (f c)) | Evar_empty -> rt (* the hole was not solved : we do nothing *) ) + | (GHole(BinderType na,_,_)) -> (* we only want to deal with implicit arguments *) + ( + let res = + try (* we scan the new evar map to find the evar corresponding to this hole (by looking the source *) + Evd.fold (* to simulate an iter *) + (fun _ evi _ -> + match evi.evar_source with + | (loc_evi,BinderType na') -> + if Name.equal na na' && rt.CAst.loc = loc_evi then raise (Found evi) + | _ -> () + ) + ctx + (); + (* the hole was not solved : we do nothing *) + rt + with Found evi -> (* we found the evar corresponding to this hole *) + match evi.evar_body with + | Evar_defined c -> + (* we just have to lift the solution in glob_term *) + Detyping.detype false [] env ctx (EConstr.of_constr (f c)) + | Evar_empty -> rt (* the hole was not solved : we d when falseo nothing *) + in + res + ) | _ -> Glob_ops.map_glob_constr change rt in change rt diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 863c9dc8d5..89537ad3f6 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -857,7 +857,7 @@ let make_graph (f_ref:global_reference) = with_full_print (fun () -> (Constrextern.extern_constr false env sigma body, Constrextern.extern_type false env sigma - ((*FIXME*) Typeops.type_of_constant_type env c_body.const_type) + ((*FIXME*) c_body.const_type) ) ) () diff --git a/plugins/funind/indfun.mli b/plugins/funind/indfun.mli index 7a60da44fb..93e03852ec 100644 --- a/plugins/funind/indfun.mli +++ b/plugins/funind/indfun.mli @@ -1,8 +1,8 @@ open Misctypes -val warn_cannot_define_graph : ?loc:Loc.t -> Pp.std_ppcmds * Pp.std_ppcmds -> unit +val warn_cannot_define_graph : ?loc:Loc.t -> Pp.t * Pp.t -> unit -val warn_cannot_define_principle : ?loc:Loc.t -> Pp.std_ppcmds * Pp.std_ppcmds -> unit +val warn_cannot_define_principle : ?loc:Loc.t -> Pp.t * Pp.t -> unit val do_generate_principle : bool -> diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli index 5e425cd18a..2e2ced790e 100644 --- a/plugins/funind/indfun_common.mli +++ b/plugins/funind/indfun_common.mli @@ -1,5 +1,4 @@ open Names -open Pp (* The mk_?_id function build different name w.r.t. a function @@ -11,7 +10,7 @@ val mk_complete_id : Id.t -> Id.t val mk_equation_id : Id.t -> Id.t -val msgnl : std_ppcmds -> unit +val msgnl : Pp.t -> unit val fresh_id : Id.t list -> string -> Id.t val fresh_name : Id.t list -> string -> Name.t @@ -24,7 +23,7 @@ val id_of_name : Name.t -> Id.t val locate_ind : Libnames.reference -> inductive val locate_constant : Libnames.reference -> Constant.t val locate_with_msg : - Pp.std_ppcmds -> (Libnames.reference -> 'a) -> + Pp.t -> (Libnames.reference -> 'a) -> Libnames.reference -> 'a val filter_map : ('a -> bool) -> ('a -> 'b) -> 'a list -> 'b list @@ -89,8 +88,8 @@ val update_Function : function_info -> unit (** debugging *) -val pr_info : function_info -> Pp.std_ppcmds -val pr_table : unit -> Pp.std_ppcmds +val pr_info : function_info -> Pp.t +val pr_table : unit -> Pp.t (* val function_debug : bool ref *) diff --git a/plugins/ltac/extraargs.ml4 b/plugins/ltac/extraargs.ml4 index 72c6f90900..6097951330 100644 --- a/plugins/ltac/extraargs.ml4 +++ b/plugins/ltac/extraargs.ml4 @@ -8,7 +8,6 @@ (*i camlp4deps: "grammar/grammar.cma" i*) -open Grammar_API open Pp open Genarg open Stdarg diff --git a/plugins/ltac/extraargs.mli b/plugins/ltac/extraargs.mli index 419c5e8c45..b06f35ddc4 100644 --- a/plugins/ltac/extraargs.mli +++ b/plugins/ltac/extraargs.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Grammar_API open Tacexpr open Names open Constrexpr @@ -15,13 +14,13 @@ open Misctypes val wit_orient : bool Genarg.uniform_genarg_type val orient : bool Pcoq.Gram.entry -val pr_orient : bool -> Pp.std_ppcmds +val pr_orient : bool -> Pp.t val wit_rename : (Id.t * Id.t) Genarg.uniform_genarg_type val occurrences : (int list or_var) Pcoq.Gram.entry val wit_occurrences : (int list or_var, int list or_var, int list) Genarg.genarg_type -val pr_occurrences : int list or_var -> Pp.std_ppcmds +val pr_occurrences : int list or_var -> Pp.t val occurrences_of : int list -> Locus.occurrences val wit_natural : int Genarg.uniform_genarg_type @@ -56,7 +55,7 @@ type place = Id.t gen_place val wit_hloc : (loc_place, loc_place, place) Genarg.genarg_type val hloc : loc_place Pcoq.Gram.entry -val pr_hloc : loc_place -> Pp.std_ppcmds +val pr_hloc : loc_place -> Pp.t val by_arg_tac : Tacexpr.raw_tactic_expr option Pcoq.Gram.entry val wit_by_arg_tac : @@ -65,8 +64,8 @@ val wit_by_arg_tac : Geninterp.Val.t option) Genarg.genarg_type val pr_by_arg_tac : - (int * Ppextend.parenRelation -> raw_tactic_expr -> Pp.std_ppcmds) -> - raw_tactic_expr option -> Pp.std_ppcmds + (int * Ppextend.parenRelation -> raw_tactic_expr -> Pp.t) -> + raw_tactic_expr option -> Pp.t val test_lpar_id_colon : unit Pcoq.Gram.entry diff --git a/plugins/ltac/extratactics.ml4 b/plugins/ltac/extratactics.ml4 index 6d80ab5494..f3f2f27e9e 100644 --- a/plugins/ltac/extratactics.ml4 +++ b/plugins/ltac/extratactics.ml4 @@ -8,7 +8,6 @@ (*i camlp4deps: "grammar/grammar.cma" i*) -open Grammar_API open Pp open Genarg open Stdarg diff --git a/plugins/ltac/g_auto.ml4 b/plugins/ltac/g_auto.ml4 index 4d13d89a49..301943a509 100644 --- a/plugins/ltac/g_auto.ml4 +++ b/plugins/ltac/g_auto.ml4 @@ -8,7 +8,6 @@ (*i camlp4deps: "grammar/grammar.cma" i*) -open Grammar_API open Pp open Genarg open Stdarg diff --git a/plugins/ltac/g_ltac.ml4 b/plugins/ltac/g_ltac.ml4 index cc052c8a20..2ea0f60ebc 100644 --- a/plugins/ltac/g_ltac.ml4 +++ b/plugins/ltac/g_ltac.ml4 @@ -8,8 +8,6 @@ (*i camlp4deps: "grammar/grammar.cma" i*) -open Grammar_API - DECLARE PLUGIN "ltac_plugin" open Util diff --git a/plugins/ltac/g_obligations.ml4 b/plugins/ltac/g_obligations.ml4 index 1935d560a4..1a2d895868 100644 --- a/plugins/ltac/g_obligations.ml4 +++ b/plugins/ltac/g_obligations.ml4 @@ -12,7 +12,6 @@ Syntax for the subtac terms and types. Elaborated from correctness/psyntax.ml4 by Jean-Christophe Filliโtre *) -open Grammar_API open Libnames open Constrexpr open Constrexpr_ops diff --git a/plugins/ltac/g_rewrite.ml4 b/plugins/ltac/g_rewrite.ml4 index 3c27b27475..c874f8d5a3 100644 --- a/plugins/ltac/g_rewrite.ml4 +++ b/plugins/ltac/g_rewrite.ml4 @@ -10,7 +10,6 @@ (* Syntax for rewriting with strategies *) -open Grammar_API open Names open Misctypes open Locus diff --git a/plugins/ltac/g_tactic.ml4 b/plugins/ltac/g_tactic.ml4 index e539b58674..d792d4ff7d 100644 --- a/plugins/ltac/g_tactic.ml4 +++ b/plugins/ltac/g_tactic.ml4 @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Grammar_API open Pp open CErrors open Util diff --git a/plugins/ltac/pltac.ml b/plugins/ltac/pltac.ml index 2adcf02e69..2c1b1067ea 100644 --- a/plugins/ltac/pltac.ml +++ b/plugins/ltac/pltac.ml @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Grammar_API open Pcoq (* Main entry for extensions *) diff --git a/plugins/ltac/pltac.mli b/plugins/ltac/pltac.mli index 794cb527f3..048dcc8e92 100644 --- a/plugins/ltac/pltac.mli +++ b/plugins/ltac/pltac.mli @@ -8,7 +8,6 @@ (** Ltac parsing entries *) -open Grammar_API open Loc open Names open Pcoq diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index 327b347ec0..140cc33440 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -67,22 +67,22 @@ let declare_notation_tactic_pprule kn pt = prnotation_tab := KNmap.add kn pt !prnotation_tab type 'a raw_extra_genarg_printer = - (constr_expr -> std_ppcmds) -> - (constr_expr -> std_ppcmds) -> - (tolerability -> raw_tactic_expr -> std_ppcmds) -> - 'a -> std_ppcmds + (constr_expr -> Pp.t) -> + (constr_expr -> Pp.t) -> + (tolerability -> raw_tactic_expr -> Pp.t) -> + 'a -> Pp.t type 'a glob_extra_genarg_printer = - (glob_constr_and_expr -> std_ppcmds) -> - (glob_constr_and_expr -> std_ppcmds) -> - (tolerability -> glob_tactic_expr -> std_ppcmds) -> - 'a -> std_ppcmds + (glob_constr_and_expr -> Pp.t) -> + (glob_constr_and_expr -> Pp.t) -> + (tolerability -> glob_tactic_expr -> Pp.t) -> + 'a -> Pp.t type 'a extra_genarg_printer = - (EConstr.constr -> std_ppcmds) -> - (EConstr.constr -> std_ppcmds) -> - (tolerability -> Val.t -> std_ppcmds) -> - 'a -> std_ppcmds + (EConstr.constr -> Pp.t) -> + (EConstr.constr -> Pp.t) -> + (tolerability -> Val.t -> Pp.t) -> + 'a -> Pp.t let keyword x = tag_keyword (str x) let primitive x = tag_primitive (str x) @@ -96,7 +96,7 @@ type 'a extra_genarg_printer = | None -> assert false | Some Refl -> x - let rec pr_value lev v : std_ppcmds = + let rec pr_value lev v : Pp.t = if has_type v Val.typ_list then pr_sequence (fun x -> pr_value lev x) (unbox v Val.typ_list) else if has_type v Val.typ_opt then @@ -272,7 +272,7 @@ type 'a extra_genarg_printer = | Glbwit (OptArg wit) -> Some (Option.map (in_gen (glbwit wit)) arg) | _ -> None - let rec pr_any_arg : type l. (_ -> l generic_argument -> std_ppcmds) -> _ -> l generic_argument -> std_ppcmds = + let rec pr_any_arg : type l. (_ -> l generic_argument -> Pp.t) -> _ -> l generic_argument -> Pp.t = fun prtac symb arg -> match symb with | Extend.Uentry tag when is_genarg tag (genarg_tag arg) -> prtac (1, Any) arg | Extend.Ulist1 s | Extend.Ulist0 s -> @@ -599,18 +599,18 @@ type 'a extra_genarg_printer = "raw", "glob" and "typed" levels *) type 'a printer = { - pr_tactic : tolerability -> 'tacexpr -> std_ppcmds; - pr_constr : 'trm -> std_ppcmds; - pr_lconstr : 'trm -> std_ppcmds; - pr_dconstr : 'dtrm -> std_ppcmds; - pr_pattern : 'pat -> std_ppcmds; - pr_lpattern : 'pat -> std_ppcmds; - pr_constant : 'cst -> std_ppcmds; - pr_reference : 'ref -> std_ppcmds; - pr_name : 'nam -> std_ppcmds; - pr_generic : 'lev generic_argument -> std_ppcmds; - pr_extend : int -> ml_tactic_entry -> 'a gen_tactic_arg list -> std_ppcmds; - pr_alias : int -> KerName.t -> 'a gen_tactic_arg list -> std_ppcmds; + pr_tactic : tolerability -> 'tacexpr -> Pp.t; + pr_constr : 'trm -> Pp.t; + pr_lconstr : 'trm -> Pp.t; + pr_dconstr : 'dtrm -> Pp.t; + pr_pattern : 'pat -> Pp.t; + pr_lpattern : 'pat -> Pp.t; + pr_constant : 'cst -> Pp.t; + pr_reference : 'ref -> Pp.t; + pr_name : 'nam -> Pp.t; + pr_generic : 'lev generic_argument -> Pp.t; + pr_extend : int -> ml_tactic_entry -> 'a gen_tactic_arg list -> Pp.t; + pr_alias : int -> KerName.t -> 'a gen_tactic_arg list -> Pp.t; } constraint 'a = < diff --git a/plugins/ltac/pptactic.mli b/plugins/ltac/pptactic.mli index 1127c98319..0bf9bc7f62 100644 --- a/plugins/ltac/pptactic.mli +++ b/plugins/ltac/pptactic.mli @@ -9,7 +9,6 @@ (** This module implements pretty-printers for tactic_expr syntactic objects and their subcomponents. *) -open Pp open Genarg open Geninterp open Names @@ -24,22 +23,22 @@ type 'a grammar_tactic_prod_item_expr = | TacNonTerm of ('a * Names.Id.t option) Loc.located type 'a raw_extra_genarg_printer = - (constr_expr -> std_ppcmds) -> - (constr_expr -> std_ppcmds) -> - (tolerability -> raw_tactic_expr -> std_ppcmds) -> - 'a -> std_ppcmds + (constr_expr -> Pp.t) -> + (constr_expr -> Pp.t) -> + (tolerability -> raw_tactic_expr -> Pp.t) -> + 'a -> Pp.t type 'a glob_extra_genarg_printer = - (glob_constr_and_expr -> std_ppcmds) -> - (glob_constr_and_expr -> std_ppcmds) -> - (tolerability -> glob_tactic_expr -> std_ppcmds) -> - 'a -> std_ppcmds + (glob_constr_and_expr -> Pp.t) -> + (glob_constr_and_expr -> Pp.t) -> + (tolerability -> glob_tactic_expr -> Pp.t) -> + 'a -> Pp.t type 'a extra_genarg_printer = - (EConstr.t -> std_ppcmds) -> - (EConstr.t -> std_ppcmds) -> - (tolerability -> Val.t -> std_ppcmds) -> - 'a -> std_ppcmds + (EConstr.t -> Pp.t) -> + (EConstr.t -> Pp.t) -> + (tolerability -> Val.t -> Pp.t) -> + 'a -> Pp.t val declare_extra_genarg_pprule : ('a, 'b, 'c) genarg_type -> @@ -57,61 +56,61 @@ type pp_tactic = { val declare_notation_tactic_pprule : KerName.t -> pp_tactic -> unit val pr_with_occurrences : - ('a -> std_ppcmds) -> 'a Locus.with_occurrences -> std_ppcmds + ('a -> Pp.t) -> 'a Locus.with_occurrences -> Pp.t val pr_red_expr : - ('a -> std_ppcmds) * ('a -> std_ppcmds) * ('b -> std_ppcmds) * ('c -> std_ppcmds) -> - ('a,'b,'c) Genredexpr.red_expr_gen -> std_ppcmds + ('a -> Pp.t) * ('a -> Pp.t) * ('b -> Pp.t) * ('c -> Pp.t) -> + ('a,'b,'c) Genredexpr.red_expr_gen -> Pp.t val pr_may_eval : - ('a -> std_ppcmds) -> ('a -> std_ppcmds) -> ('b -> std_ppcmds) -> - ('c -> std_ppcmds) -> ('a,'b,'c) Genredexpr.may_eval -> std_ppcmds + ('a -> Pp.t) -> ('a -> Pp.t) -> ('b -> Pp.t) -> + ('c -> Pp.t) -> ('a,'b,'c) Genredexpr.may_eval -> Pp.t -val pr_and_short_name : ('a -> std_ppcmds) -> 'a and_short_name -> std_ppcmds -val pr_or_by_notation : ('a -> std_ppcmds) -> 'a or_by_notation -> std_ppcmds +val pr_and_short_name : ('a -> Pp.t) -> 'a and_short_name -> Pp.t +val pr_or_by_notation : ('a -> Pp.t) -> 'a or_by_notation -> Pp.t val pr_in_clause : - ('a -> Pp.std_ppcmds) -> 'a Locus.clause_expr -> Pp.std_ppcmds + ('a -> Pp.t) -> 'a Locus.clause_expr -> Pp.t val pr_clauses : bool option -> - ('a -> Pp.std_ppcmds) -> 'a Locus.clause_expr -> Pp.std_ppcmds + ('a -> Pp.t) -> 'a Locus.clause_expr -> Pp.t -val pr_raw_generic : env -> rlevel generic_argument -> std_ppcmds +val pr_raw_generic : env -> rlevel generic_argument -> Pp.t -val pr_glb_generic : env -> glevel generic_argument -> std_ppcmds +val pr_glb_generic : env -> glevel generic_argument -> Pp.t val pr_raw_extend: env -> int -> - ml_tactic_entry -> raw_tactic_arg list -> std_ppcmds + ml_tactic_entry -> raw_tactic_arg list -> Pp.t val pr_glob_extend: env -> int -> - ml_tactic_entry -> glob_tactic_arg list -> std_ppcmds + ml_tactic_entry -> glob_tactic_arg list -> Pp.t val pr_extend : - (Val.t -> std_ppcmds) -> int -> ml_tactic_entry -> Val.t list -> std_ppcmds + (Val.t -> Pp.t) -> int -> ml_tactic_entry -> Val.t list -> Pp.t -val pr_alias_key : Names.KerName.t -> std_ppcmds +val pr_alias_key : Names.KerName.t -> Pp.t -val pr_alias : (Val.t -> std_ppcmds) -> - int -> Names.KerName.t -> Val.t list -> std_ppcmds +val pr_alias : (Val.t -> Pp.t) -> + int -> Names.KerName.t -> Val.t list -> Pp.t -val pr_ltac_constant : Nametab.ltac_constant -> std_ppcmds +val pr_ltac_constant : Nametab.ltac_constant -> Pp.t -val pr_raw_tactic : raw_tactic_expr -> std_ppcmds +val pr_raw_tactic : raw_tactic_expr -> Pp.t -val pr_raw_tactic_level : tolerability -> raw_tactic_expr -> std_ppcmds +val pr_raw_tactic_level : tolerability -> raw_tactic_expr -> Pp.t -val pr_glob_tactic : env -> glob_tactic_expr -> std_ppcmds +val pr_glob_tactic : env -> glob_tactic_expr -> Pp.t -val pr_atomic_tactic : env -> Evd.evar_map -> atomic_tactic_expr -> std_ppcmds +val pr_atomic_tactic : env -> Evd.evar_map -> atomic_tactic_expr -> Pp.t -val pr_hintbases : string list option -> std_ppcmds +val pr_hintbases : string list option -> Pp.t -val pr_auto_using : ('constr -> std_ppcmds) -> 'constr list -> std_ppcmds +val pr_auto_using : ('constr -> Pp.t) -> 'constr list -> Pp.t -val pr_match_pattern : ('a -> std_ppcmds) -> 'a match_pattern -> std_ppcmds +val pr_match_pattern : ('a -> Pp.t) -> 'a match_pattern -> Pp.t -val pr_match_rule : bool -> ('a -> std_ppcmds) -> ('b -> std_ppcmds) -> - ('b, 'a) match_rule -> std_ppcmds +val pr_match_rule : bool -> ('a -> Pp.t) -> ('b -> Pp.t) -> + ('b, 'a) match_rule -> Pp.t -val pr_value : tolerability -> Val.t -> std_ppcmds +val pr_value : tolerability -> Val.t -> Pp.t val ltop : tolerability diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index bbd7834d58..75b665aad9 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -1461,7 +1461,7 @@ let solve_constraints env (evars,cstrs) = let nf_zeta = Reductionops.clos_norm_flags (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) -exception RewriteFailure of Pp.std_ppcmds +exception RewriteFailure of Pp.t type result = (evar_map * constr option * types) option option diff --git a/plugins/ltac/rewrite.mli b/plugins/ltac/rewrite.mli index 35205ac58a..23767c12f5 100644 --- a/plugins/ltac/rewrite.mli +++ b/plugins/ltac/rewrite.mli @@ -61,8 +61,8 @@ val strategy_of_ast : (glob_constr_and_expr, raw_red_expr) strategy_ast -> strat val map_strategy : ('a -> 'b) -> ('c -> 'd) -> ('a, 'c) strategy_ast -> ('b, 'd) strategy_ast -val pr_strategy : ('a -> Pp.std_ppcmds) -> ('b -> Pp.std_ppcmds) -> - ('a, 'b) strategy_ast -> Pp.std_ppcmds +val pr_strategy : ('a -> Pp.t) -> ('b -> Pp.t) -> + ('a, 'b) strategy_ast -> Pp.t (** Entry point for user-level "rewrite_strat" *) val cl_rewrite_clause_strat : strategy -> Id.t option -> unit Proofview.tactic diff --git a/plugins/ltac/tacentries.ml b/plugins/ltac/tacentries.ml index 791b7f48db..cf676f598f 100644 --- a/plugins/ltac/tacentries.ml +++ b/plugins/ltac/tacentries.ml @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Grammar_API open Pp open CErrors open Util diff --git a/plugins/ltac/tacentries.mli b/plugins/ltac/tacentries.mli index ccd44b914e..aa8f4efe65 100644 --- a/plugins/ltac/tacentries.mli +++ b/plugins/ltac/tacentries.mli @@ -8,7 +8,6 @@ (** Ltac toplevel command entries. *) -open Grammar_API open Vernacexpr open Tacexpr diff --git a/plugins/ltac/tacintern.ml b/plugins/ltac/tacintern.ml index df03c7b472..0554d43641 100644 --- a/plugins/ltac/tacintern.ml +++ b/plugins/ltac/tacintern.ml @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Grammar_API open Pattern open Pp open Genredexpr diff --git a/plugins/ltac/tacintern.mli b/plugins/ltac/tacintern.mli index ad2e709085..e3a4d5c798 100644 --- a/plugins/ltac/tacintern.mli +++ b/plugins/ltac/tacintern.mli @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Grammar_API -open Pp open Names open Tacexpr open Genarg @@ -56,7 +54,7 @@ val intern_hyp : glob_sign -> Id.t Loc.located -> Id.t Loc.located val intern_genarg : glob_sign -> raw_generic_argument -> glob_generic_argument (** printing *) -val print_ltac : Libnames.qualid -> std_ppcmds +val print_ltac : Libnames.qualid -> Pp.t (** Reduction expressions *) diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index 7b054947b7..d3e625e73a 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Grammar_API open Constrintern open Patternops open Pp @@ -2001,7 +2000,7 @@ let lift f = (); fun ist x -> Ftactic.enter begin fun gl -> Ftactic.return (f ist env sigma x) end -let lifts f = (); fun ist x -> Ftactic.nf_enter begin fun gl -> +let lifts f = (); fun ist x -> Ftactic.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let (sigma, v) = f ist env sigma x in diff --git a/plugins/ltac/tacsubst.ml b/plugins/ltac/tacsubst.ml index c1ca854334..180fb2db40 100644 --- a/plugins/ltac/tacsubst.ml +++ b/plugins/ltac/tacsubst.ml @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Grammar_API open Util open Tacexpr open Mod_subst diff --git a/plugins/ltac/tactic_debug.mli b/plugins/ltac/tactic_debug.mli index ef6362270a..2475e41f9d 100644 --- a/plugins/ltac/tactic_debug.mli +++ b/plugins/ltac/tactic_debug.mli @@ -58,16 +58,16 @@ val db_hyp_pattern_failure : val db_matching_failure : debug_info -> unit Proofview.NonLogical.t (** Prints an evaluation failure message for a rule *) -val db_eval_failure : debug_info -> Pp.std_ppcmds -> unit Proofview.NonLogical.t +val db_eval_failure : debug_info -> Pp.t -> unit Proofview.NonLogical.t (** An exception handler *) -val explain_logic_error: exn -> Pp.std_ppcmds +val explain_logic_error: exn -> Pp.t (** For use in the Ltac debugger: some exception that are usually consider anomalies are acceptable because they are caught later in the process that is being debugged. One should not require from users that they report these anomalies. *) -val explain_logic_error_no_anomaly : exn -> Pp.std_ppcmds +val explain_logic_error_no_anomaly : exn -> Pp.t (** Prints a logic failure message for a rule *) val db_logic_failure : debug_info -> exn -> unit Proofview.NonLogical.t @@ -77,4 +77,4 @@ val db_breakpoint : debug_info -> Id.t Loc.located message_token list -> unit Proofview.NonLogical.t val extract_ltac_trace : - ?loc:Loc.t -> Tacexpr.ltac_trace -> Pp.std_ppcmds option Loc.located + ?loc:Loc.t -> Tacexpr.ltac_trace -> Pp.t option Loc.located diff --git a/plugins/ltac/tactic_option.mli b/plugins/ltac/tactic_option.mli index dd91944d48..95cd243ec8 100644 --- a/plugins/ltac/tactic_option.mli +++ b/plugins/ltac/tactic_option.mli @@ -12,4 +12,4 @@ open Vernacexpr val declare_tactic_option : ?default:Tacexpr.glob_tactic_expr -> string -> (* put *) (locality_flag -> glob_tactic_expr -> unit) * (* get *) (unit -> locality_flag * unit Proofview.tactic) * - (* print *) (unit -> Pp.std_ppcmds) + (* print *) (unit -> Pp.t) diff --git a/plugins/rtauto/proof_search.mli b/plugins/rtauto/proof_search.mli index e0c09f394c..86231cf199 100644 --- a/plugins/rtauto/proof_search.mli +++ b/plugins/rtauto/proof_search.mli @@ -38,9 +38,9 @@ val branching: state -> state list val success: state -> bool -val pp: state -> Pp.std_ppcmds +val pp: state -> Pp.t -val pr_form : form -> Pp.std_ppcmds +val pr_form : form -> Pp.t val reset_info : unit -> unit diff --git a/plugins/setoid_ring/g_newring.ml4 b/plugins/setoid_ring/g_newring.ml4 index 6c82346bca..05ab8ab326 100644 --- a/plugins/setoid_ring/g_newring.ml4 +++ b/plugins/setoid_ring/g_newring.ml4 @@ -8,7 +8,6 @@ (*i camlp4deps: "grammar/grammar.cma" i*) -open Grammar_API open Ltac_plugin open Pp open Util diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index 608b778e4f..799e969ae2 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -8,7 +8,6 @@ (* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) -open Grammar_API open Util open Names open Evd diff --git a/plugins/ssr/ssrcommon.mli b/plugins/ssr/ssrcommon.mli index 4b045e989a..2eadd5f26c 100644 --- a/plugins/ssr/ssrcommon.mli +++ b/plugins/ssr/ssrcommon.mli @@ -41,7 +41,7 @@ val nohint : 'a ssrhint (******************************** misc ************************************) -val errorstrm : Pp.std_ppcmds -> 'a +val errorstrm : Pp.t -> 'a val anomaly : string -> 'a val array_app_tl : 'a array -> 'a list -> 'a list diff --git a/plugins/ssr/ssrparser.ml4 b/plugins/ssr/ssrparser.ml4 index 228444b82e..ce23bb2b30 100644 --- a/plugins/ssr/ssrparser.ml4 +++ b/plugins/ssr/ssrparser.ml4 @@ -8,7 +8,6 @@ (* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) -open Grammar_API open Names open Pp open Pcoq diff --git a/plugins/ssr/ssrparser.mli b/plugins/ssr/ssrparser.mli index c93e104056..88beeaa711 100644 --- a/plugins/ssr/ssrparser.mli +++ b/plugins/ssr/ssrparser.mli @@ -8,8 +8,6 @@ (* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) -open Grammar_API - val ssrtacarg : Tacexpr.raw_tactic_expr Pcoq.Gram.entry val wit_ssrtacarg : (Tacexpr.raw_tactic_expr, Tacexpr.glob_tactic_expr, Geninterp.Val.t) Genarg.genarg_type val pr_ssrtacarg : 'a -> 'b -> (int * Ppextend.parenRelation -> 'c) -> 'c @@ -18,5 +16,5 @@ val ssrtclarg : Tacexpr.raw_tactic_expr Pcoq.Gram.entry val wit_ssrtclarg : (Tacexpr.raw_tactic_expr, Tacexpr.glob_tactic_expr, Geninterp.Val.t) Genarg.genarg_type val pr_ssrtclarg : 'a -> 'b -> (int * Ppextend.parenRelation -> 'c -> 'd) -> 'c -> 'd -val add_genarg : string -> ('a -> Pp.std_ppcmds) -> 'a Genarg.uniform_genarg_type +val add_genarg : string -> ('a -> Pp.t) -> 'a Genarg.uniform_genarg_type diff --git a/plugins/ssr/ssrprinters.mli b/plugins/ssr/ssrprinters.mli index 5c68872b75..f231068265 100644 --- a/plugins/ssr/ssrprinters.mli +++ b/plugins/ssr/ssrprinters.mli @@ -11,16 +11,16 @@ open Ssrast val pp_term : - Goal.goal Evd.sigma -> EConstr.constr -> Pp.std_ppcmds + Goal.goal Evd.sigma -> EConstr.constr -> Pp.t -val pr_spc : unit -> Pp.std_ppcmds -val pr_bar : unit -> Pp.std_ppcmds +val pr_spc : unit -> Pp.t +val pr_bar : unit -> Pp.t val pr_list : - (unit -> Pp.std_ppcmds) -> ('a -> Pp.std_ppcmds) -> 'a list -> Pp.std_ppcmds + (unit -> Pp.t) -> ('a -> Pp.t) -> 'a list -> Pp.t val pp_concat : - Pp.std_ppcmds -> - ?sep:Pp.std_ppcmds -> Pp.std_ppcmds list -> Pp.std_ppcmds + Pp.t -> + ?sep:Pp.t -> Pp.t list -> Pp.t val xInParens : ssrtermkind val xWithAt : ssrtermkind @@ -29,17 +29,17 @@ val xCpattern : ssrtermkind val pr_term : ssrtermkind * (Glob_term.glob_constr * Constrexpr.constr_expr option) -> - Pp.std_ppcmds + Pp.t -val pr_hyp : ssrhyp -> Pp.std_ppcmds +val pr_hyp : ssrhyp -> Pp.t -val prl_constr_expr : Constrexpr.constr_expr -> Pp.std_ppcmds -val prl_glob_constr : Glob_term.glob_constr -> Pp.std_ppcmds +val prl_constr_expr : Constrexpr.constr_expr -> Pp.t +val prl_glob_constr : Glob_term.glob_constr -> Pp.t val pr_guarded : - (string -> int -> bool) -> ('a -> Pp.std_ppcmds) -> 'a -> Pp.std_ppcmds + (string -> int -> bool) -> ('a -> Pp.t) -> 'a -> Pp.t -val pr_occ : ssrocc -> Pp.std_ppcmds +val pr_occ : ssrocc -> Pp.t -val ppdebug : Pp.std_ppcmds Lazy.t -> unit +val ppdebug : Pp.t Lazy.t -> unit diff --git a/plugins/ssr/ssrvernac.ml4 b/plugins/ssr/ssrvernac.ml4 index fbe3cd2b91..9c59d83d4e 100644 --- a/plugins/ssr/ssrvernac.ml4 +++ b/plugins/ssr/ssrvernac.ml4 @@ -8,7 +8,6 @@ (* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) -open Grammar_API open Names open Term open Termops diff --git a/plugins/ssrmatching/ssrmatching.ml4 b/plugins/ssrmatching/ssrmatching.ml4 index 74519f6c54..f6300ab7e1 100644 --- a/plugins/ssrmatching/ssrmatching.ml4 +++ b/plugins/ssrmatching/ssrmatching.ml4 @@ -8,8 +8,6 @@ (* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) -open Grammar_API - (* Defining grammar rules with "xx" in it automatically declares keywords too, * we thus save the lexer to restore it at the end of the file *) let frozen_lexer = CLexer.get_keyword_state () ;; diff --git a/plugins/ssrmatching/ssrmatching.mli b/plugins/ssrmatching/ssrmatching.mli index 0c09d7bfbf..8e2a1a7176 100644 --- a/plugins/ssrmatching/ssrmatching.mli +++ b/plugins/ssrmatching/ssrmatching.mli @@ -1,7 +1,6 @@ (* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) -open Grammar_API open Goal open Genarg open Tacexpr @@ -16,7 +15,7 @@ open Term (** The type of context patterns, the patterns of the [set] tactic and [:] tactical. These are patterns that identify a precise subterm. *) type cpattern -val pr_cpattern : cpattern -> Pp.std_ppcmds +val pr_cpattern : cpattern -> Pp.t (** CS cpattern: (f _), (X in t), (t in X in t), (t as X in t) *) val cpattern : cpattern Pcoq.Gram.entry @@ -30,7 +29,7 @@ val wit_lcpattern : cpattern uniform_genarg_type These patterns also include patterns that identify all the subterms of a context (i.e. "in" prefix) *) type rpattern -val pr_rpattern : rpattern -> Pp.std_ppcmds +val pr_rpattern : rpattern -> Pp.t (** OS rpattern: f _, in t, X in t, in X in t, t in X in t, t as X in t *) val rpattern : rpattern Pcoq.Gram.entry @@ -51,7 +50,7 @@ type ('ident, 'term) ssrpattern = | E_As_X_In_T of 'term * 'ident * 'term type pattern = evar_map * (constr, constr) ssrpattern -val pp_pattern : pattern -> Pp.std_ppcmds +val pp_pattern : pattern -> Pp.t (** Extracts the redex and applies to it the substitution part of the pattern. @raise Anomaly if called on [In_T] or [In_X_In_T] *) @@ -116,7 +115,7 @@ val fill_occ_pattern : the T pattern above, and calls a continuation on its occurrences. *) type ssrdir = L2R | R2L -val pr_dir_side : ssrdir -> Pp.std_ppcmds +val pr_dir_side : ssrdir -> Pp.t (** a pattern for a term with wildcards *) type tpattern @@ -226,7 +225,7 @@ val loc_of_cpattern : cpattern -> Loc.t option val id_of_pattern : pattern -> Names.Id.t option val is_wildcard : cpattern -> bool val cpattern_of_id : Names.Id.t -> cpattern -val pr_constr_pat : constr -> Pp.std_ppcmds +val pr_constr_pat : constr -> Pp.t val pf_merge_uc : UState.t -> goal Evd.sigma -> goal Evd.sigma val pf_unsafe_merge_uc : UState.t -> goal Evd.sigma -> goal Evd.sigma diff --git a/pretyping/classops.ml b/pretyping/classops.ml index 078990a8c1..1cc072a2a2 100644 --- a/pretyping/classops.ml +++ b/pretyping/classops.ml @@ -89,7 +89,7 @@ sig type t val compare : t -> t -> int val equal : t -> t -> bool - val print : t -> std_ppcmds + val print : t -> Pp.t end type 'a t val empty : 'a t @@ -324,7 +324,7 @@ let coercion_value { coe_value = c; coe_type = t; coe_context = ctx; (* rajouter une coercion dans le graphe *) let path_printer = ref (fun _ -> str "<a class path>" - : (Bijint.Index.t * Bijint.Index.t) * inheritance_path -> std_ppcmds) + : (Bijint.Index.t * Bijint.Index.t) * inheritance_path -> Pp.t) let install_path_printer f = path_printer := f diff --git a/pretyping/classops.mli b/pretyping/classops.mli index 2e5ce30f35..8707078b58 100644 --- a/pretyping/classops.mli +++ b/pretyping/classops.mli @@ -95,15 +95,14 @@ val lookup_pattern_path_between : (**/**) (* Crade *) -open Pp val install_path_printer : - ((cl_index * cl_index) * inheritance_path -> std_ppcmds) -> unit + ((cl_index * cl_index) * inheritance_path -> Pp.t) -> unit (**/**) (** {6 This is for printing purpose } *) val string_of_class : cl_typ -> string -val pr_class : cl_typ -> std_ppcmds -val pr_cl_index : cl_index -> std_ppcmds +val pr_class : cl_typ -> Pp.t +val pr_cl_index : cl_index -> Pp.t val get_coercion_value : coe_index -> Constr.t val inheritance_graph : unit -> ((cl_index * cl_index) * inheritance_path) list val classes : unit -> cl_typ list diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index f830d4be3f..a27debe735 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -81,7 +81,7 @@ let encode_tuple r = module PrintingInductiveMake = functor (Test : sig val encode : reference -> inductive - val member_message : std_ppcmds -> bool -> std_ppcmds + val member_message : Pp.t -> bool -> Pp.t val field : string val title : string end) -> @@ -475,8 +475,8 @@ let rec detype flags avoid env sigma t = CAst.make @@ GApp (f',args''@args') | _ -> GApp (f',args') in - mkapp (detype flags avoid env sigma f) - (Array.map_to_list (detype flags avoid env sigma) args) + mkapp (detype flags avoid env sigma f) + (detype_array flags avoid env sigma args) | Const (sp,u) -> GRef (ConstRef sp, detype_instance sigma u) | Proj (p,c) -> let noparams () = @@ -694,6 +694,15 @@ and detype_binder (lax,isgoal as flags) bk avoid env sigma na body ty c = let t = if s != InProp && not !Flags.raw_print then None else Some (detype (lax,false) avoid env sigma ty) in GLetIn (na', c, t, r) +(** We use a dedicated function here to prevent overallocation from + Array.map_to_list. *) +and detype_array flags avoid env sigma args = + let ans = ref [] in + for i = Array.length args - 1 downto 0 do + ans := detype flags avoid env sigma args.(i) :: !ans; + done; + !ans + let detype_rel_context ?(lax=false) where avoid env sigma sign = let where = Option.map (fun c -> EConstr.it_mkLambda_or_LetIn c sign) where in let rec aux avoid env = function diff --git a/pretyping/detyping.mli b/pretyping/detyping.mli index ffd67299d5..59f3f967d3 100644 --- a/pretyping/detyping.mli +++ b/pretyping/detyping.mli @@ -66,7 +66,7 @@ val subst_genarg_hook : module PrintingInductiveMake : functor (Test : sig val encode : Libnames.reference -> Names.inductive - val member_message : Pp.std_ppcmds -> bool -> Pp.std_ppcmds + val member_message : Pp.t -> bool -> Pp.t val field : string val title : string end) -> @@ -75,9 +75,9 @@ module PrintingInductiveMake : val compare : t -> t -> int val encode : Libnames.reference -> Names.inductive val subst : substitution -> t -> t - val printer : t -> Pp.std_ppcmds + val printer : t -> Pp.t val key : Goptions.option_name val title : string - val member_message : t -> bool -> Pp.std_ppcmds + val member_message : t -> bool -> Pp.t val synchronous : bool end diff --git a/pretyping/evardefine.mli b/pretyping/evardefine.mli index c727332c79..5477c5c99d 100644 --- a/pretyping/evardefine.mli +++ b/pretyping/evardefine.mli @@ -43,5 +43,5 @@ val define_evar_as_sort : env -> evar_map -> existential -> evar_map * sorts (** {6 debug pretty-printer:} *) -val pr_tycon : env -> evar_map -> type_constraint -> Pp.std_ppcmds +val pr_tycon : env -> evar_map -> type_constraint -> Pp.t diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index 9f48297613..ef0fb8ea6e 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -34,12 +34,6 @@ let get_polymorphic_positions sigma f = (match oib.mind_arity with | RegularArity _ -> assert false | TemplateArity templ -> templ.template_param_levels) - | Const (cst, u) -> - let cb = Global.lookup_constant cst in - (match cb.const_type with - | RegularArity _ -> assert false - | TemplateArity (_, templ) -> - templ.template_param_levels) | _ -> assert false let refresh_universes ?(status=univ_rigid) ?(onlyalg=false) ?(refreshset=false) diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index bfc6bf5cff..b4d87dfdb0 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -1136,8 +1136,13 @@ and pretype_type k0 resolve_tc valcon (env : ExtraEnv.t) evdref lvar = function evd_comb1 (define_evar_as_sort env.ExtraEnv.env) evdref ev | _ -> anomaly (Pp.str "Found a type constraint which is not a type.") in - { utj_val = v; - utj_type = s } + (* Correction of bug #5315 : we need to define an evar for *all* holes *) + let evkt = e_new_evar env evdref ~src:(loc, knd) ~naming (mkSort s) in + let ev,_ = destEvar !evdref evkt in + evdref := Evd.define ev (to_constr !evdref v) !evdref; + (* End of correction of bug #5315 *) + { utj_val = v; + utj_type = s } | None -> let env = ltac_interp_name_env k0 lvar env !evdref in let s = evd_comb0 (new_sort_variable univ_flexible_alg) evdref in diff --git a/pretyping/recordops.mli b/pretyping/recordops.mli index de09edcdcb..5480b14af0 100644 --- a/pretyping/recordops.mli +++ b/pretyping/recordops.mli @@ -67,7 +67,7 @@ type obj_typ = { (** Return the form of the component of a canonical structure *) val cs_pattern_of_constr : constr -> cs_pattern * int option * constr list -val pr_cs_pattern : cs_pattern -> Pp.std_ppcmds +val pr_cs_pattern : cs_pattern -> Pp.t val lookup_canonical_conversion : (global_reference * cs_pattern) -> constr * obj_typ val declare_canonical_structure : global_reference -> unit diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 1d75fecb15..3563235434 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -272,7 +272,7 @@ module Stack : sig open EConstr type 'a app_node - val pr_app_node : ('a -> Pp.std_ppcmds) -> 'a app_node -> Pp.std_ppcmds + val pr_app_node : ('a -> Pp.t) -> 'a app_node -> Pp.t type cst_member = | Cst_const of pconstant @@ -290,7 +290,7 @@ sig exception IncompatibleFold2 - val pr : ('a -> Pp.std_ppcmds) -> 'a t -> Pp.std_ppcmds + val pr : ('a -> Pp.t) -> 'a t -> Pp.t val empty : 'a t val is_empty : 'a t -> bool val append_app : 'a array -> 'a t -> 'a t diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index db407b6c9b..1828196fe4 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -26,7 +26,7 @@ module ReductionBehaviour : sig bool -> Globnames.global_reference -> (int list * int * flag list) -> unit val get : Globnames.global_reference -> (int list * int * flag list) option - val print : Globnames.global_reference -> Pp.std_ppcmds + val print : Globnames.global_reference -> Pp.t end (** Option telling if reduction should use the refolding machinery of cbn @@ -63,13 +63,13 @@ module Cst_stack : sig val best_cst : t -> (constr * constr list) option val best_replace : Evd.evar_map -> constr -> t -> constr -> constr val reference : Evd.evar_map -> t -> Constant.t option - val pr : t -> Pp.std_ppcmds + val pr : t -> Pp.t end module Stack : sig type 'a app_node - val pr_app_node : ('a -> Pp.std_ppcmds) -> 'a app_node -> Pp.std_ppcmds + val pr_app_node : ('a -> Pp.t) -> 'a app_node -> Pp.t type cst_member = | Cst_const of pconstant @@ -86,7 +86,7 @@ module Stack : sig | Update of 'a and 'a t = 'a member list - val pr : ('a -> Pp.std_ppcmds) -> 'a t -> Pp.std_ppcmds + val pr : ('a -> Pp.t) -> 'a t -> Pp.t val empty : 'a t val is_empty : 'a t -> bool @@ -145,7 +145,7 @@ type contextual_state_reduction_function = type state_reduction_function = contextual_state_reduction_function type local_state_reduction_function = evar_map -> state -> state -val pr_state : state -> Pp.std_ppcmds +val pr_state : state -> Pp.t (** {6 Reduction Function Operators } *) diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index e0f9bfcb72..079524f344 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -192,11 +192,6 @@ let retype ?(polyprop=true) sigma = EConstr.of_constr (try Inductive.type_of_inductive_knowing_parameters ~polyprop env (mip, u) argtyps with Reduction.NotArity -> retype_error NotAnArity) - | Const (cst, u) -> - let u = EInstance.kind sigma u in - EConstr.of_constr (try Typeops.type_of_constant_knowing_parameters_in env (cst, u) argtyps - with Reduction.NotArity -> retype_error NotAnArity) - | Var id -> type_of_var env id | Construct (cstr, u) -> let u = EInstance.kind sigma u in EConstr.of_constr (type_of_constructor env (cstr, u)) @@ -220,7 +215,7 @@ let type_of_global_reference_knowing_conclusion env sigma c conclty = | Const (cst, u) -> let t = constant_type_in env (cst, EInstance.kind sigma u) in (* TODO *) - sigma, EConstr.of_constr (Typeops.type_of_constant_type_knowing_parameters env t [||]) + sigma, EConstr.of_constr t | Var id -> sigma, type_of_var env id | Construct (cstr, u) -> sigma, EConstr.of_constr (type_of_constructor env (cstr, EInstance.kind sigma u)) | _ -> assert false diff --git a/pretyping/retyping.mli b/pretyping/retyping.mli index 163d3975af..ed3a9d0f96 100644 --- a/pretyping/retyping.mli +++ b/pretyping/retyping.mli @@ -48,4 +48,4 @@ val sorts_of_context : env -> evar_map -> rel_context -> sorts list val expand_projection : env -> evar_map -> Names.projection -> constr -> constr list -> constr -val print_retype_error : retype_error -> Pp.std_ppcmds +val print_retype_error : retype_error -> Pp.t diff --git a/pretyping/typing.ml b/pretyping/typing.ml index 1bb0035751..1f35fa19aa 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -35,11 +35,6 @@ let meta_type evd mv = let ty = Evd.map_fl EConstr.of_constr ty in meta_instance evd ty -let constant_type_knowing_parameters env sigma (cst, u) jl = - let u = Unsafe.to_instance u in - let paramstyp = Array.map (fun j -> lazy (EConstr.to_constr sigma j.uj_type)) jl in - EConstr.of_constr (type_of_constant_knowing_parameters_in env (cst, u) paramstyp) - let inductive_type_knowing_parameters env sigma (ind,u) jl = let u = Unsafe.to_instance u in let mspec = lookup_mind_specif env ind in @@ -315,9 +310,6 @@ let rec execute env evdref cstr = | Ind (ind, u) when EInstance.is_empty u && Environ.template_polymorphic_ind ind env -> make_judge f (inductive_type_knowing_parameters env !evdref (ind, u) jl) - | Const (cst, u) when EInstance.is_empty u && Environ.template_polymorphic_constant cst env -> - make_judge f - (constant_type_knowing_parameters env !evdref (cst, u) jl) | _ -> (* No template polymorphism *) execute env evdref f diff --git a/printing/genprint.ml b/printing/genprint.ml index bb9736d731..543b05024d 100644 --- a/printing/genprint.ml +++ b/printing/genprint.ml @@ -9,7 +9,7 @@ open Pp open Genarg -type 'a printer = 'a -> std_ppcmds +type 'a printer = 'a -> Pp.t type ('raw, 'glb, 'top) genprinter = { raw : 'raw printer; diff --git a/printing/genprint.mli b/printing/genprint.mli index 24779a359d..130a89c929 100644 --- a/printing/genprint.mli +++ b/printing/genprint.mli @@ -8,18 +8,17 @@ (** Entry point for generic printers *) -open Pp open Genarg -type 'a printer = 'a -> std_ppcmds +type 'a printer = 'a -> Pp.t -val raw_print : ('raw, 'glb, 'top) genarg_type -> 'raw -> std_ppcmds +val raw_print : ('raw, 'glb, 'top) genarg_type -> 'raw -> Pp.t (** Printer for raw level generic arguments. *) -val glb_print : ('raw, 'glb, 'top) genarg_type -> 'glb -> std_ppcmds +val glb_print : ('raw, 'glb, 'top) genarg_type -> 'glb -> Pp.t (** Printer for glob level generic arguments. *) -val top_print : ('raw, 'glb, 'top) genarg_type -> 'top -> std_ppcmds +val top_print : ('raw, 'glb, 'top) genarg_type -> 'top -> Pp.t (** Printer for top level generic arguments. *) val generic_raw_print : rlevel generic_argument printer diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index cf513321fb..ee03bc9007 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -731,10 +731,10 @@ let tag_var = tag Tag.variable (sep() ++ if prec_less prec inherited then strm else surround strm) type term_pr = { - pr_constr_expr : constr_expr -> std_ppcmds; - pr_lconstr_expr : constr_expr -> std_ppcmds; - pr_constr_pattern_expr : constr_pattern_expr -> std_ppcmds; - pr_lconstr_pattern_expr : constr_pattern_expr -> std_ppcmds + pr_constr_expr : constr_expr -> Pp.t; + pr_lconstr_expr : constr_expr -> Pp.t; + pr_constr_pattern_expr : constr_pattern_expr -> Pp.t; + pr_lconstr_pattern_expr : constr_pattern_expr -> Pp.t } type precedence = Ppextend.precedence * Ppextend.parenRelation diff --git a/printing/ppconstr.mli b/printing/ppconstr.mli index fd232759ef..8335034851 100644 --- a/printing/ppconstr.mli +++ b/printing/ppconstr.mli @@ -9,10 +9,8 @@ (** This module implements pretty-printers for constr_expr syntactic objects and their subcomponents. *) -(** The default pretty-printers produce {!Pp.std_ppcmds} that are - interpreted as raw strings. *) +(** The default pretty-printers produce pretty-printing commands ({!Pp.t}). *) open Loc -open Pp open Libnames open Constrexpr open Names @@ -28,45 +26,45 @@ val split_fix : val prec_less : int -> int * Ppextend.parenRelation -> bool -val pr_tight_coma : unit -> std_ppcmds +val pr_tight_coma : unit -> Pp.t -val pr_or_var : ('a -> std_ppcmds) -> 'a or_var -> std_ppcmds +val pr_or_var : ('a -> Pp.t) -> 'a or_var -> Pp.t -val pr_lident : Id.t located -> std_ppcmds -val pr_lname : Name.t located -> std_ppcmds +val pr_lident : Id.t located -> Pp.t +val pr_lname : Name.t located -> Pp.t -val pr_with_comments : ?loc:Loc.t -> std_ppcmds -> std_ppcmds -val pr_com_at : int -> std_ppcmds +val pr_with_comments : ?loc:Loc.t -> Pp.t -> Pp.t +val pr_com_at : int -> Pp.t val pr_sep_com : - (unit -> std_ppcmds) -> - (constr_expr -> std_ppcmds) -> - constr_expr -> std_ppcmds + (unit -> Pp.t) -> + (constr_expr -> Pp.t) -> + constr_expr -> Pp.t -val pr_id : Id.t -> std_ppcmds -val pr_name : Name.t -> std_ppcmds -val pr_qualid : qualid -> std_ppcmds -val pr_patvar : patvar -> std_ppcmds +val pr_id : Id.t -> Pp.t +val pr_name : Name.t -> Pp.t +val pr_qualid : qualid -> Pp.t +val pr_patvar : patvar -> Pp.t -val pr_glob_level : glob_level -> std_ppcmds -val pr_glob_sort : glob_sort -> std_ppcmds -val pr_guard_annot : (constr_expr -> std_ppcmds) -> +val pr_glob_level : glob_level -> Pp.t +val pr_glob_sort : glob_sort -> Pp.t +val pr_guard_annot : (constr_expr -> Pp.t) -> local_binder_expr list -> ('a * Names.Id.t) option * recursion_order_expr -> - std_ppcmds + Pp.t -val pr_record_body : (reference * constr_expr) list -> std_ppcmds -val pr_binders : local_binder_expr list -> std_ppcmds -val pr_constr_pattern_expr : constr_pattern_expr -> std_ppcmds -val pr_lconstr_pattern_expr : constr_pattern_expr -> std_ppcmds -val pr_constr_expr : constr_expr -> std_ppcmds -val pr_lconstr_expr : constr_expr -> std_ppcmds -val pr_cases_pattern_expr : cases_pattern_expr -> std_ppcmds +val pr_record_body : (reference * constr_expr) list -> Pp.t +val pr_binders : local_binder_expr list -> Pp.t +val pr_constr_pattern_expr : constr_pattern_expr -> Pp.t +val pr_lconstr_pattern_expr : constr_pattern_expr -> Pp.t +val pr_constr_expr : constr_expr -> Pp.t +val pr_lconstr_expr : constr_expr -> Pp.t +val pr_cases_pattern_expr : cases_pattern_expr -> Pp.t type term_pr = { - pr_constr_expr : constr_expr -> std_ppcmds; - pr_lconstr_expr : constr_expr -> std_ppcmds; - pr_constr_pattern_expr : constr_pattern_expr -> std_ppcmds; - pr_lconstr_pattern_expr : constr_pattern_expr -> std_ppcmds + pr_constr_expr : constr_expr -> Pp.t; + pr_lconstr_expr : constr_expr -> Pp.t; + pr_constr_pattern_expr : constr_pattern_expr -> Pp.t; + pr_lconstr_pattern_expr : constr_pattern_expr -> Pp.t } val set_term_pr : term_pr -> unit @@ -91,5 +89,5 @@ type precedence val lsimpleconstr : precedence val ltop : precedence val modular_constr_pr : - ((unit->std_ppcmds) -> precedence -> constr_expr -> std_ppcmds) -> - (unit->std_ppcmds) -> precedence -> constr_expr -> std_ppcmds + ((unit->Pp.t) -> precedence -> constr_expr -> Pp.t) -> + (unit->Pp.t) -> precedence -> constr_expr -> Pp.t diff --git a/printing/pputils.mli b/printing/pputils.mli index 0dee11e0bc..1f4fa1390d 100644 --- a/printing/pputils.mli +++ b/printing/pputils.mli @@ -6,26 +6,25 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Pp open Genarg open Misctypes open Locus open Genredexpr -val pr_located : ('a -> std_ppcmds) -> 'a Loc.located -> std_ppcmds +val pr_located : ('a -> Pp.t) -> 'a Loc.located -> Pp.t (** Prints an object surrounded by its commented location *) -val pr_or_var : ('a -> std_ppcmds) -> 'a or_var -> std_ppcmds -val pr_or_by_notation : ('a -> std_ppcmds) -> 'a or_by_notation -> std_ppcmds +val pr_or_var : ('a -> Pp.t) -> 'a or_var -> Pp.t +val pr_or_by_notation : ('a -> Pp.t) -> 'a or_by_notation -> Pp.t val pr_with_occurrences : - ('a -> std_ppcmds) -> (string -> std_ppcmds) -> 'a with_occurrences -> std_ppcmds + ('a -> Pp.t) -> (string -> Pp.t) -> 'a with_occurrences -> Pp.t -val pr_short_red_flag : ('a -> std_ppcmds) -> 'a glob_red_flag -> std_ppcmds -val pr_red_flag : ('a -> std_ppcmds) -> 'a glob_red_flag -> std_ppcmds +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 -> std_ppcmds) * ('a -> std_ppcmds) * ('b -> std_ppcmds) * ('c -> std_ppcmds) -> - (string -> std_ppcmds) -> - ('a,'b,'c) red_expr_gen -> std_ppcmds + ('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_raw_generic : Environ.env -> rlevel generic_argument -> std_ppcmds -val pr_glb_generic : Environ.env -> glevel generic_argument -> std_ppcmds +val pr_raw_generic : Environ.env -> rlevel generic_argument -> Pp.t +val pr_glb_generic : Environ.env -> glevel generic_argument -> Pp.t diff --git a/printing/ppvernac.mli b/printing/ppvernac.mli index ed5585b309..b88eed4843 100644 --- a/printing/ppvernac.mli +++ b/printing/ppvernac.mli @@ -10,10 +10,10 @@ objects and their subcomponents. *) (** Prints a fixpoint body *) -val pr_rec_definition : (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) -> Pp.std_ppcmds +val pr_rec_definition : (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) -> Pp.t (** Prints a vernac expression *) -val pr_vernac_body : Vernacexpr.vernac_expr -> Pp.std_ppcmds +val pr_vernac_body : Vernacexpr.vernac_expr -> Pp.t (** Prints a vernac expression and closes it with a dot. *) -val pr_vernac : Vernacexpr.vernac_expr -> Pp.std_ppcmds +val pr_vernac : Vernacexpr.vernac_expr -> Pp.t diff --git a/printing/prettyp.ml b/printing/prettyp.ml index 827c0e4583..09859157c3 100644 --- a/printing/prettyp.ml +++ b/printing/prettyp.ml @@ -33,17 +33,17 @@ open Context.Rel.Declaration module NamedDecl = Context.Named.Declaration type object_pr = { - print_inductive : mutual_inductive -> std_ppcmds; - print_constant_with_infos : constant -> std_ppcmds; - print_section_variable : variable -> std_ppcmds; - print_syntactic_def : kernel_name -> std_ppcmds; - print_module : bool -> Names.module_path -> std_ppcmds; - print_modtype : module_path -> std_ppcmds; - print_named_decl : Context.Named.Declaration.t -> std_ppcmds; - print_library_entry : bool -> (object_name * Lib.node) -> std_ppcmds option; - print_context : bool -> int option -> Lib.library_segment -> std_ppcmds; - print_typed_value_in_env : Environ.env -> Evd.evar_map -> EConstr.constr * EConstr.types -> Pp.std_ppcmds; - print_eval : Reductionops.reduction_function -> env -> Evd.evar_map -> Constrexpr.constr_expr -> EConstr.unsafe_judgment -> std_ppcmds; + print_inductive : mutual_inductive -> Pp.t; + print_constant_with_infos : constant -> Pp.t; + print_section_variable : variable -> Pp.t; + print_syntactic_def : kernel_name -> Pp.t; + print_module : bool -> Names.module_path -> Pp.t; + print_modtype : module_path -> 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_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; } let gallina_print_module = print_module @@ -501,9 +501,6 @@ let print_body env evd = function let print_typed_body env evd (val_0,typ) = (print_body env evd val_0 ++ fnl () ++ str " : " ++ pr_ltype_env env evd typ) -let ungeneralized_type_of_constant_type t = - Typeops.type_of_constant_type (Global.env ()) t - let print_instance sigma cb = if Declareops.constant_is_polymorphic cb then let univs = Declareops.constant_polymorphic_context cb in @@ -515,17 +512,13 @@ let print_instance sigma cb = let print_constant with_values sep sp = let cb = Global.lookup_constant sp in let val_0 = Global.body_of_constant_body cb in - let typ = match cb.const_type with - | RegularArity t as x -> - begin match cb.const_universes with - | Monomorphic_const _ -> x + let typ = + match cb.const_universes with + | Monomorphic_const _ -> cb.const_type | Polymorphic_const univs -> let inst = Univ.AUContext.instance univs in - RegularArity (Vars.subst_instance_constr inst t) - end - | TemplateArity _ as x -> x + Vars.subst_instance_constr inst cb.const_type in - let typ = ungeneralized_type_of_constant_type typ in let univs = let otab = Global.opaque_tables () in match cb.const_body with @@ -698,7 +691,7 @@ let print_full_pure_context () = | "CONSTANT" -> let con = Global.constant_of_delta_kn kn in let cb = Global.lookup_constant con in - let typ = ungeneralized_type_of_constant_type cb.const_type in + let typ = cb.const_type in hov 0 ( match cb.const_body with | Undef _ -> diff --git a/printing/prettyp.mli b/printing/prettyp.mli index 4add21fa7b..f4277b6c50 100644 --- a/printing/prettyp.mli +++ b/printing/prettyp.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Pp open Names open Environ open Reductionops @@ -19,57 +18,57 @@ 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 -> std_ppcmds -val print_library_entry : bool -> (object_name * Lib.node) -> std_ppcmds option -val print_full_context : unit -> std_ppcmds -val print_full_context_typ : unit -> std_ppcmds -val print_full_pure_context : unit -> std_ppcmds -val print_sec_context : reference -> std_ppcmds -val print_sec_context_typ : reference -> std_ppcmds -val print_judgment : env -> Evd.evar_map -> EConstr.unsafe_judgment -> std_ppcmds -val print_safe_judgment : env -> Evd.evar_map -> Safe_typing.judgment -> std_ppcmds +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_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 -> std_ppcmds + Constrexpr.constr_expr -> EConstr.unsafe_judgment -> Pp.t -val print_name : reference or_by_notation -> std_ppcmds -val print_opaque_name : reference -> std_ppcmds -val print_about : reference or_by_notation -> std_ppcmds -val print_impargs : reference or_by_notation -> std_ppcmds +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_impargs : reference or_by_notation -> Pp.t (** Pretty-printing functions for classes and coercions *) -val print_graph : unit -> std_ppcmds -val print_classes : unit -> std_ppcmds -val print_coercions : unit -> std_ppcmds -val print_path_between : Classops.cl_typ -> Classops.cl_typ -> std_ppcmds -val print_canonical_projections : unit -> std_ppcmds +val print_graph : unit -> Pp.t +val print_classes : unit -> Pp.t +val print_coercions : unit -> Pp.t +val print_path_between : Classops.cl_typ -> Classops.cl_typ -> Pp.t +val print_canonical_projections : unit -> Pp.t (** Pretty-printing functions for type classes and instances *) -val print_typeclasses : unit -> std_ppcmds -val print_instances : global_reference -> std_ppcmds -val print_all_instances : unit -> std_ppcmds +val print_typeclasses : unit -> Pp.t +val print_instances : global_reference -> Pp.t +val print_all_instances : unit -> Pp.t -val inspect : int -> std_ppcmds +val inspect : int -> Pp.t (** Locate *) -val print_located_qualid : reference -> std_ppcmds -val print_located_term : reference -> std_ppcmds -val print_located_tactic : reference -> std_ppcmds -val print_located_module : reference -> std_ppcmds +val print_located_qualid : reference -> Pp.t +val print_located_term : reference -> Pp.t +val print_located_tactic : reference -> Pp.t +val print_located_module : reference -> Pp.t type object_pr = { - print_inductive : mutual_inductive -> std_ppcmds; - print_constant_with_infos : constant -> std_ppcmds; - print_section_variable : variable -> std_ppcmds; - print_syntactic_def : kernel_name -> std_ppcmds; - print_module : bool -> Names.module_path -> std_ppcmds; - print_modtype : module_path -> std_ppcmds; - print_named_decl : Context.Named.Declaration.t -> std_ppcmds; - print_library_entry : bool -> (object_name * Lib.node) -> std_ppcmds option; - print_context : bool -> int option -> Lib.library_segment -> std_ppcmds; - print_typed_value_in_env : Environ.env -> Evd.evar_map -> EConstr.constr * EConstr.types -> Pp.std_ppcmds; - print_eval : reduction_function -> env -> Evd.evar_map -> Constrexpr.constr_expr -> EConstr.unsafe_judgment -> std_ppcmds + print_inductive : mutual_inductive -> Pp.t; + print_constant_with_infos : constant -> Pp.t; + print_section_variable : variable -> Pp.t; + print_syntactic_def : kernel_name -> Pp.t; + print_module : bool -> Names.module_path -> Pp.t; + print_modtype : module_path -> 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_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 } val set_object_pr : object_pr -> unit diff --git a/printing/printer.ml b/printing/printer.ml index 3516788022..f731a39a48 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -758,9 +758,9 @@ let default_pr_subgoals ?(pr_first=true) type printer_pr = { - pr_subgoals : ?pr_first:bool -> std_ppcmds option -> evar_map -> evar list -> Goal.goal list -> int list -> goal list -> goal list -> std_ppcmds; - pr_subgoal : int -> evar_map -> goal list -> std_ppcmds; - pr_goal : goal sigma -> std_ppcmds; + 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; } let default_printer_pr = { diff --git a/printing/printer.mli b/printing/printer.mli index f8685b0895..2c9a4d70e6 100644 --- a/printing/printer.mli +++ b/printing/printer.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Pp open Names open Globnames open Term @@ -25,96 +24,96 @@ val enable_goal_names_printing : bool ref (** Terms *) -val pr_lconstr_env : env -> evar_map -> constr -> std_ppcmds -val pr_lconstr : constr -> std_ppcmds -val pr_lconstr_goal_style_env : env -> evar_map -> constr -> std_ppcmds +val pr_lconstr_env : env -> evar_map -> constr -> Pp.t +val pr_lconstr : constr -> Pp.t +val pr_lconstr_goal_style_env : env -> evar_map -> constr -> Pp.t -val pr_constr_env : env -> evar_map -> constr -> std_ppcmds -val pr_constr : constr -> std_ppcmds -val pr_constr_goal_style_env : env -> evar_map -> constr -> std_ppcmds +val pr_constr_env : env -> evar_map -> constr -> Pp.t +val pr_constr : constr -> Pp.t +val pr_constr_goal_style_env : env -> evar_map -> constr -> Pp.t (** Same, but resilient to [Nametab] errors. Prints fully-qualified names when [shortest_qualid_of_global] has failed. Prints "??" in case of remaining issues (such as reference not in env). *) -val safe_pr_lconstr_env : env -> evar_map -> constr -> std_ppcmds -val safe_pr_lconstr : constr -> std_ppcmds +val safe_pr_lconstr_env : env -> evar_map -> constr -> Pp.t +val safe_pr_lconstr : constr -> Pp.t -val safe_pr_constr_env : env -> evar_map -> constr -> std_ppcmds -val safe_pr_constr : constr -> std_ppcmds +val safe_pr_constr_env : env -> evar_map -> constr -> Pp.t +val safe_pr_constr : constr -> Pp.t -val pr_econstr_env : env -> evar_map -> EConstr.t -> std_ppcmds -val pr_econstr : EConstr.t -> std_ppcmds -val pr_leconstr_env : env -> evar_map -> EConstr.t -> std_ppcmds -val pr_leconstr : EConstr.t -> std_ppcmds +val pr_econstr_env : env -> evar_map -> EConstr.t -> Pp.t +val pr_econstr : EConstr.t -> Pp.t +val pr_leconstr_env : env -> evar_map -> EConstr.t -> Pp.t +val pr_leconstr : EConstr.t -> Pp.t -val pr_etype_env : env -> evar_map -> EConstr.types -> std_ppcmds -val pr_letype_env : env -> evar_map -> EConstr.types -> std_ppcmds +val pr_etype_env : env -> evar_map -> EConstr.types -> Pp.t +val pr_letype_env : env -> evar_map -> EConstr.types -> Pp.t -val pr_open_constr_env : env -> evar_map -> open_constr -> std_ppcmds -val pr_open_constr : open_constr -> std_ppcmds +val pr_open_constr_env : env -> evar_map -> open_constr -> Pp.t +val pr_open_constr : open_constr -> Pp.t -val pr_open_lconstr_env : env -> evar_map -> open_constr -> std_ppcmds -val pr_open_lconstr : open_constr -> std_ppcmds +val pr_open_lconstr_env : env -> evar_map -> open_constr -> Pp.t +val pr_open_lconstr : open_constr -> Pp.t -val pr_constr_under_binders_env : env -> evar_map -> constr_under_binders -> std_ppcmds -val pr_constr_under_binders : constr_under_binders -> std_ppcmds +val pr_constr_under_binders_env : env -> evar_map -> constr_under_binders -> Pp.t +val pr_constr_under_binders : constr_under_binders -> Pp.t -val pr_lconstr_under_binders_env : env -> evar_map -> constr_under_binders -> std_ppcmds -val pr_lconstr_under_binders : constr_under_binders -> std_ppcmds +val pr_lconstr_under_binders_env : env -> evar_map -> constr_under_binders -> Pp.t +val pr_lconstr_under_binders : constr_under_binders -> Pp.t -val pr_goal_concl_style_env : env -> evar_map -> EConstr.types -> std_ppcmds -val pr_ltype_env : env -> evar_map -> types -> std_ppcmds -val pr_ltype : types -> std_ppcmds +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 -val pr_type_env : env -> evar_map -> types -> std_ppcmds -val pr_type : types -> std_ppcmds +val pr_type_env : env -> evar_map -> types -> Pp.t +val pr_type : types -> Pp.t -val pr_closed_glob_env : env -> evar_map -> closed_glob_constr -> std_ppcmds -val pr_closed_glob : closed_glob_constr -> std_ppcmds +val pr_closed_glob_env : env -> evar_map -> closed_glob_constr -> Pp.t +val pr_closed_glob : closed_glob_constr -> Pp.t -val pr_ljudge_env : env -> evar_map -> EConstr.unsafe_judgment -> std_ppcmds * std_ppcmds -val pr_ljudge : EConstr.unsafe_judgment -> std_ppcmds * std_ppcmds +val pr_ljudge_env : env -> evar_map -> EConstr.unsafe_judgment -> Pp.t * Pp.t +val pr_ljudge : EConstr.unsafe_judgment -> Pp.t * Pp.t -val pr_lglob_constr_env : env -> glob_constr -> std_ppcmds -val pr_lglob_constr : glob_constr -> std_ppcmds +val pr_lglob_constr_env : env -> glob_constr -> Pp.t +val pr_lglob_constr : glob_constr -> Pp.t -val pr_glob_constr_env : env -> glob_constr -> std_ppcmds -val pr_glob_constr : glob_constr -> std_ppcmds +val pr_glob_constr_env : env -> glob_constr -> Pp.t +val pr_glob_constr : glob_constr -> Pp.t -val pr_lconstr_pattern_env : env -> evar_map -> constr_pattern -> std_ppcmds -val pr_lconstr_pattern : constr_pattern -> std_ppcmds +val pr_lconstr_pattern_env : env -> evar_map -> constr_pattern -> Pp.t +val pr_lconstr_pattern : constr_pattern -> Pp.t -val pr_constr_pattern_env : env -> evar_map -> constr_pattern -> std_ppcmds -val pr_constr_pattern : constr_pattern -> std_ppcmds +val pr_constr_pattern_env : env -> evar_map -> constr_pattern -> Pp.t +val pr_constr_pattern : constr_pattern -> Pp.t -val pr_cases_pattern : cases_pattern -> std_ppcmds +val pr_cases_pattern : cases_pattern -> Pp.t -val pr_sort : evar_map -> sorts -> std_ppcmds +val pr_sort : evar_map -> sorts -> Pp.t (** Universe constraints *) -val pr_polymorphic : bool -> std_ppcmds -val pr_cumulative : bool -> bool -> std_ppcmds -val pr_universe_instance : evar_map -> Univ.universe_context -> std_ppcmds -val pr_universe_ctx : evar_map -> Univ.universe_context -> std_ppcmds -val pr_cumulativity_info : evar_map -> Univ.cumulativity_info -> std_ppcmds +val pr_polymorphic : bool -> Pp.t +val pr_cumulative : bool -> bool -> Pp.t +val pr_universe_instance : evar_map -> Univ.universe_context -> Pp.t +val pr_universe_ctx : evar_map -> Univ.universe_context -> Pp.t +val pr_cumulativity_info : evar_map -> Univ.cumulativity_info -> Pp.t (** Printing global references using names as short as possible *) -val pr_global_env : Id.Set.t -> global_reference -> std_ppcmds -val pr_global : global_reference -> std_ppcmds +val pr_global_env : Id.Set.t -> global_reference -> Pp.t +val pr_global : global_reference -> Pp.t -val pr_constant : env -> constant -> std_ppcmds -val pr_existential_key : evar_map -> existential_key -> std_ppcmds -val pr_existential : env -> evar_map -> existential -> std_ppcmds -val pr_constructor : env -> constructor -> std_ppcmds -val pr_inductive : env -> inductive -> std_ppcmds -val pr_evaluable_reference : evaluable_global_reference -> std_ppcmds +val pr_constant : env -> constant -> Pp.t +val pr_existential_key : evar_map -> existential_key -> Pp.t +val pr_existential : env -> evar_map -> existential -> Pp.t +val pr_constructor : env -> constructor -> Pp.t +val pr_inductive : env -> inductive -> Pp.t +val pr_evaluable_reference : evaluable_global_reference -> Pp.t -val pr_pconstant : env -> pconstant -> std_ppcmds -val pr_pinductive : env -> pinductive -> std_ppcmds -val pr_pconstructor : env -> pconstructor -> std_ppcmds +val pr_pconstant : env -> pconstant -> Pp.t +val pr_pinductive : env -> pinductive -> Pp.t +val pr_pconstructor : env -> pconstructor -> Pp.t (** Contexts *) @@ -122,29 +121,29 @@ val pr_pconstructor : env -> pconstructor -> std_ppcmds val set_compact_context : bool -> unit val get_compact_context : unit -> bool -val pr_context_unlimited : env -> evar_map -> std_ppcmds -val pr_ne_context_of : std_ppcmds -> env -> evar_map -> std_ppcmds +val pr_context_unlimited : env -> evar_map -> Pp.t +val pr_ne_context_of : Pp.t -> env -> evar_map -> Pp.t -val pr_named_decl : env -> evar_map -> Context.Named.Declaration.t -> std_ppcmds -val pr_compacted_decl : env -> evar_map -> Context.Compacted.Declaration.t -> std_ppcmds -val pr_rel_decl : env -> evar_map -> Context.Rel.Declaration.t -> std_ppcmds +val pr_named_decl : env -> evar_map -> Context.Named.Declaration.t -> Pp.t +val pr_compacted_decl : env -> evar_map -> Context.Compacted.Declaration.t -> Pp.t +val pr_rel_decl : env -> evar_map -> Context.Rel.Declaration.t -> Pp.t -val pr_named_context : env -> evar_map -> Context.Named.t -> std_ppcmds -val pr_named_context_of : env -> evar_map -> std_ppcmds -val pr_rel_context : env -> evar_map -> Context.Rel.t -> std_ppcmds -val pr_rel_context_of : env -> evar_map -> std_ppcmds -val pr_context_of : env -> evar_map -> std_ppcmds +val pr_named_context : env -> evar_map -> Context.Named.t -> Pp.t +val pr_named_context_of : env -> evar_map -> Pp.t +val pr_rel_context : env -> evar_map -> Context.Rel.t -> Pp.t +val pr_rel_context_of : env -> evar_map -> Pp.t +val pr_context_of : env -> evar_map -> Pp.t (** Predicates *) -val pr_predicate : ('a -> std_ppcmds) -> (bool * 'a list) -> std_ppcmds -val pr_cpred : Cpred.t -> std_ppcmds -val pr_idpred : Id.Pred.t -> std_ppcmds -val pr_transparent_state : transparent_state -> std_ppcmds +val pr_predicate : ('a -> Pp.t) -> (bool * 'a list) -> Pp.t +val pr_cpred : Cpred.t -> Pp.t +val pr_idpred : Id.Pred.t -> Pp.t +val pr_transparent_state : transparent_state -> Pp.t (** Proofs, these functions obey [Hyps Limit] and [Compact contexts]. *) -val pr_goal : goal sigma -> std_ppcmds +val pr_goal : goal sigma -> Pp.t (** [pr_subgoals ~pr_first pp sigma seeds shelf focus_stack unfocused goals] prints the goals of the list [goals] followed by the goals in @@ -155,25 +154,25 @@ val pr_goal : goal sigma -> std_ppcmds focused goals unless the conrresponding option [enable_unfocused_goal_printing] is set. [seeds] is for printing dependent evars (mainly for emacs proof tree mode). *) -val pr_subgoals : ?pr_first:bool -> std_ppcmds option -> evar_map -> evar list -> Goal.goal list -> int list - -> goal list -> goal list -> std_ppcmds +val pr_subgoals : ?pr_first:bool -> Pp.t option -> evar_map -> evar list -> Goal.goal list -> int list + -> goal list -> goal list -> Pp.t -val pr_subgoal : int -> evar_map -> goal list -> std_ppcmds -val pr_concl : int -> evar_map -> goal -> std_ppcmds +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 -> std_ppcmds -val pr_nth_open_subgoal : int -> std_ppcmds -val pr_evar : evar_map -> (evar * evar_info) -> std_ppcmds -val pr_evars_int : evar_map -> int -> evar_info Evar.Map.t -> std_ppcmds -val pr_evars : evar_map -> evar_info Evar.Map.t -> std_ppcmds -val pr_ne_evar_set : std_ppcmds -> std_ppcmds -> evar_map -> - Evar.Set.t -> std_ppcmds +val pr_open_subgoals : ?proof:Proof.proof -> unit -> Pp.t +val pr_nth_open_subgoal : 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 +val pr_ne_evar_set : Pp.t -> Pp.t -> evar_map -> + Evar.Set.t -> Pp.t -val pr_prim_rule : prim_rule -> std_ppcmds +val pr_prim_rule : prim_rule -> Pp.t (** Backwards compatibility *) -val prterm : constr -> std_ppcmds (** = pr_lconstr *) +val prterm : constr -> Pp.t (** = pr_lconstr *) (** Declarations for the "Print Assumption" command *) @@ -193,15 +192,15 @@ module ContextObjectMap : CMap.ExtS with type key = context_object and module Set := ContextObjectSet val pr_assumptionset : - env -> Term.types ContextObjectMap.t -> std_ppcmds + env -> Term.types ContextObjectMap.t -> Pp.t -val pr_goal_by_id : Id.t -> std_ppcmds -val pr_goal_by_uid : string -> std_ppcmds +val pr_goal_by_id : Id.t -> Pp.t +val pr_goal_by_uid : string -> Pp.t type printer_pr = { - pr_subgoals : ?pr_first:bool -> std_ppcmds option -> evar_map -> evar list -> Goal.goal list -> int list -> goal list -> goal list -> std_ppcmds; - pr_subgoal : int -> evar_map -> goal list -> std_ppcmds; - pr_goal : goal sigma -> std_ppcmds; + 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 5c7dcdc10f..219eafda4c 100644 --- a/printing/printmod.ml +++ b/printing/printmod.ml @@ -323,7 +323,7 @@ let print_body is_impl env mp (l,body) = str " :" ++ spc () ++ hov 0 (Printer.pr_ltype_env env sigma (Vars.subst_instance_constr u - (Typeops.type_of_constant_type env cb.const_type))) ++ + cb.const_type)) ++ (match cb.const_body with | Def l when is_impl -> spc () ++ diff --git a/printing/printmod.mli b/printing/printmod.mli index 81b5774537..8c3f0149e6 100644 --- a/printing/printmod.mli +++ b/printing/printmod.mli @@ -6,12 +6,11 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Pp open Names (** false iff the module is an element of an open module type *) val printable_body : DirPath.t -> bool -val pr_mutual_inductive_body : Environ.env -> mutual_inductive -> Declarations.mutual_inductive_body -> std_ppcmds -val print_module : bool -> module_path -> std_ppcmds -val print_modtype : module_path -> std_ppcmds +val pr_mutual_inductive_body : Environ.env -> mutual_inductive -> Declarations.mutual_inductive_body -> Pp.t +val print_module : bool -> module_path -> Pp.t +val print_modtype : module_path -> Pp.t diff --git a/proofs/clenv.mli b/proofs/clenv.mli index 26c6e60141..9c69995f4b 100644 --- a/proofs/clenv.mli +++ b/proofs/clenv.mli @@ -112,7 +112,7 @@ exception NotExtensibleClause val clenv_push_prod : clausenv -> clausenv (** {6 Pretty-print (debug only) } *) -val pr_clenv : clausenv -> Pp.std_ppcmds +val pr_clenv : clausenv -> Pp.t (** {6 Evar-based clauses} *) diff --git a/proofs/goal.mli b/proofs/goal.mli index cd71d11f86..6d3ec8bd4e 100644 --- a/proofs/goal.mli +++ b/proofs/goal.mli @@ -20,7 +20,7 @@ val uid : goal -> string val get_by_uid : string -> goal (* Debugging help *) -val pr_goal : goal -> Pp.std_ppcmds +val pr_goal : goal -> Pp.t (* Layer to implement v8.2 tactic engine ontop of the new architecture. Types are different from what they used to be due to a change of the diff --git a/proofs/miscprint.mli b/proofs/miscprint.mli index 21d410c7b0..b75718cd01 100644 --- a/proofs/miscprint.mli +++ b/proofs/miscprint.mli @@ -11,27 +11,27 @@ open Misctypes (** Printing of [intro_pattern] *) val pr_intro_pattern : - ('a -> Pp.std_ppcmds) -> 'a intro_pattern_expr Loc.located -> Pp.std_ppcmds + ('a -> Pp.t) -> 'a intro_pattern_expr Loc.located -> Pp.t val pr_or_and_intro_pattern : - ('a -> Pp.std_ppcmds) -> 'a or_and_intro_pattern_expr -> Pp.std_ppcmds + ('a -> Pp.t) -> 'a or_and_intro_pattern_expr -> Pp.t -val pr_intro_pattern_naming : intro_pattern_naming_expr -> Pp.std_ppcmds +val pr_intro_pattern_naming : intro_pattern_naming_expr -> Pp.t (** Printing of [move_location] *) val pr_move_location : - ('a -> Pp.std_ppcmds) -> 'a move_location -> Pp.std_ppcmds + ('a -> Pp.t) -> 'a move_location -> Pp.t val pr_bindings : - ('a -> Pp.std_ppcmds) -> - ('a -> Pp.std_ppcmds) -> 'a bindings -> Pp.std_ppcmds + ('a -> Pp.t) -> + ('a -> Pp.t) -> 'a bindings -> Pp.t val pr_bindings_no_with : - ('a -> Pp.std_ppcmds) -> - ('a -> Pp.std_ppcmds) -> 'a bindings -> Pp.std_ppcmds + ('a -> Pp.t) -> + ('a -> Pp.t) -> 'a bindings -> Pp.t val pr_with_bindings : - ('a -> Pp.std_ppcmds) -> - ('a -> Pp.std_ppcmds) -> 'a * 'a bindings -> Pp.std_ppcmds + ('a -> Pp.t) -> + ('a -> Pp.t) -> 'a * 'a bindings -> Pp.t diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index a949c8e911..1937885587 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -157,10 +157,9 @@ let build_by_tactic ?(side_eff=true) env sigma ?(poly=false) typ tac = if side_eff then Safe_typing.inline_private_constants_in_definition_entry env ce else { ce with const_entry_body = Future.chain ~pure:true ce.const_entry_body - (fun (pt, _) -> pt, Safe_typing.empty_private_constants) } in - let (cb, ctx), se = Future.force ce.const_entry_body in + (fun (pt, _) -> pt, ()) } in + let (cb, ctx), () = Future.force ce.const_entry_body in let univs' = Evd.merge_context_set Evd.univ_rigid (Evd.from_ctx univs) ctx in - assert(Safe_typing.empty_private_constants = se); cb, status, Evd.evar_universe_context univs' let refine_by_tactic env sigma ty tac = diff --git a/proofs/proof.mli b/proofs/proof.mli index 1865382e41..698aa48b02 100644 --- a/proofs/proof.mli +++ b/proofs/proof.mli @@ -182,7 +182,7 @@ val in_proof : proof -> (Evd.evar_map -> 'a) -> 'a focused goals. *) val unshelve : proof -> proof -val pr_proof : proof -> Pp.std_ppcmds +val pr_proof : proof -> Pp.t (*** Compatibility layer with <=v8.2 ***) module V82 : sig diff --git a/proofs/proof_bullet.mli b/proofs/proof_bullet.mli index 9ae521d3f0..9e924fec97 100644 --- a/proofs/proof_bullet.mli +++ b/proofs/proof_bullet.mli @@ -48,6 +48,6 @@ val suggest : proof -> Pp.t (* *) (**********************************************************) -val pr_goal_selector : Vernacexpr.goal_selector -> Pp.std_ppcmds +val pr_goal_selector : Vernacexpr.goal_selector -> Pp.t val get_default_goal_selector : unit -> Vernacexpr.goal_selector diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index 52d6787d44..2ade797f63 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -378,6 +378,10 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now let t = EConstr.Unsafe.to_constr t in let univstyp, body = make_body t p in let univs, typ = Future.force univstyp in + let univs = + if poly then Entries.Polymorphic_const_entry univs + else Entries.Monomorphic_const_entry univs + in { Entries. const_entry_body = body; const_entry_secctx = section_vars; @@ -386,7 +390,7 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now const_entry_inline_code = false; const_entry_opaque = true; const_entry_universes = univs; - const_entry_polymorphic = poly}) + }) fpl initial_goals in let binders = Option.map (fun names -> fst (Evd.universe_context ~names (Evd.from_ctx universes))) diff --git a/proofs/proof_type.mli b/proofs/proof_type.ml index 11f1a13e6e..11f1a13e6e 100644 --- a/proofs/proof_type.mli +++ b/proofs/proof_type.ml diff --git a/proofs/proofs.mllib b/proofs/proofs.mllib index 0ea2bd66be..eaf0c693e1 100644 --- a/proofs/proofs.mllib +++ b/proofs/proofs.mllib @@ -2,6 +2,7 @@ Miscprint Goal Evar_refiner Proof_using +Proof_type Logic Refine Proof diff --git a/proofs/refine.mli b/proofs/refine.mli index 20f5a07912..3b0a9e5b6f 100644 --- a/proofs/refine.mli +++ b/proofs/refine.mli @@ -17,7 +17,7 @@ open Proofview (** Printer used to print the constr which refine refines. *) val pr_constr : - (Environ.env -> Evd.evar_map -> Term.constr -> Pp.std_ppcmds) Hook.t + (Environ.env -> Evd.evar_map -> Term.constr -> Pp.t) Hook.t (** {7 Refinement primitives} *) diff --git a/proofs/refiner.ml b/proofs/refiner.ml index f1b1cd359f..3e3313eb57 100644 --- a/proofs/refiner.ml +++ b/proofs/refiner.ml @@ -63,7 +63,7 @@ let tclIDTAC_MESSAGE s gls = let tclFAIL_s s gls = user_err ~hdr:"Refiner.tclFAIL_s" (str s) (* A special exception for levels for the Fail tactic *) -exception FailError of int * std_ppcmds Lazy.t +exception FailError of int * Pp.t Lazy.t (* The Fail tactic *) let tclFAIL lvl s g = raise (FailError (lvl,lazy s)) diff --git a/proofs/refiner.mli b/proofs/refiner.mli index aac10e81b7..3ff010fe3e 100644 --- a/proofs/refiner.mli +++ b/proofs/refiner.mli @@ -31,7 +31,7 @@ val refiner : rule -> tactic (** [tclIDTAC] is the identity tactic without message printing*) val tclIDTAC : tactic -val tclIDTAC_MESSAGE : Pp.std_ppcmds -> tactic +val tclIDTAC_MESSAGE : Pp.t -> tactic (** [tclEVARS sigma] changes the current evar map *) val tclEVARS : evar_map -> tactic @@ -100,7 +100,7 @@ val tclTHENLASTn : tactic -> tactic array -> tactic val tclTHENFIRSTn : tactic -> tactic array -> tactic (** A special exception for levels for the Fail tactic *) -exception FailError of int * Pp.std_ppcmds Lazy.t +exception FailError of int * Pp.t Lazy.t (** Takes an exception and either raise it at the next level or do nothing. *) @@ -116,8 +116,8 @@ val tclTRY : tactic -> tactic val tclTHENTRY : tactic -> tactic -> tactic val tclCOMPLETE : tactic -> tactic val tclAT_LEAST_ONCE : tactic -> tactic -val tclFAIL : int -> Pp.std_ppcmds -> tactic -val tclFAIL_lazy : int -> Pp.std_ppcmds Lazy.t -> tactic +val tclFAIL : int -> Pp.t -> tactic +val tclFAIL_lazy : int -> Pp.t Lazy.t -> tactic val tclDO : int -> tactic -> tactic val tclPROGRESS : tactic -> tactic val tclSHOWHYPS : tactic -> tactic diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli index 2b7c365943..40b6573a15 100644 --- a/proofs/tacmach.mli +++ b/proofs/tacmach.mli @@ -94,8 +94,8 @@ val internal_cut_rev : bool -> Id.t -> types -> tactic val refine : constr -> tactic (** {6 Pretty-printing functions (debug only). } *) -val pr_gls : goal sigma -> Pp.std_ppcmds -val pr_glls : goal list sigma -> Pp.std_ppcmds +val pr_gls : goal sigma -> Pp.t +val pr_glls : goal list sigma -> Pp.t (* Variants of [Tacmach] functions built with the new proof engine *) module New : sig diff --git a/stm/asyncTaskQueue.ml b/stm/asyncTaskQueue.ml index 25f9d7c187..9c58df5b21 100644 --- a/stm/asyncTaskQueue.ml +++ b/stm/asyncTaskQueue.ml @@ -123,7 +123,7 @@ module Make(T : Task) = struct "-worker-id"; name; "-async-proofs-worker-priority"; Flags.string_of_priority !Flags.async_proofs_worker_priority] - | ("-ideslave"|"-emacs"|"-emacs-U"|"-batch")::tl -> set_slave_opt tl + | ("-ideslave"|"-emacs"|"-batch")::tl -> set_slave_opt tl | ("-async-proofs" |"-toploop" |"-vio2vo" |"-load-vernac-source" |"-l" |"-load-vernac-source-verbose" |"-lv" |"-compile" |"-compile-verbose" diff --git a/stm/stm.ml b/stm/stm.ml index 7c96208546..3386044f26 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -1133,7 +1133,7 @@ let record_pb_time ?loc proof_name time = hints := Aux_file.set !hints proof_name proof_build_time end -exception RemoteException of Pp.std_ppcmds +exception RemoteException of Pp.t let _ = CErrors.register_handler (function | RemoteException ppcmd -> ppcmd | _ -> raise Unhandled) @@ -1274,7 +1274,7 @@ end = struct (* {{{ *) type error = { e_error_at : Stateid.t; e_safe_id : Stateid.t; - e_msg : Pp.std_ppcmds; + e_msg : Pp.t; e_safe_states : Stateid.t list } type response = @@ -1711,7 +1711,7 @@ end = struct (* {{{ *) type response = | RespBuiltSubProof of (Constr.constr * Evd.evar_universe_context) - | RespError of Pp.std_ppcmds + | RespError of Pp.t | RespNoProgress let name = ref "tacworker" diff --git a/tactics/autorewrite.mli b/tactics/autorewrite.mli index 306ff1868a..edbb7c6b71 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.std_ppcmds +val print_rewrite_hintdb : string -> Pp.t open Clenv diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index 6cc9d3d554..5337565d3b 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -621,7 +621,7 @@ module V85 = struct type autoinfo = { hints : hint_db; is_evar: existential_key option; only_classes: bool; unique : bool; - auto_depth: int list; auto_last_tac: std_ppcmds Lazy.t; + auto_depth: int list; auto_last_tac: Pp.t Lazy.t; auto_path : global_reference option list; auto_cut : hints_path } type autogoal = goal * autoinfo @@ -972,7 +972,7 @@ end module Search = struct type autoinfo = { search_depth : int list; - last_tac : Pp.std_ppcmds Lazy.t; + last_tac : Pp.t Lazy.t; search_dep : bool; search_only_classes : bool; search_cut : hints_path; @@ -1143,7 +1143,7 @@ module Search = struct let res = if j = 0 then tclUNIT () else tclDISPATCH - (List.init j (fun j' -> (tac_of gls i (Option.default 0 k + j)))) + (List.init j (fun j' -> (tac_of gls i (Option.default 0 k + j')))) in let finish nestedshelf sigma = let filter ev = diff --git a/tactics/eauto.ml b/tactics/eauto.ml index 64d4d3135e..65864bd472 100644 --- a/tactics/eauto.ml +++ b/tactics/eauto.ml @@ -203,7 +203,7 @@ type search_state = { priority : int; depth : int; (*r depth of search before failing *) tacres : goal list sigma; - last_tactic : std_ppcmds Lazy.t; + last_tactic : Pp.t Lazy.t; dblist : hint_db list; localdb : hint_db list; prev : prev_search_state; diff --git a/tactics/hints.mli b/tactics/hints.mli index 6325a44706..44e5370e93 100644 --- a/tactics/hints.mli +++ b/tactics/hints.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Pp open Util open Names open EConstr @@ -85,10 +84,10 @@ type hints_path = global_reference hints_path_gen val normalize_path : hints_path -> hints_path val path_matches : hints_path -> hints_path_atom list -> bool val path_derivate : hints_path -> hints_path_atom -> hints_path -val pp_hints_path_gen : ('a -> Pp.std_ppcmds) -> 'a hints_path_gen -> Pp.std_ppcmds -val pp_hints_path_atom : ('a -> Pp.std_ppcmds) -> 'a hints_path_atom_gen -> Pp.std_ppcmds -val pp_hints_path : hints_path -> Pp.std_ppcmds -val pp_hint_mode : hint_mode -> Pp.std_ppcmds +val pp_hints_path_gen : ('a -> Pp.t) -> 'a hints_path_gen -> Pp.t +val pp_hints_path_atom : ('a -> Pp.t) -> 'a hints_path_atom_gen -> Pp.t +val pp_hints_path : hints_path -> Pp.t +val pp_hint_mode : hint_mode -> Pp.t val glob_hints_path_atom : Libnames.reference hints_path_atom_gen -> Globnames.global_reference hints_path_atom_gen val glob_hints_path : @@ -261,12 +260,12 @@ val rewrite_db : hint_db_name (** Printing hints *) -val pr_searchtable : unit -> std_ppcmds -val pr_applicable_hint : unit -> std_ppcmds -val pr_hint_ref : global_reference -> std_ppcmds -val pr_hint_db_by_name : hint_db_name -> std_ppcmds -val pr_hint_db : Hint_db.t -> std_ppcmds -val pr_hint : hint -> Pp.std_ppcmds +val pr_searchtable : unit -> 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_db : Hint_db.t -> Pp.t +val pr_hint : hint -> Pp.t (** Hook for changing the initialization of auto *) diff --git a/tactics/ind_tables.ml b/tactics/ind_tables.ml index 0407c1e36a..7f087ea01a 100644 --- a/tactics/ind_tables.ml +++ b/tactics/ind_tables.ml @@ -123,14 +123,18 @@ let define internal id c p univs = let ctx = Evd.normalize_evar_universe_context univs in let c = Vars.subst_univs_fn_constr (Universes.make_opt_subst (Evd.evar_universe_context_subst ctx)) c in + let univs = Evd.evar_context_universe_context ctx in + let univs = + if p then Polymorphic_const_entry univs + else Monomorphic_const_entry univs + in let entry = { const_entry_body = Future.from_val ((c,Univ.ContextSet.empty), Safe_typing.empty_private_constants); const_entry_secctx = None; const_entry_type = None; - const_entry_polymorphic = p; - const_entry_universes = Evd.evar_context_universe_context ctx; + const_entry_universes = univs; const_entry_opaque = false; const_entry_inline_code = false; const_entry_feedback = None; diff --git a/tactics/ind_tables.mli b/tactics/ind_tables.mli index 005555caa0..f825c4f4a3 100644 --- a/tactics/ind_tables.mli +++ b/tactics/ind_tables.mli @@ -48,4 +48,4 @@ val find_scheme : ?mode:internal_flag -> 'a scheme_kind -> inductive -> constant val check_scheme : 'a scheme_kind -> inductive -> bool -val pr_scheme_kind : 'a scheme_kind -> Pp.std_ppcmds +val pr_scheme_kind : 'a scheme_kind -> Pp.t diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index 4ad9c6541d..2a04c413be 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Pp open Names open Term open EConstr @@ -19,7 +18,7 @@ open Tactypes (** Tacticals i.e. functions from tactics to tactics. *) val tclIDTAC : tactic -val tclIDTAC_MESSAGE : std_ppcmds -> tactic +val tclIDTAC_MESSAGE : Pp.t -> tactic val tclORELSE0 : tactic -> tactic -> tactic val tclORELSE : tactic -> tactic -> tactic val tclTHEN : tactic -> tactic -> tactic @@ -41,8 +40,8 @@ val tclSOLVE : tactic list -> tactic val tclTRY : tactic -> tactic val tclCOMPLETE : tactic -> tactic val tclAT_LEAST_ONCE : tactic -> tactic -val tclFAIL : int -> std_ppcmds -> tactic -val tclFAIL_lazy : int -> std_ppcmds Lazy.t -> tactic +val tclFAIL : int -> Pp.t -> tactic +val tclFAIL_lazy : int -> Pp.t Lazy.t -> tactic val tclDO : int -> tactic -> tactic val tclPROGRESS : tactic -> tactic val tclSHOWHYPS : tactic -> tactic @@ -160,9 +159,9 @@ module New : sig (* [tclFAIL n msg] fails with [msg] as an error message at level [n] (meaning that it will jump over [n] error catching tacticals FROM THIS MODULE. *) - val tclFAIL : int -> Pp.std_ppcmds -> 'a tactic + val tclFAIL : int -> Pp.t -> 'a tactic - val tclZEROMSG : ?loc:Loc.t -> Pp.std_ppcmds -> 'a tactic + val tclZEROMSG : ?loc:Loc.t -> Pp.t -> 'a tactic (** Fail with a [User_Error] containing the given message. *) val tclOR : unit tactic -> unit tactic -> unit tactic diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 8a95ad177d..cb905e749a 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -5004,8 +5004,9 @@ let cache_term_by_tactic_then ~opaque ?(goal_type=None) id gk tac tacK = in let cst = Impargs.with_implicit_protection cst () in let lem = - if const.Entries.const_entry_polymorphic then - let uctx = Univ.ContextSet.of_context const.Entries.const_entry_universes in + match const.Entries.const_entry_universes with + | Entries.Polymorphic_const_entry uctx -> + let uctx = Univ.ContextSet.of_context uctx in (** Hack: the kernel may generate definitions whose universe variables are not the same as requested in the entry because of constraints delayed in the body, even in polymorphic mode. We mimick what it does for now @@ -5014,7 +5015,8 @@ let cache_term_by_tactic_then ~opaque ?(goal_type=None) id gk tac tacK = let uctx = Univ.ContextSet.to_context (Univ.ContextSet.union uctx body_uctx) in let u = Univ.UContext.instance uctx in mkConstU (cst, EInstance.make u) - else mkConst cst + | Entries.Monomorphic_const_entry _ -> + mkConst cst in let evd = Evd.set_universe_context evd ectx in let open Safe_typing in diff --git a/tactics/term_dnet.ml b/tactics/term_dnet.ml index e90e1959ed..64ba38a51b 100644 --- a/tactics/term_dnet.ml +++ b/tactics/term_dnet.ml @@ -49,7 +49,7 @@ struct | DNil (* debug *) - let _pr_dconstr f : 'a t -> std_ppcmds = function + let _pr_dconstr f : 'a t -> Pp.t = function | DRel -> str "*" | DSort -> str "Sort" | DRef _ -> str "Ref" diff --git a/test-suite/bugs/closed/4709.v b/test-suite/bugs/closed/4709.v new file mode 100644 index 0000000000..a9edcc8043 --- /dev/null +++ b/test-suite/bugs/closed/4709.v @@ -0,0 +1,18 @@ + +(** Bug 4709 https://coq.inria.fr/bug/4709 + Extraction wasn't reducing primitive projections in types. *) + +Require Extraction. + +Set Primitive Projections. + +Record t := Foo { foo : Type }. +Definition ty := foo (Foo nat). + +(* Without proper reduction of primitive projections in + [extract_type], the type [ty] was extracted as [Tunknown]. + Let's check it isn't the case anymore. *) + +Parameter check : nat. +Extract Constant check => "(O:ty)". +Extraction TestCompile ty check. diff --git a/test-suite/bugs/closed/4720.v b/test-suite/bugs/closed/4720.v new file mode 100644 index 0000000000..9265b60c17 --- /dev/null +++ b/test-suite/bugs/closed/4720.v @@ -0,0 +1,46 @@ +(** Bug 4720 : extraction and "with" in module type *) + +Module Type A. + Parameter t : Set. +End A. + +Module A_instance <: A. + Definition t := nat. +End A_instance. + +Module A_private : A. + Definition t := nat. +End A_private. + +Module Type B. +End B. + +Module Type C (b : B). + Declare Module a : A. +End C. + +Module WithMod (a' : A) (b' : B) (c' : C b' with Module a := A_instance). +End WithMod. + +Module WithDef (a' : A) (b' : B) (c' : C b' with Definition a.t := nat). +End WithDef. + +Module WithModPriv (a' : A) (b' : B) (c' : C b' with Module a := A_private). +End WithModPriv. + +(* The initial bug report was concerning the extraction of WithModPriv + in Coq 8.4, which was suboptimal: it was compiling, but could have been + turned into some faulty code since A_private and c'.a were not seen as + identical by the extraction. + + In Coq 8.5 and 8.6, the extractions of WithMod, WithDef, WithModPriv + were all causing Anomaly or Assert Failure. This shoud be fixed now. +*) + +Require Extraction. + +Recursive Extraction WithMod. + +Recursive Extraction WithDef. + +Recursive Extraction WithModPriv. diff --git a/test-suite/bugs/closed/4844.v b/test-suite/bugs/closed/4844.v new file mode 100644 index 0000000000..f140939ccd --- /dev/null +++ b/test-suite/bugs/closed/4844.v @@ -0,0 +1,47 @@ + +(* Bug report 4844 (and 4824): + The Haskell extraction was erroneously considering [Any] and + [()] as convertible ([Tunknown] an [Tdummy] internally). *) + +(* A value with inner logical parts. + Its extracted type will be [Sum () ()]. *) + +Definition semilogic : True + True := inl I. + +(* Higher-order record, whose projection [ST] isn't expressible + as an Haskell (or OCaml) type. Hence [ST] is extracted as the + unknown type [Any] in Haskell. *) + +Record SomeType := { ST : Type }. + +Definition SomeTrue := {| ST := True |}. + +(* A first version of the issue: + [abstrSum] is extracted as [Sum Any Any], so an unsafeCoerce + is required to cast [semilogic] into [abstrSum SomeTrue]. *) + +Definition abstrSum (t : SomeType) := ((ST t) + (ST t))%type. + +Definition semilogic' : abstrSum SomeTrue := semilogic. + +(* A deeper version of the issue. + In the previous example, the extraction could have reduced + [abstrSum SomeTrue] into [True+True], solving the issue. + It might do so in future versions. But if we put an inductive + in the way, a reduction isn't helpful. *) + +Inductive box (t : SomeType) := Box : ST t + ST t -> box t. + +Definition boxed_semilogic : box SomeTrue := + Box SomeTrue semilogic. + +Require Extraction. +Extraction Language Haskell. +Recursive Extraction semilogic' boxed_semilogic. +(* Warning! To fully check that this bug is still closed, + you should run ghc on the extracted code: + +Extraction "bug4844.hs" semilogic' boxed_semilogic. +ghc bug4844.hs + +*) diff --git a/test-suite/bugs/closed/5177.v b/test-suite/bugs/closed/5177.v new file mode 100644 index 0000000000..231d103a59 --- /dev/null +++ b/test-suite/bugs/closed/5177.v @@ -0,0 +1,21 @@ +(* Bug 5177 https://coq.inria.fr/bug/5177 : + Extraction and module type containing application and "with" *) + +Module Type T. + Parameter t: Type. +End T. + +Module Type A (MT: T). + Parameter t1: Type. + Parameter t2: Type. + Parameter bar: MT.t -> t1 -> t2. +End A. + +Module MakeA(MT: T): A MT with Definition t1 := nat. + Definition t1 := nat. + Definition t2 := nat. + Definition bar (m: MT.t) (x:t1) := x. +End MakeA. + +Require Extraction. +Recursive Extraction MakeA. diff --git a/test-suite/bugs/closed/5315.v b/test-suite/bugs/closed/5315.v new file mode 100644 index 0000000000..f1f1b8c051 --- /dev/null +++ b/test-suite/bugs/closed/5315.v @@ -0,0 +1,10 @@ +Require Import Recdef. + +Function dumb_works (a:nat) {struct a} := + match (fun x => x) a with O => O | S n' => dumb_works n' end. + +Function dumb_nope (a:nat) {struct a} := + match (id (fun x => x)) a with O => O | S n' => dumb_nope n' end. + +(* This check is just present to ensure Function worked well *) +Check R_dumb_nope_complete.
\ No newline at end of file diff --git a/test-suite/output/Notations3.out b/test-suite/output/Notations3.out index ffea0819a5..a9ae74fd67 100644 --- a/test-suite/output/Notations3.out +++ b/test-suite/output/Notations3.out @@ -109,3 +109,9 @@ fun x : ?A => x === x : forall x : ?A, x = x where ?A : [x : ?A |- Type] (x cannot be used) +{0, 1} + : nat * nat +{0, 1, 2} + : nat * (nat * nat) +{0, 1, 2, 3} + : nat * (nat * (nat * nat)) diff --git a/test-suite/output/Notations3.v b/test-suite/output/Notations3.v index 250aecafd4..dee0f70f79 100644 --- a/test-suite/output/Notations3.v +++ b/test-suite/output/Notations3.v @@ -160,3 +160,11 @@ End Bug4765. Notation "x === x" := (eq_refl x) (only printing, at level 10). Check (fun x => eq_refl x). + +(**********************************************************************) +(* Test recursive notations with the recursive pattern repeated on the right *) + +Notation "{ x , .. , y , z }" := (pair x .. (pair y z) ..). +Check {0,1}. +Check {0,1,2}. +Check {0,1,2,3}. diff --git a/test-suite/output/TypeclassDebug.out b/test-suite/output/TypeclassDebug.out index 73369ab713..8b38fe0ff4 100644 --- a/test-suite/output/TypeclassDebug.out +++ b/test-suite/output/TypeclassDebug.out @@ -1,18 +1,18 @@ Debug: 1: looking for foo without backtracking Debug: 1.1: simple apply H on foo, 1 subgoal(s) -Debug: 1.1-2 : foo -Debug: 1.1-2: looking for foo without backtracking -Debug: 1.1-2.1: simple apply H on foo, 1 subgoal(s) -Debug: 1.1-2.1-2 : foo -Debug: 1.1-2.1-2: looking for foo without backtracking -Debug: 1.1-2.1-2.1: simple apply H on foo, 1 subgoal(s) -Debug: 1.1-2.1-2.1-2 : foo -Debug: 1.1-2.1-2.1-2: looking for foo without backtracking -Debug: 1.1-2.1-2.1-2.1: simple apply H on foo, 1 subgoal(s) -Debug: 1.1-2.1-2.1-2.1-2 : foo -Debug: 1.1-2.1-2.1-2.1-2: looking for foo without backtracking -Debug: 1.1-2.1-2.1-2.1-2.1: simple apply H on foo, 1 subgoal(s) -Debug: 1.1-2.1-2.1-2.1-2.1-2 : foo +Debug: 1.1-1 : foo +Debug: 1.1-1: looking for foo without backtracking +Debug: 1.1-1.1: simple apply H on foo, 1 subgoal(s) +Debug: 1.1-1.1-1 : foo +Debug: 1.1-1.1-1: looking for foo without backtracking +Debug: 1.1-1.1-1.1: simple apply H on foo, 1 subgoal(s) +Debug: 1.1-1.1-1.1-1 : foo +Debug: 1.1-1.1-1.1-1: looking for foo without backtracking +Debug: 1.1-1.1-1.1-1.1: simple apply H on foo, 1 subgoal(s) +Debug: 1.1-1.1-1.1-1.1-1 : foo +Debug: 1.1-1.1-1.1-1.1-1: looking for foo without backtracking +Debug: 1.1-1.1-1.1-1.1-1.1: simple apply H on foo, 1 subgoal(s) +Debug: 1.1-1.1-1.1-1.1-1.1-1 : foo The command has indeed failed with message: Ltac call to "typeclasses eauto (int_or_var_opt) with (ne_preident_list)" failed. Tactic failure: Proof search reached its limit. diff --git a/theories/Compat/Coq86.v b/theories/Compat/Coq86.v index f464608865..34061ddd6d 100644 --- a/theories/Compat/Coq86.v +++ b/theories/Compat/Coq86.v @@ -7,5 +7,7 @@ (************************************************************************) (** Compatibility file for making Coq act similar to Coq v8.6 *) +Require Export Coq.Compat.Coq87. + Require Export Coq.extraction.Extraction. Require Export Coq.funind.FunInd. diff --git a/theories/Compat/Coq87.v b/theories/Compat/Coq87.v new file mode 100644 index 0000000000..61e911678a --- /dev/null +++ b/theories/Compat/Coq87.v @@ -0,0 +1,9 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** Compatibility file for making Coq act similar to Coq v8.7 *) diff --git a/theories/FSets/FMapPositive.v b/theories/FSets/FMapPositive.v index b1c0fdaa2f..3e76649293 100644 --- a/theories/FSets/FMapPositive.v +++ b/theories/FSets/FMapPositive.v @@ -654,19 +654,19 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Lemma xelements_bits_lt_1 : forall p p0 q m v, List.In (p0,v) (xelements m (append p (xO q))) -> E.bits_lt p0 p. - Proof. + Proof using. intros. generalize (xelements_complete _ _ _ _ H); clear H; intros. - revert p0 q m v H. + revert p0 H. induction p; destruct p0; simpl; intros; eauto; try discriminate. Qed. Lemma xelements_bits_lt_2 : forall p p0 q m v, List.In (p0,v) (xelements m (append p (xI q))) -> E.bits_lt p p0. - Proof. + Proof using. intros. generalize (xelements_complete _ _ _ _ H); clear H; intros. - revert p0 q m v H. + revert p0 H. induction p; destruct p0; simpl; intros; eauto; try discriminate. Qed. diff --git a/theories/Numbers/Integer/Abstract/ZDivEucl.v b/theories/Numbers/Integer/Abstract/ZDivEucl.v index ce49877e4e..967b68d365 100644 --- a/theories/Numbers/Integer/Abstract/ZDivEucl.v +++ b/theories/Numbers/Integer/Abstract/ZDivEucl.v @@ -602,6 +602,14 @@ Proof. apply div_mod; order. Qed. +Lemma mod_div: forall a b, b~=0 -> + a mod b / b == 0. +Proof. + intros a b Hb. + rewrite div_small_iff by assumption. + auto using mod_always_pos. +Qed. + (** A last inequality: *) Theorem div_mul_le: diff --git a/theories/Numbers/Integer/Abstract/ZDivFloor.v b/theories/Numbers/Integer/Abstract/ZDivFloor.v index ca6197002c..a9077127ed 100644 --- a/theories/Numbers/Integer/Abstract/ZDivFloor.v +++ b/theories/Numbers/Integer/Abstract/ZDivFloor.v @@ -650,6 +650,14 @@ Proof. apply div_mod; order. Qed. +Lemma mod_div: forall a b, b~=0 -> + a mod b / b == 0. +Proof. + intros a b Hb. + rewrite div_small_iff by assumption. + auto using mod_bound_or. +Qed. + (** A last inequality: *) Theorem div_mul_le: diff --git a/theories/Numbers/Integer/Abstract/ZDivTrunc.v b/theories/Numbers/Integer/Abstract/ZDivTrunc.v index 46c36015dd..bbb8ad5ae9 100644 --- a/theories/Numbers/Integer/Abstract/ZDivTrunc.v +++ b/theories/Numbers/Integer/Abstract/ZDivTrunc.v @@ -622,6 +622,14 @@ Proof. apply quot_rem; order. Qed. +Lemma rem_quot: forall a b, b~=0 -> + a rem b รท b == 0. +Proof. + intros a b Hb. + rewrite quot_small_iff by assumption. + auto using rem_bound_abs. +Qed. + (** A last inequality: *) Theorem quot_mul_le: diff --git a/theories/ZArith/Zdiv.v b/theories/ZArith/Zdiv.v index 55fc90f212..fa1ddf56f2 100644 --- a/theories/ZArith/Zdiv.v +++ b/theories/ZArith/Zdiv.v @@ -508,6 +508,13 @@ Qed. (** Unfortunately, the previous result isn't always true on negative numbers. For instance: 3/(-2)/(-2) = 1 <> 0 = 3 / (-2*-2) *) +Lemma Zmod_div : forall a b, a mod b / b = 0. +Proof. + intros a b. + zero_or_not b. + auto using Z.mod_div. +Qed. + (** A last inequality: *) Theorem Zdiv_mult_le: diff --git a/tools/coqc.ml b/tools/coqc.ml index 0559d7b537..4595af6e88 100644 --- a/tools/coqc.ml +++ b/tools/coqc.ml @@ -91,11 +91,10 @@ let parse_args () = (* Options for coqtop : a) options with 0 argument *) - | ("-notactics"|"-bt"|"-debug"|"-nolib"|"-boot"|"-time"|"-profile-ltac" + | ("-bt"|"-debug"|"-nolib"|"-boot"|"-time"|"-profile-ltac" |"-batch"|"-noinit"|"-nois"|"-noglob"|"-no-glob" - |"-q"|"-full"|"-profile"|"-just-parsing"|"-echo" |"-unsafe"|"-quiet" - |"-silent"|"-m"|"-xml"|"-v7"|"-v8"|"-beautify"|"-strict-implicit" - |"-dont-load-proofs"|"-load-proofs"|"-force-load-proofs" + |"-q"|"-profile"|"-just-parsing"|"-echo" |"-quiet" + |"-silent"|"-m"|"-xml"|"-beautify"|"-strict-implicit" |"-impredicative-set"|"-vm"|"-native-compiler" |"-indices-matter"|"-quick"|"-type-in-type" |"-async-proofs-always-delegate"|"-async-proofs-never-reopen-branch" @@ -110,7 +109,7 @@ let parse_args () = |"-load-ml-source"|"-require"|"-load-ml-object" |"-init-file"|"-dump-glob"|"-compat"|"-coqlib"|"-top" |"-async-proofs-j" |"-async-proofs-private-flags" |"-async-proofs" |"-w" - |"-o"|"-profile-ltac-cutoff" + |"-o"|"-profile-ltac-cutoff" as o) :: rem -> begin match rem with diff --git a/tools/coqmktop.ml b/tools/coqmktop.ml index 30e098df59..28a3c791cb 100644 --- a/tools/coqmktop.ml +++ b/tools/coqmktop.ml @@ -175,8 +175,6 @@ let parse_args () = | "-top" :: rem -> top := true ; parse (op,fl) rem | "-no-start" :: rem -> no_start:=true; parse (op, fl) rem | "-echo" :: rem -> echo := true ; parse (op,fl) rem - | ("-v8"|"-full" as o) :: rem -> - Printf.eprintf "warning: option %s deprecated\n" o; parse (op,fl) rem (* Extra options with arity 0 or 1, directly passed to ocamlc/ocamlopt *) | ("-noassert"|"-compact"|"-g"|"-p"|"-thread"|"-dtypes" as o) :: rem -> diff --git a/toplevel/coqinit.ml b/toplevel/coqinit.ml index f61416dde1..326ef54715 100644 --- a/toplevel/coqinit.ml +++ b/toplevel/coqinit.ml @@ -127,7 +127,8 @@ let init_ocaml_path () = List.iter add_subdir Coq_config.all_src_dirs let get_compat_version ?(allow_old = true) = function - | "8.7" -> Flags.Current + | "8.8" -> Flags.Current + | "8.7" -> Flags.V8_7 | "8.6" -> Flags.V8_6 | "8.5" -> Flags.V8_5 | ("8.4" | "8.3" | "8.2" | "8.1" | "8.0") as s -> diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 86c0cbfa23..8fe27b3b97 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -138,8 +138,6 @@ let set_toplevel_name dir = if Names.DirPath.is_empty dir then user_err Pp.(str "Need a non empty toplevel module name"); toplevel_name := dir -let remove_top_ml () = Mltop.remove () - let warn_deprecated_inputstate = CWarnings.create ~name:"deprecated-inputstate" ~category:"deprecated" (fun () -> strbrk "The inputstate option is deprecated and discouraged.") @@ -209,6 +207,7 @@ let add_compat_require v = match v with | Flags.V8_5 -> add_require "Coq.Compat.Coq85" | Flags.V8_6 -> add_require "Coq.Compat.Coq86" + | Flags.V8_7 -> add_require "Coq.Compat.Coq87" | Flags.VOld | Flags.Current -> () let compile_list = ref ([] : (bool * string) list) @@ -588,21 +587,6 @@ let parse_args arglist = |"-where" -> print_where := true |"-xml" -> Flags.xml_export := true - (* Deprecated options *) - |"-byte" -> warning "option -byte deprecated, call with .byte suffix" - |"-opt" -> warning "option -opt deprecated, call with .opt suffix" - |"-full" -> warning "option -full deprecated" - |"-notactics" -> warning "Obsolete option \"-notactics\"."; remove_top_ml () - |"-emacs-U" -> - warning "Obsolete option \"-emacs-U\", use -emacs instead."; set_emacs () - |"-v7" -> user_err Pp.(str "This version of Coq does not support v7 syntax") - |"-v8" -> warning "Obsolete option \"-v8\"." - |"-lazy-load-proofs" -> warning "Obsolete option \"-lazy-load-proofs\"." - |"-dont-load-proofs" -> warning "Obsolete option \"-dont-load-proofs\"." - |"-force-load-proofs" -> warning "Obsolete option \"-force-load-proofs\"." - |"-unsafe" -> warning "Obsolete option \"-unsafe\"."; ignore (next ()) - |"-quality" -> warning "Obsolete option \"-quality\"." - (* Unknown option *) | s -> extras := s :: !extras end; @@ -613,6 +597,7 @@ let parse_args arglist = with any -> fatal_error any let init_toplevel arglist = + Profile.init_profile (); init_gc (); Sys.catch_break false; (* Ctrl-C is fatal during the initialisation *) let init_feeder = Feedback.add_feeder coqtop_init_feed in diff --git a/vernac/assumptions.ml b/vernac/assumptions.ml index 86bbf46a35..6711b14da0 100644 --- a/vernac/assumptions.ml +++ b/vernac/assumptions.ml @@ -311,10 +311,7 @@ let traverse current t = (** Hopefully bullet-proof function to recover the type of a constant. It just ignores all the universe stuff. There are many issues that can arise when considering terms out of any valid environment, so use with caution. *) -let type_of_constant cb = match cb.Declarations.const_type with -| Declarations.RegularArity ty -> ty -| Declarations.TemplateArity (ctx, arity) -> - Term.mkArity (ctx, Sorts.sort_of_univ arity.Declarations.template_level) +let type_of_constant cb = cb.Declarations.const_type let assumptions ?(add_opaque=false) ?(add_transparent=false) st gr t = let (idts, knst) = st in diff --git a/vernac/explainErr.ml b/vernac/explainErr.ml index 793a4c580f..2178a7caa0 100644 --- a/vernac/explainErr.ml +++ b/vernac/explainErr.ml @@ -18,7 +18,7 @@ let guill s = str "\"" ++ str s ++ str "\"" (** Invariant : exceptions embedded in EvaluatedError satisfy Errors.noncritical *) -exception EvaluatedError of std_ppcmds * exn option +exception EvaluatedError of Pp.t * exn option (** Registration of generic errors Nota: explain_exn does NOT end with a newline anymore! diff --git a/vernac/explainErr.mli b/vernac/explainErr.mli index 944339d851..0cbd71fa4f 100644 --- a/vernac/explainErr.mli +++ b/vernac/explainErr.mli @@ -7,7 +7,7 @@ (************************************************************************) (** Toplevel Exception *) -exception EvaluatedError of Pp.std_ppcmds * exn option +exception EvaluatedError of Pp.t * exn option (** Pre-explain a vernac interpretation error *) @@ -16,6 +16,6 @@ val process_vernac_interp_error : ?allow_uncaught:bool -> Util.iexn -> Util.iexn (** General explain function. Should not be used directly now, see instead function [Errors.print] and variants *) -val explain_exn_default : exn -> Pp.std_ppcmds +val explain_exn_default : exn -> Pp.t -val register_additional_error_info : (Util.iexn -> (Pp.std_ppcmds option Loc.located) option) -> unit +val register_additional_error_info : (Util.iexn -> (Pp.t option Loc.located) option) -> unit diff --git a/vernac/himsg.mli b/vernac/himsg.mli index b95ef8425a..5b91f9e682 100644 --- a/vernac/himsg.mli +++ b/vernac/himsg.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Pp open Indtypes open Environ open Type_errors @@ -18,28 +17,28 @@ open Logic (** This module provides functions to explain the type errors. *) -val explain_type_error : env -> Evd.evar_map -> type_error -> std_ppcmds +val explain_type_error : env -> Evd.evar_map -> type_error -> Pp.t -val explain_pretype_error : env -> Evd.evar_map -> pretype_error -> std_ppcmds +val explain_pretype_error : env -> Evd.evar_map -> pretype_error -> Pp.t -val explain_inductive_error : inductive_error -> std_ppcmds +val explain_inductive_error : inductive_error -> Pp.t -val explain_typeclass_error : env -> typeclass_error -> Pp.std_ppcmds +val explain_typeclass_error : env -> typeclass_error -> Pp.t -val explain_recursion_scheme_error : recursion_scheme_error -> std_ppcmds +val explain_recursion_scheme_error : recursion_scheme_error -> Pp.t -val explain_refiner_error : refiner_error -> std_ppcmds +val explain_refiner_error : refiner_error -> Pp.t val explain_pattern_matching_error : - env -> Evd.evar_map -> pattern_matching_error -> std_ppcmds + env -> Evd.evar_map -> pattern_matching_error -> Pp.t val explain_reduction_tactic_error : - Tacred.reduction_tactic_error -> std_ppcmds + Tacred.reduction_tactic_error -> Pp.t -val explain_module_error : Modops.module_typing_error -> std_ppcmds +val explain_module_error : Modops.module_typing_error -> Pp.t val explain_module_internalization_error : - Modintern.module_internalization_error -> std_ppcmds + Modintern.module_internalization_error -> Pp.t val map_pguard_error : ('c -> 'd) -> 'c pguard_error -> 'd pguard_error val map_ptype_error : ('c -> 'd) -> ('c, 'c) ptype_error -> ('d, 'd) ptype_error diff --git a/vernac/indschemes.ml b/vernac/indschemes.ml index 3d97a767c8..6ea8bc7f2c 100644 --- a/vernac/indschemes.ml +++ b/vernac/indschemes.ml @@ -109,13 +109,17 @@ let _ = let define id internal ctx c t = let f = declare_constant ~internal in + let _, univs = Evd.universe_context ctx in + let univs = + if Flags.is_universe_polymorphism () then Polymorphic_const_entry univs + else Monomorphic_const_entry univs + in let kn = f id (DefinitionEntry { const_entry_body = c; const_entry_secctx = None; const_entry_type = t; - const_entry_polymorphic = Flags.is_universe_polymorphism (); - const_entry_universes = snd (Evd.universe_context ctx); + const_entry_universes = univs; const_entry_opaque = false; const_entry_inline_code = false; const_entry_feedback = None; diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml index 567fc57fae..c0974d0a7c 100644 --- a/vernac/metasyntax.ml +++ b/vernac/metasyntax.ml @@ -615,46 +615,71 @@ let define_keywords = function let distribute a ll = List.map (fun l -> a @ l) ll - (* Expand LIST1(t,sep) into the combination of t and t;sep;LIST1(t,sep) - as many times as expected in [n] argument *) -let rec expand_list_rule typ tkl x n i hds ll = - if Int.equal i n then + (* Expand LIST1(t,sep);sep;t;...;t (with the trailing pattern + occurring p times, possibly p=0) into the combination of + t;sep;t;...;t;sep;t (p+1 times) + t;sep;t;...;t;sep;t;sep;t (p+2 times) + ... + t;sep;t;...;t;sep;t;...;t;sep;t (p+n times) + t;sep;t;...;t;sep;t;...;t;sep;t;LIST1(t,sep) *) + +let expand_list_rule typ tkl x n p ll = + let camlp4_message_name = Some (add_suffix x ("_"^string_of_int n)) in + let main = GramConstrNonTerminal (ETConstr typ, camlp4_message_name) in + let tks = List.map (fun x -> GramConstrTerminal x) tkl in + let rec aux i hds ll = + if i < p then aux (i+1) (main :: tks @ hds) ll + else if Int.equal i (p+n) then let hds = - GramConstrListMark (n,true) :: hds + GramConstrListMark (p+n,true,p) :: hds @ [GramConstrNonTerminal (ETConstrList (typ,tkl), Some x)] in distribute hds ll else - let camlp4_message_name = Some (add_suffix x ("_"^string_of_int n)) in - let main = GramConstrNonTerminal (ETConstr typ, camlp4_message_name) in - let tks = List.map (fun x -> GramConstrTerminal x) tkl in - distribute (GramConstrListMark (i+1,false) :: hds @ [main]) ll @ - expand_list_rule typ tkl x n (i+1) (main :: tks @ hds) ll + distribute (GramConstrListMark (i+1,false,p) :: hds @ [main]) ll @ + aux (i+1) (main :: tks @ hds) ll in + aux 0 [] ll + +let is_constr_typ typ x etyps = + match List.assoc x etyps with + | ETConstr typ' -> typ = typ' + | _ -> false + +let include_possible_similar_trailing_pattern typ etyps sl l = + let rec aux n = function + | Terminal s :: sl, Terminal s'::l' when s = s' -> aux n (sl,l') + | [], NonTerminal x ::l' when is_constr_typ typ x etyps -> try_aux n l' + | _ -> raise Exit + and try_aux n l = + try aux (n+1) (sl,l) + with Exit -> n,l in + try_aux 0 l let make_production etyps symbols = - let prod = - List.fold_right - (fun t ll -> match t with - | NonTerminal m -> - let typ = List.assoc m etyps in - distribute [GramConstrNonTerminal (typ, Some m)] ll - | Terminal s -> - distribute [GramConstrTerminal (CLexer.terminal s)] ll - | Break _ -> - ll - | SProdList (x,sl) -> - let tkl = List.flatten - (List.map (function Terminal s -> [CLexer.terminal s] - | Break _ -> [] - | _ -> anomaly (Pp.str "Found a non terminal token in recursive notation separator.")) sl) in - match List.assoc x etyps with - | ETConstr typ -> expand_list_rule typ tkl x 1 0 [] ll - | ETBinder o -> - distribute - [GramConstrNonTerminal (ETBinderList (o,tkl), Some x)] ll - | _ -> - user_err Pp.(str "Components of recursive patterns in notation must be terms or binders.")) - symbols [[]] in - List.map define_keywords prod + let rec aux = function + | [] -> [[]] + | NonTerminal m :: l -> + let typ = List.assoc m etyps in + distribute [GramConstrNonTerminal (typ, Some m)] (aux l) + | Terminal s :: l -> + distribute [GramConstrTerminal (CLexer.terminal s)] (aux l) + | Break _ :: l -> + aux l + | SProdList (x,sl) :: l -> + let tkl = List.flatten + (List.map (function Terminal s -> [CLexer.terminal s] + | Break _ -> [] + | _ -> anomaly (Pp.str "Found a non terminal token in recursive notation separator.")) sl) in + match List.assoc x etyps with + | ETConstr typ -> + let p,l' = include_possible_similar_trailing_pattern typ etyps sl l in + expand_list_rule typ tkl x 1 p (aux l') + | ETBinder o -> + distribute + [GramConstrNonTerminal (ETBinderList (o,tkl), Some x)] (aux l) + | _ -> + user_err Pp.(str "Components of recursive patterns in notation must be terms or binders.") in + let prods = aux symbols in + List.map define_keywords prods let rec find_symbols c_current c_next c_last = function | [] -> [] @@ -1056,7 +1081,7 @@ module SynData = struct extra : (string * string) list; (* XXX: Callback to printing, must remove *) - msgs : ((std_ppcmds -> unit) * std_ppcmds) list; + msgs : ((Pp.t -> unit) * Pp.t) list; (* Fields for internalization *) recvars : (Id.t * Id.t) list; diff --git a/vernac/metasyntax.mli b/vernac/metasyntax.mli index c9e37a4eb2..9cd00cbcb4 100644 --- a/vernac/metasyntax.mli +++ b/vernac/metasyntax.mli @@ -52,7 +52,7 @@ val add_syntactic_definition : Id.t -> Id.t list * constr_expr -> (** Print the Camlp4 state of a grammar *) -val pr_grammar : string -> Pp.std_ppcmds +val pr_grammar : string -> Pp.t type any_entry = AnyEntry : 'a Pcoq.Gram.entry -> any_entry diff --git a/vernac/mltop.mli b/vernac/mltop.mli index 3ecda656df..324a66d382 100644 --- a/vernac/mltop.mli +++ b/vernac/mltop.mli @@ -83,6 +83,6 @@ val declare_ml_modules : Vernacexpr.locality_flag -> string list -> unit (** {5 Utilities} *) -val print_ml_path : unit -> Pp.std_ppcmds -val print_ml_modules : unit -> Pp.std_ppcmds -val print_gc : unit -> Pp.std_ppcmds +val print_ml_path : unit -> Pp.t +val print_ml_modules : unit -> Pp.t +val print_gc : unit -> Pp.t diff --git a/vernac/obligations.ml b/vernac/obligations.ml index 10d3317f8d..28aeaa725e 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -636,12 +636,12 @@ let declare_obligation prg obl body ty uctx = shrink_body body ty else [], body, ty, [||] in let body = ((body,Univ.ContextSet.empty),Safe_typing.empty_private_constants) in + let univs = if poly then Polymorphic_const_entry uctx else Monomorphic_const_entry uctx in let ce = { const_entry_body = Future.from_val ~fix_exn:(fun x -> x) body; const_entry_secctx = None; const_entry_type = ty; - const_entry_polymorphic = poly; - const_entry_universes = uctx; + const_entry_universes = univs; const_entry_opaque = opaque; const_entry_inline_code = false; const_entry_feedback = None; @@ -818,8 +818,7 @@ let solve_by_tac name evi t poly ctx = id ~goal_kind:(goal_kind poly) ctx evi.evar_hyps concl (Tacticals.New.tclCOMPLETE t) in let env = Global.env () in let entry = Safe_typing.inline_private_constants_in_definition_entry env entry in - let body, eff = Future.force entry.const_entry_body in - assert(Safe_typing.empty_private_constants = eff); + let body, () = Future.force entry.const_entry_body in let ctx' = Evd.merge_context_set ~sideff:true Evd.univ_rigid (Evd.from_ctx ctx') (snd body) in Inductiveops.control_only_guard (Global.env ()) (fst body); (fst body), entry.const_entry_type, Evd.evar_universe_context ctx' @@ -836,8 +835,7 @@ let obligation_terminator name num guard hook auto pf = let env = Global.env () in let entry = Safe_typing.inline_private_constants_in_definition_entry env entry in let ty = entry.Entries.const_entry_type in - let (body, cstr), eff = Future.force entry.Entries.const_entry_body in - assert(Safe_typing.empty_private_constants = eff); + let (body, cstr), () = Future.force entry.Entries.const_entry_body in let sigma = Evd.from_ctx (fst uctx) in let sigma = Evd.merge_context_set ~sideff:true Evd.univ_rigid sigma cstr in Inductiveops.control_only_guard (Global.env ()) body; diff --git a/vernac/obligations.mli b/vernac/obligations.mli index fa691ad1b6..5614403ba5 100644 --- a/vernac/obligations.mli +++ b/vernac/obligations.mli @@ -10,7 +10,6 @@ open Environ open Term open Evd open Names -open Pp open Globnames (* This is a hack to make it possible for Obligations to craft a Qed @@ -96,12 +95,12 @@ val try_solve_obligations : Names.Id.t option -> unit Proofview.tactic option -> val show_obligations : ?msg:bool -> Names.Id.t option -> unit -val show_term : Names.Id.t option -> std_ppcmds +val show_term : Names.Id.t option -> Pp.t val admit_obligations : Names.Id.t option -> unit exception NoObligations of Names.Id.t option -val explain_no_obligations : Names.Id.t option -> Pp.std_ppcmds +val explain_no_obligations : Names.Id.t option -> Pp.t val set_program_mode : bool -> unit diff --git a/vernac/record.ml b/vernac/record.ml index 63ca227862..a2e443e5f7 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -322,13 +322,16 @@ let declare_projections indsp ?(kind=StructureComponent) binder_name coers field let projtyp = it_mkProd_or_LetIn (mkProd (x,rp,ccl)) paramdecls in try + let univs = + if poly then Polymorphic_const_entry ctx + else Monomorphic_const_entry ctx + in let entry = { const_entry_body = Future.from_val (Safe_typing.mk_pure_proof proj); const_entry_secctx = None; const_entry_type = Some projtyp; - const_entry_polymorphic = poly; - const_entry_universes = ctx; + const_entry_universes = univs; const_entry_opaque = false; const_entry_inline_code = false; const_entry_feedback = None } in diff --git a/vernac/topfmt.mli b/vernac/topfmt.mli index 6e006fc6c9..afe76f6f87 100644 --- a/vernac/topfmt.mli +++ b/vernac/topfmt.mli @@ -37,8 +37,8 @@ val set_margin : int option -> unit val get_margin : unit -> int option (** Console display of feedback, we may add some location information *) -val std_logger : ?pre_hdr:Pp.std_ppcmds -> Feedback.level -> Pp.std_ppcmds -> unit -val emacs_logger : ?pre_hdr:Pp.std_ppcmds -> Feedback.level -> Pp.std_ppcmds -> unit +val std_logger : ?pre_hdr:Pp.t -> Feedback.level -> Pp.t -> unit +val emacs_logger : ?pre_hdr:Pp.t -> Feedback.level -> Pp.t -> unit (** Color output *) val clear_styles : unit -> unit @@ -51,8 +51,8 @@ val init_terminal_output : color:bool -> unit (** Error printing *) (* To be deprecated when we can fully move to feedback-based error printing. *) -val pr_loc : Loc.t -> Pp.std_ppcmds -val print_err_exn : ?extra:Pp.std_ppcmds -> exn -> unit +val pr_loc : Loc.t -> Pp.t +val print_err_exn : ?extra:Pp.t -> exn -> unit (** [with_output_to_file file f x] executes [f x] with logging redirected to a file [file] *) diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 9650ea19d7..959df89f6e 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -257,7 +257,7 @@ let print_namespace ns = in let print_constant k body = (* FIXME: universes *) - let t = Typeops.type_of_constant_type (Global.env ()) body.Declarations.const_type in + let t = body.Declarations.const_type in print_kn k ++ str":" ++ spc() ++ Printer.pr_type t in let matches mp = match match_modulepath ns mp with @@ -2120,7 +2120,7 @@ let locate_if_not_already ?loc (e, info) = | Some l -> (e, info) exception HasNotFailed -exception HasFailed of std_ppcmds +exception HasFailed of Pp.t let with_fail b f = if not b then f () |