diff options
354 files changed, 5606 insertions, 5122 deletions
diff --git a/.gitignore b/.gitignore index 5340f081d..71de7bb8d 100644 --- a/.gitignore +++ b/.gitignore @@ -9,6 +9,7 @@ *.spot *.o *.a +*.pyc *.log *.aux *.dvi @@ -35,6 +36,10 @@ *.tacind *.v.tex *.v.ps +*.v.timing +*.v.timing.diff +*.v.before-timing +*.v.after-timing *.v.html *.stamp *.native @@ -55,6 +60,10 @@ plugins/micromega/csdpcert plugins/micromega/.micromega.ml.generated kernel/byterun/dllcoqrun.so coqdoc.sty +time-of-build.log +time-of-build-pretty.log +time-of-build-before.log +time-of-build-after.log .csdp.cache test-suite/.lia.cache test-suite/.nra.cache @@ -63,8 +72,9 @@ test-suite/misc/universes/all_stdlib.v test-suite/misc/universes/universes.txt test-suite/coq-makefile/*/actual test-suite/coq-makefile/*/desired -test-suite/coq-makefile/*/Makefile -test-suite/coq-makefile/*/Makefile.conf +test-suite/coq-makefile/**/*.processed +test-suite/coq-makefile/**/Makefile +test-suite/coq-makefile/**/Makefile.conf test-suite/coq-makefile/*/src test-suite/coq-makefile/*/theories test-suite/coq-makefile/*/theories2 diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index e1feabd06..8b43d975a 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -18,8 +18,10 @@ variables: # some useful values COMPILER_32BIT: "4.02.3+32bit" - COMPILER_BLEEDING_EDGE: "4.04.1" - CAMLP5_VER_BLEEDING_EDGE: "6.17" + COMPILER_BLEEDING_EDGE: "4.05.0" + CAMLP5_VER_BLEEDING_EDGE: "7.01" + + TEST_PACKAGES: "time python" COQIDE_PACKAGES: "libgtk2.0-dev libgtksourceview2.0-dev" #COQIDE_PACKAGES_32BIT: "libgtk2.0-dev:i386 libgtksourceview2.0-dev:i386" @@ -193,6 +195,8 @@ test-suite: <<: *test-suite-template dependencies: - build + variables: + EXTRA_PACKAGES: "$TEST_PACKAGES" test-suite:32bit: <<: *test-suite-template @@ -200,7 +204,7 @@ test-suite:32bit: - build:32bit variables: COMPILER: "$COMPILER_32BIT" - EXTRA_PACKAGES: "gcc-multilib" + EXTRA_PACKAGES: "gcc-multilib $TEST_PACKAGES" test-suite:bleeding-edge: <<: *test-suite-template @@ -209,6 +213,7 @@ test-suite:bleeding-edge: variables: COMPILER: "$COMPILER_BLEEDING_EDGE" CAMLP5_VER: "$CAMLP5_VER_BLEEDING_EDGE" + EXTRA_PACKAGES: "$TEST_PACKAGES" documentation: <<: *documentation-template diff --git a/.travis.yml b/.travis.yml index d2d779d8b..3cd7fdf5e 100644 --- a/.travis.yml +++ b/.travis.yml @@ -95,8 +95,8 @@ matrix: - env: - TEST_TARGET="test-suite" - - COMPILER="4.04.1" - - CAMLP5_VER="6.17" + - COMPILER="4.05.0" + - CAMLP5_VER="7.01" - EXTRA_CONF="-coqide opt -with-doc yes" - EXTRA_OPAM="lablgtk-extras hevea" addons: @@ -124,8 +124,8 @@ matrix: - env: - TEST_TARGET="coqocaml" - - COMPILER="4.04.1" - - CAMLP5_VER="6.17" + - COMPILER="4.05.0" + - CAMLP5_VER="7.01" - EXTRA_CONF="-coqide opt -warn-error" - EXTRA_OPAM="lablgtk-extras hevea" # dummy target @@ -144,6 +144,10 @@ matrix: before_install: - brew update - brew install opam + - brew install gnu-time + +before_install: +- if [ "${TRAVIS_PULL_REQUEST}" != "false" ]; then echo "Tested commit (followed by parent commits):"; git log -1; for commit in `git log -1 --format="%P"`; do echo; git log -1 $commit; done; fi install: - opam init -j ${NJOBS} --compiler=${COMPILER} -n -y diff --git a/API/API.ml b/API/API.ml index 093ca97f8..fd20167f2 100644 --- a/API/API.ml +++ b/API/API.ml @@ -6,198 +6,265 @@ (* * 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_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 *) +(* module Copcodes *) +(* module Cemitcodes *) +(* module Nativevalues *) +(* module Primitives *) +module Opaqueproof = Opaqueproof +module Declareops = Declareops +module Retroknowledge = Retroknowledge +(* module 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 *) +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 + +(******************************************************************************) +(* 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 -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 +(******************************************************************************) +(* Vernac *) +(******************************************************************************) +(* module Vernacprop *) +module Lemmas = Lemmas +module Himsg = Himsg +module ExplainErr = ExplainErr +(* module Class *) +module Locality = Locality +(* module 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 *) +module Mltop = Mltop +module Topfmt = Topfmt +module Vernacentries = Vernacentries -(* 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 +(******************************************************************************) +(* Stm *) +(******************************************************************************) +module Vernac_classifier = Vernac_classifier +module Stm = Stm diff --git a/API/API.mli b/API/API.mli index 029f458cc..309719539 100644 --- a/API/API.mli +++ b/API/API.mli @@ -6,150 +6,31 @@ (* * 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 - - (* API.Evar.Map.t *) - type evar_map = Evd.evar_map - - (* API.Globnames.global_reference *) - type global_reference = Globnames.global_reference - - type rigid = Evd.rigid = - | UnivRigid - | UnivFlexible of bool - - 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 -end - -module Univ : -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 +(* Warning, this file should respect the dependency order established + in Coq. To see such order issue the comand: - module Constraint : module type of struct include Univ.Constraint end + ``` + 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 + ``` - type 'a constrained = 'a * Constraint.t + 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. - module UContext : - sig - type t = Univ.UContext.t - val empty : t - end + See below in the file for their concrete position. +*) - 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 - - 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 - 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 : - 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 : +(************************************************************************) +(* Modules from config/ *) +(************************************************************************) +module Coq_config : 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 + val exec_extension : string end +(************************************************************************) +(* Modules from kernel/ *) +(************************************************************************) module Names : sig module Id : module type of struct include Names.Id end @@ -158,7 +39,7 @@ sig type t = Names.MBId.t val equal : t -> t -> bool val to_id : t -> Names.Id.t - val repr : t -> int * Names.Id.t * Names.DirPath.t + val repr : t -> int * Names.Id.t * Names.DirPath.t val debug_to_string : t -> string end @@ -169,7 +50,7 @@ sig 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"] @@ -395,9 +276,255 @@ sig module Idset : module type of struct include Id.Set end end -module Context : +module Univ : +sig + + module Level : + sig + type t = Univ.Level.t + val set : t + val pr : t -> Pp.std_ppcmds + end + + module LSet : module type of struct include Univ.LSet end + + module Universe : + sig + type t = Univ.Universe.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 + + type 'a constrained = 'a * Constraint.t + + module UContext : + sig + type t = Univ.UContext.t + val empty : t + end + + type universe_context = UContext.t + + module AUContext : + sig + type t = Univ.AUContext.t + val empty : t + end + + type abstract_universe_context = AUContext.t + + module CumulativityInfo : + sig + type t = Univ.CumulativityInfo.t + end + + type cumulativity_info = CumulativityInfo.t + + module ACumulativityInfo : + sig + type t = Univ.ACumulativityInfo.t + end + type abstract_cumulativity_info = ACumulativityInfo.t + + module ContextSet : + sig + type t = Univ.ContextSet.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 constraint_type = Univ.constraint_type + + type universe_context_set = ContextSet.t + + type universe_set = 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 UGraph : sig + type t = UGraph.t + val pr_universes : (Univ.Level.t -> Pp.std_ppcmds) -> t -> Pp.std_ppcmds +end + +module Esubst : +sig + type 'a subs = 'a Esubst.subs + val subs_id : int -> 'a subs +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 Evar : +sig + (** Unique identifier of some {i evar} *) + type t = Evar.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 : module type of struct include Evar.Set end +end + +module Constr : +sig + open Names + + type t = Constr.t + + type constr = t + type types = t + + type cast_kind = Constr.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 = Constr.case_style = + LetStyle | IfStyle | LetPatternStyle | MatchStyle + | RegularStyle (** infer printing form from number of constructor *) + + type case_printing = Constr.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 = Constr.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 = ('constr, 'types, 'sort, 'univs) Constr.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 : @@ -408,7 +535,7 @@ sig | 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 @@ -445,7 +572,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 @@ -502,7 +629,7 @@ sig | 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 @@ -599,13 +726,34 @@ 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 contents = Sorts.contents = Pos | Null type sorts = Sorts.t = @@ -613,15 +761,20 @@ 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 @@ -632,26 +785,30 @@ sig | 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_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 @@ -666,7 +823,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 @@ -680,7 +837,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 @@ -760,18 +917,19 @@ sig *) val eq_constr_nounivs : constr -> constr -> bool - type ('constr, 'types) kind_of_type = ('constr, 'types) Term.kind_of_type = + 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 + 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 @@ -792,181 +950,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 - 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 @@ -974,13 +964,73 @@ 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 end +module Opaqueproof : +sig + type opaquetab = Opaqueproof.opaquetab + type opaque = Opaqueproof.opaque + val empty_opaquetab : opaquetab + val force_proof : opaquetab -> opaque -> Constr.t +end + +module Decl_kinds : +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 +end + module Retroknowledge : sig type action = Retroknowledge.action @@ -1037,7 +1087,7 @@ sig type inline = Declarations.inline type constant_def = Declarations.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 = { template_param_levels : Univ.Level.t option list; @@ -1048,15 +1098,15 @@ sig | RegularArity of 'a | TemplateArity of 'b - type constant_type = (Prelude.types, Context.Rel.t * template_arity) declaration_arity + type constant_type = (Constr.types, Context.Rel.t * template_arity) declaration_arity type constant_universes = Declarations.constant_universes type projection_body = Declarations.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 @@ -1075,11 +1125,11 @@ sig mind_arity_ctxt : Context.Rel.t; mind_arity : Declarations.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,16 +1142,17 @@ sig | MoreFunctor of Names.MBId.t * 'ty * ('ty,'a) functorize type with_declaration = Declarations.with_declaration = | WithMod of Names.Id.t list * Names.ModPath.t - | WithDef of Names.Id.t list * Term.constr Univ.in_universe_context + | WithDef of Names.Id.t list * Constr.t Univ.in_universe_context + type module_alg_expr = Declarations.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 + | 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 = { mind_packets : one_inductive_body array; @@ -1141,15 +1192,42 @@ sig | 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 + type mutual_inductive_entry = Entries.mutual_inductive_entry + 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 '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 : Constr.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 * Constr.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 end module Environ : sig - type env = Prelude.env - type named_context_val = Prelude.named_context_val + type env = Environ.env + type named_context_val = Environ.named_context_val type ('constr, 'types) punsafe_judgment = ('constr, 'types) Environ.punsafe_judgment = { uj_val : 'constr; @@ -1179,63 +1257,107 @@ 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 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 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 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 = 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 + end + 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 = Reduction.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 - - val closedn : int -> Term.constr -> bool - - val replace_vars : (Names.Id.t * Term.constr) list -> Term.constr -> Term.constr + type type_error = Type_errors.type_error + 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 : @@ -1244,7 +1366,7 @@ 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 : @@ -1254,144 +1376,575 @@ sig 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_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 = Safe_typing.private_constants + val mk_pure_proof : Constr.t -> Safe_typing.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 = '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 end -module Mod_typing : +module Extend : 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 ('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 end -module Esubst : +module Locus : sig - type 'a subs = 'a Esubst.subs - val subs_id : int -> 'a subs + 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 end -module CClosure : +(************************************************************************) +(* End Modules from intf/ *) +(************************************************************************) + +(************************************************************************) +(* Modules from library/ *) +(************************************************************************) + +module Univops : 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 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 Nameops : +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 pr_name : Names.Name.t -> Pp.std_ppcmds + [@@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.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 - 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 + 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 - val create_clos_infos : ?evars:(Term.existential -> Term.constr option) -> RedFlags.reds -> Environ.env -> clos_infos + 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 - val whd_val : clos_infos -> fconstr -> Term.constr + type reference = Libnames.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 - val inject : Term.constr -> fconstr + type object_name = Libnames.full_path * Names.KerName.t + type object_prefix = Names.DirPath.t * (Names.ModPath.t * Names.DirPath.t) - val kl : clos_infos -> fconstr -> Term.constr - val term_of_fconstr : fconstr -> Term.constr + 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 Type_errors : +module Globnames : sig - type type_error = Type_errors.type_error - exception TypeError of Environ.env * type_error + 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 extended_global_reference = Globnames.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 : 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 + + 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 : Globnames.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 = 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 - (** Recover the underlying integer. *) - val repr : t -> int +module Summary : +sig - val equal : t -> t -> bool + type frozen = Summary.frozen - (** a set of unique identifiers of some {i evars} *) - module Set : module type of struct include Evar.Set end + 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 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 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 = 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 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 = '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 +end + +module Keys : +sig + type key = Keys.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.std_ppcmds) -> Pp.std_ppcmds +end + +module Coqlib : +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 +end + +(************************************************************************) +(* End of modules from library/ *) +(************************************************************************) + +(************************************************************************) +(* Modules from engine/ *) +(************************************************************************) + +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 : 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.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 + + type universe_constraints = Constraints.t +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 + + type rigid = UState.rigid = + | UnivRigid + | UnivFlexible of bool + +end + +module Evar_kinds : +sig + type obligation_definition_status = Evar_kinds.obligation_definition_status = + | Define of bool + | Expand + + type matching_var_kind = Evar_kinds.matching_var_kind = + | FirstOrderPatVar of Names.Id.t + | SecondOrderPatVar of Names.Id.t + + 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 Evd.evar 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 (* --------------------------------- *) @@ -1412,24 +1965,24 @@ sig (** This value defines the refinement of a given {i evar} *) type evar_body = Evd.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 = { - 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 @@ -1437,39 +1990,38 @@ sig (* evar map *) - type evar_map = Prelude.evar_map - type open_constr = evar_map * Term.constr + type evar_map = Evd.evar_map + type open_constr = evar_map * Constr.t - type rigid = Prelude.rigid = + type rigid = UState.rigid = | UnivRigid - | UnivFlexible of bool + | UnivFlexible of bool - type 'a freelisted = 'a Evd.freelisted = { rebus : 'a; freemetas : Evd.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 + | 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 @@ -1478,24 +2030,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 @@ -1524,12 +2076,12 @@ sig type unsolvability_explanation = Evd.unsolvability_explanation = | SeveralInstancesFound of int - + module Metaset : module type of struct include Evd.Metaset end - with type elt = Prelude.metavariable + with type elt = Constr.metavariable (** 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"] @@ -1540,14 +2092,367 @@ 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 +module Constrexpr : +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 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 = Constrexpr.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 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 + + 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 = Constrexpr.recursion_order_expr = + | CStructRec + | CWfRec of constr_expr + | CMeasureRec of constr_expr * constr_expr option + + 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 + + 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 = 'a Genredexpr.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 = '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 + } + + (** Generic kinds of reductions *) + 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 + + 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 + + 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 + +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 Constr.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 : 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 = 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 : 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 = 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 + + (** 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 (** *) @@ -1579,10 +2484,82 @@ 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.std_ppcmds + + val print_constr : EConstr.constr -> Pp.std_ppcmds + + (** [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.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 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.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 module Proofview_monad : @@ -1594,39 +2571,52 @@ sig 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 nf_hyps : Evd.evar_map -> goal -> Environ.named_context_val + val e_new_global : Evd.evar_map ref -> Globnames.global_reference -> EConstr.constr - val env : Evd.evar_map -> goal -> Environ.env + 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 concl : Evd.evar_map -> goal -> EConstr.constr + val mk_new_meta : unit -> EConstr.constr - val mk_goal : Evd.evar_map -> - Environ.named_context_val -> - EConstr.constr -> - Evd.Store.t -> - goal * EConstr.constr * Evd.evar_map + (** [new_meta] is a generator of unique meta variables *) + val new_meta : unit -> Constr.metavariable - val extra : Evd.evar_map -> goal -> Evd.Store.t + 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 partial_solution_to : Evd.evar_map -> goal -> goal -> EConstr.constr -> Evd.evar_map + 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 : Evd.evar_map -> 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 hyps : Evd.evar_map -> goal -> Environ.named_context_val + 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 abstract_type : Evd.evar_map -> goal -> EConstr.types - end + 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 -> 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 : @@ -1658,7 +2648,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 @@ -1685,20 +2675,20 @@ 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 : @@ -1766,54 +2756,6 @@ 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 : @@ -1856,426 +2798,441 @@ 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 = 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 - 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 = Glob_term.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 = Glob_term.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 = 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 } + + (** 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 matching_var_kind = Evar_kinds.matching_var_kind = - | FirstOrderPatVar of Names.Id.t - | SecondOrderPatVar of Names.Id.t + 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 - 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 : +(************************************************************************) +(* 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 = 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 - 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 = 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 + + 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 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 = 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 : 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 = 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 +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 + 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 : 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 - and constr_notation_substitution = - constr_expr list * - constr_expr list list * - local_binder_expr list list +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 - 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 +module Typing : +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 + + val e_type_of : ?refresh:bool -> Environ.env -> Evd.evar_map ref -> EConstr.constr -> EConstr.types end -module Goptions : +module Miscops : 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 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 -module Locus : +module Stm : 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 + type state = Stm.state + val state_of_id : + Stateid.t -> [ `Valid of state option | `Expired | `Error of exn ] end -module Genredexpr : +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 - (** The parsing produces initially a list of [red_atom] *) + (** Conversion from glob_constr to cases pattern, if possible - type 'a red_atom = 'a Genredexpr.red_atom = - | FBeta - | FMatch - | FFix - | FCofix - | FZeta - | FConst of 'a list - | FDeltaBut of 'a list + 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 - (** This list of atoms is immediately converted to a [glob_red_flag] *) + val empty_lvar : Glob_term.ltac_var_map - 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 - } +end - (** Generic kinds of reductions *) +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) 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 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 ('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 Constr_matching : +sig + val special_meta : Constr.metavariable - 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 + 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 Vernacexpr : sig type instance_flag = bool option @@ -2289,9 +3246,7 @@ sig type locality_flag = bool type inductive_kind = Vernacexpr.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 = | VtStartProof of vernac_start | VtSideff of vernac_sideff_type @@ -2322,7 +3277,7 @@ sig and solving_tac = bool and anon_abstracting_tac = bool and proof_block_name = string - type vernac_when = Vernacexpr.vernac_when = + type vernac_when = Vernacexpr.vernac_when = | VtNow | VtLater type verbose_flag = bool @@ -2349,12 +3304,10 @@ sig 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 = | 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 @@ -2363,7 +3316,6 @@ sig 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 extend_name = string * int type simple_binder = Vernacexpr.simple_binder type option_value = Vernacexpr.option_value @@ -2379,15 +3331,33 @@ sig 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 'a hint_info_gen = 'a Vernacexpr.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 = Vernacexpr.hints_expr = - | HintsResolve of (hint_info_expr * bool * reference_or_constr) list + | HintsResolve of (Vernacexpr.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 'a module_signature = 'a Vernacexpr.module_signature = + | Enforce of 'a (** ... : T *) + | Check of 'a list (** ... <: T1 <: T2, possibly empty *) + + type inline = Vernacexpr.inline = + | NoInline + | DefaultInline + | InlineAt of int + type vernac_expr = Vernacexpr.vernac_expr = | VernacLoad of verbose_flag * string | VernacTime of vernac_expr Loc.located @@ -2424,10 +3394,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 @@ -2437,11 +3407,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 * @@ -2462,26 +3432,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 @@ -2530,433 +3500,67 @@ 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 unsafe_type_of_global : Globnames.global_reference -> Term.types - val constr_of_global : Prelude.global_reference -> Term.constr - val new_univ_level : Names.DirPath.t -> Univ.Level.t - val unsafe_constr_of_global : Globnames.global_reference -> Term.constr Univ.in_universe_context - 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 type_of_global_unsafe : Globnames.global_reference -> Term.types - - val current_dirpath : unit -> Names.DirPath.t - val body_of_constant_body : Declarations.constant_body -> Term.constr option - val body_of_constant : Names.Constant.t -> Term.constr 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 - - 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 : -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 - -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.ContextSet.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 -module Retyping : (* reconstruct the type of a term knowing that it was already typechecked *) +module Typeclasses : 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 + 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; + } + 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 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 = Classops.coe_index + type inheritance_path = coe_index list + type cl_index = Classops.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.std_ppcmds 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 : @@ -2988,7 +3592,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 : @@ -3000,14 +3604,6 @@ 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 = @@ -3040,77 +3636,13 @@ sig Environ.env -> Evd.evar_map -> ?flags:unify_flags -> EConstr.constr * EConstr.constr -> Evd.evar_map * EConstr.constr end -module Typeclasses : -sig - type typeclass = Typeclasses.typeclass = { - 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 = 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 - - 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 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 +(************************************************************************) +(* End of modules from pretyping/ *) +(************************************************************************) -module Dumpglob : -sig - val add_glob : ?loc:Loc.t -> Globnames.global_reference -> unit - val pause : unit -> unit - val continue : unit -> unit -end +(************************************************************************) +(* Modules from interp/ *) +(************************************************************************) module Stdarg : sig @@ -3121,18 +3653,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 @@ -3148,83 +3680,90 @@ 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 = Ppextend.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.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 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 : @@ -3257,9 +3796,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 -> @@ -3274,157 +3813,142 @@ sig val global_reference : Names.Id.t -> Globnames.global_reference end -module Notation_term : +module Constrextern : 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 + 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 Notation : +module Declare : 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 + 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: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 -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 +(************************************************************************) +(* End of modules from interp/ *) +(************************************************************************) -module Redexpr : +(************************************************************************) +(* Modules from proofs/ *) +(************************************************************************) + +module Miscprint : 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 + 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 -module Tacmach : +(* All items in the Goal modules are deprecated. *) +module Goal : sig - type tactic = Goal.goal Evd.sigma -> Goal.goal list Evd.sigma - - type 'a sigma = 'a Evd.sigma - [@@ocaml.deprecated "alias of API.Evd.sigma"] - - val re_sig : 'a -> Evd.evar_map -> 'a Evd.sigma - - val pf_reduction_of_red_expr : Goal.goal Evd.sigma -> Redexpr.red_expr -> EConstr.constr -> Evd.evar_map * EConstr.constr - - val pf_unsafe_type_of : Goal.goal Evd.sigma -> EConstr.constr -> EConstr.types - - val pf_get_new_id : Names.Id.t -> Goal.goal Evd.sigma -> Names.Id.t - - val pf_env : Goal.goal Evd.sigma -> Environ.env - - val pf_concl : Goal.goal Evd.sigma -> EConstr.types - - val pf_apply : (Environ.env -> Evd.evar_map -> 'a) -> Goal.goal Evd.sigma -> 'a - - 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 + type goal = Evar.t - val pf_hyps : Goal.goal Evd.sigma -> EConstr.named_context + val pr_goal : goal -> Pp.std_ppcmds - 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 = Proof_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 = Logic.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 : @@ -3444,6 +3968,11 @@ sig end end +module Proof_bullet : +sig + val get_default_goal_selector : unit -> Vernacexpr.goal_selector +end + module Proof_global : sig type proof_mode = Proof_global.proof_mode = { @@ -3478,7 +4007,6 @@ sig (unit Proofview.tactic -> Proof.proof -> Proof.proof) -> unit val compact_the_proof : unit -> unit val register_proof_mode : proof_mode -> unit - val get_default_goal_selector : unit -> Vernacexpr.goal_selector exception NoCurrentProof val give_me_the_proof : unit -> Proof.proof @@ -3489,382 +4017,186 @@ 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 + val tclSHOWHYPS : Proof_type.tactic -> Proof_type.tactic exception FailError of int * Pp.std_ppcmds 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.std_ppcmds -> 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 - (** [dependent m t] tests whether [m] is a subterm of [t] *) - val dependent : Prelude.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 + type tactic = Proof_type.tactic - (** Does a given term contain an existential variable? *) - val occur_existential : Prelude.evar_map -> EConstr.constr -> bool + type 'a sigma = 'a Evd.sigma + [@@ocaml.deprecated "alias of API.Evd.sigma"] - (** [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 re_sig : 'a -> Evd.evar_map -> 'a Evd.sigma - (** 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_reduction_of_red_expr : Goal.goal Evd.sigma -> Redexpr.red_expr -> EConstr.constr -> Evd.evar_map * EConstr.constr - (** [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_unsafe_type_of : Goal.goal Evd.sigma -> EConstr.constr -> EConstr.types - (** [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_get_new_id : Names.Id.t -> Goal.goal Evd.sigma -> Names.Id.t - (** [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_env : Goal.goal Evd.sigma -> Environ.env - type meta_value_map = Prelude.meta_value_map + val pf_concl : Goal.goal Evd.sigma -> 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_apply : (Environ.env -> Evd.evar_map -> 'a) -> Goal.goal Evd.sigma -> 'a - val eq_constr : Evd.evar_map -> EConstr.constr -> EConstr.constr -> bool + 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 occur_var_in_decl : - Environ.env -> Evd.evar_map -> - Names.Id.t -> EConstr.named_declaration -> bool + val pf_hyps : Goal.goal Evd.sigma -> EConstr.named_context - val subst_meta : Prelude.meta_value_map -> Term.constr -> Term.constr + val pf_ids_of_hyps : Goal.goal Evd.sigma -> Names.Id.t list - val free_rels : Evd.evar_map -> EConstr.constr -> Int.Set.t + val pf_reduce_to_atomic_ind : Goal.goal Evd.sigma -> EConstr.types -> (Names.inductive * EConstr.EInstance.t) * EConstr.types - val occur_term : Evd.evar_map -> EConstr.constr -> EConstr.constr -> bool - [@@ocaml.deprecated "alias of API.Termops.dependent"] + val pf_reduce_to_quantified_ind : Goal.goal Evd.sigma -> EConstr.types -> (Names.inductive * EConstr.EInstance.t) * EConstr.types - 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_eapply : (Environ.env -> Evd.evar_map -> 'a -> Evd.evar_map * 'b) -> + Evar.t Evd.sigma -> 'a -> Evar.t Evd.sigma * 'b -module Locality : -sig - val make_section_locality : bool option -> bool - module LocalityFixme : sig - val consume : unit -> bool option - end - val make_module_locality : bool option -> bool -end + val pf_unfoldn : (Locus.occurrences * Names.evaluable_global_reference) list + -> Goal.goal Evd.sigma -> EConstr.constr -> EConstr.constr -module Search : -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 pf_reduce : (Environ.env -> Evd.evar_map -> EConstr.constr -> EConstr.constr) -> Goal.goal Evd.sigma -> EConstr.constr -> EConstr.constr -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 pf_conv_x : Goal.goal Evd.sigma -> EConstr.constr -> EConstr.constr -> bool -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 + val pf_is_matching : Goal.goal Evd.sigma -> Pattern.constr_pattern -> EConstr.constr -> bool -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 pf_hyps_types : Goal.goal Evd.sigma -> (Names.Id.t * EConstr.types) list -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_gls : 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 pf_nf_betaiota : Goal.goal Evd.sigma -> EConstr.constr -> EConstr.constr - val pr_constr : Term.constr -> Pp.std_ppcmds + val pf_last_hyp : Goal.goal Evd.sigma -> EConstr.named_declaration - val pr_lconstr : Term.constr -> Pp.std_ppcmds + val pf_nth_hyp_id : Goal.goal Evd.sigma -> int -> Names.Id.t - 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 sig_it : 'a Evd.sigma -> 'a - 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 -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 Classes : -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 + 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 end -module Classops : +module Pfedit : sig - type coe_index = Classops.coe_index - type inheritance_path = coe_index list - type cl_index = Classops.cl_index + 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)) - 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 + val get_current_context : unit -> Evd.evar_map * Environ.env -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 -end + (* Deprecated *) + val delete_current_proof : unit -> unit + [@@ocaml.deprecated "use Proof_global.discard_current"] -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 + val get_current_proof_name : unit -> Names.Id.t + [@@ocaml.deprecated "use Proof_global.get_current_proof_name"] -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 -module Constrexpr_ops : +module Clenv : 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 + 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 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 +(************************************************************************) +(* End of modules from proofs/ *) +(************************************************************************) - (** Conversion from glob_constr to cases pattern, if possible +(************************************************************************) +(* Modules from parsing/ *) +(************************************************************************) - 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 -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 -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 +(************************************************************************) +(* End of modules from parsing/ *) +(************************************************************************) -module Himsg : -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 -end +(************************************************************************) +(* Modules from printing/ *) +(************************************************************************) -module Extend : +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.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 end module Pputils : @@ -3899,80 +4231,170 @@ sig val pr_glob_sort : Misctypes.glob_sort -> Pp.std_ppcmds 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 -end + 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 -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 + val pr_constr_env : Environ.env -> Evd.evar_map -> Constr.t -> Pp.std_ppcmds + val pr_lconstr_env : Environ.env -> Evd.evar_map -> Constr.t -> Pp.std_ppcmds -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 + val pr_constr : Constr.t -> Pp.std_ppcmds -module Stateid : -sig - type t = Stateid.t - module Self : module type of struct include Stateid.Self end + val pr_lconstr : Constr.t -> 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 end -module Stm : +(************************************************************************) +(* End of modules from printing/ *) +(************************************************************************) + +(************************************************************************) +(* Modules from tactics/ *) +(************************************************************************) + +module Tacticals : sig - type state = Stm.state - val state_of_id : - Stateid.t -> [ `Valid of state option | `Expired | `Error of exn ] + open Proof_type + + 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 -> 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.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 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 = Ind_tables.individual + type 'a scheme_kind = 'a Ind_tables.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.std_ppcmds +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 : @@ -4011,7 +4433,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 @@ -4021,7 +4443,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 : @@ -4086,8 +4508,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 @@ -4104,7 +4526,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 @@ -4140,83 +4562,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 : @@ -4267,7 +4618,7 @@ sig 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 : @@ -4293,24 +4644,29 @@ 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 : @@ -4377,15 +4733,15 @@ 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 glob_hints_path_atom : - Prelude.reference hints_path_atom_gen -> Globnames.global_reference hints_path_atom_gen + Libnames.reference hints_path_atom_gen -> Globnames.global_reference hints_path_atom_gen val pp_hints_path : hints_path -> Pp.std_ppcmds 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 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 @@ -4412,140 +4768,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 @@ -4557,7 +4779,7 @@ 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 : @@ -4578,23 +4800,43 @@ 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.std_ppcmds 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.std_ppcmds + val pr_rec_definition : (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) -> Pp.std_ppcmds end module Lemmas : @@ -4605,7 +4847,7 @@ sig 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 @@ -4613,152 +4855,62 @@ sig val get_current_context : unit -> Evd.evar_map * Environ.env end -module Eqdecide : -sig - val compare : EConstr.constr -> EConstr.constr -> unit Proofview.tactic - val decideEqualityGoal : unit Proofview.tactic -end - -module Locusops : +module Himsg : 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 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 end -module Topfmt : +module ExplainErr : sig - val std_ft : Format.formatter ref - val with_output_to : out_channel -> Format.formatter - val get_margin : unit -> int option + 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 end -module Nameops : +module Locality : 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 pr_name : Names.Name.t -> Pp.std_ppcmds - [@@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.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 + 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 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 - val body_of_constant : - Opaqueproof.opaquetab -> Declarations.constant_body -> Term.constr option -end - -module Constr : -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"] -end -[@@ocaml.deprecated "alias of API.Term"] - -module Coq_config : -sig - val exec_extension : string -end - -module Kindops : +module Search : sig - val logical_kind_of_goal_kind : Decl_kinds.goal_object_kind -> Decl_kinds.logical_kind + 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 -> 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 States : +module Obligations : sig - val with_state_protection_on_exception : ('a -> 'b) -> 'a -> 'b - val with_state_protection : ('a -> 'b) -> 'a -> 'b + 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 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 recursive_preentry = Names.Id.t list * Constr.t option list * Constr.types list type structured_inductive_expr = Command.structured_inductive_expr type one_inductive_impls = Command.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 -> @@ -4774,7 +4926,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 : @@ -4793,14 +4945,65 @@ 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 Mltop : sig - val replace_vars_constr_expr : - Names.Id.t Names.Id.Map.t -> Constrexpr.constr_expr -> Constrexpr.constr_expr + 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 + +(************************************************************************) +(* End of modules from stm/ *) +(************************************************************************) @@ -6,6 +6,17 @@ Tactics - New tactic "extensionality in H" which applies (possibly dependent) functional extensionality in H supposed to be a quantified equality until giving a bare equality. +- New tactic "inversion_sigma" which turns equalities of dependent + pairs (e.g., "existT P x p = existT P y q", frequently left over by + "inversion" on a dependent type family) into pairs of equalities + (e.g., a hypothesis "H : x = y" and a hypothesis of type "rew H in p + = q"); these hypotheses can subsequently be simplified using + "subst", without ever invoking any kind of axiom asserting + uniqueness of identity proofs. If you want to explicitly specify the + hypothesis to be inverted, or name the generated hypotheses, you can + invoke "induction H as [H1 H2] using eq_sigT_rect". The tactic also + works for "sig", "sigT2", and "sig2", and there are similar + "eq_sig*_rect" induction lemmas. - Tactic "specialize with ..." now accepts any partial bindings. Missing bindings are either solved by unification or left quantified in the hypothesis. @@ -84,6 +95,11 @@ Tools The current version contains code for retro compatibility that prints warnings when a deprecated feature is used. Please upgrade your _CoqProject accordingly. + * Additionally, coq_makefile-made Makefiles now support experimental timing + targets `pretty-timed`, `pretty-timed-before`, `pretty-timed-after`, + `print-pretty-timed-diff`, `print-pretty-single-time-diff`, + `all.timing.diff`, and the variable `TIMING=1` (or `TIMING=before` or + `TIMING=after`); see the documentation for more details. Build Infrastructure @@ -95,6 +95,8 @@ package "intf" ( directory = "intf" + archive(byte) = "intf.cma" + archive(native) = "intf.cmxa" ) package "engine" ( @@ -239,19 +241,6 @@ package "toplevel" ( ) -package "highparsing" ( - - description = "Coq Extra Parsing" - version = "8.7" - - requires = "coq.toplevel" - directory = "parsing" - - archive(byte) = "highparsing.cma" - archive(native) = "highparsing.cmxa" - -) - package "idetop" ( description = "Coq IDE Libraries" @@ -279,28 +268,43 @@ package "ide" ( ) -package "ltac" ( +# XXX: Remove the dependency on toplevel (due to Coqinit use for compat flags) +package "highparsing" ( - description = "Coq LTAC Plugin" + description = "Coq Extra Parsing" version = "8.7" - requires = "coq.highparsing" - directory = "plugins/ltac" + requires = "coq.toplevel" + directory = "parsing" - archive(byte) = "ltac_plugin.cmo" - archive(native) = "ltac_plugin.cmx" + archive(byte) = "highparsing.cma" + archive(native) = "highparsing.cmxa" ) +# XXX: API should depend only on stm. package "API" ( description = "Coq API" version = "8.7" - requires = "coq.toplevel" + requires = "coq.highparsing" directory = "API" archive(byte) = "API.cma" archive(native) = "API.cmxa" ) + +package "ltac" ( + + description = "Coq LTAC Plugin" + version = "8.7" + + requires = "coq.API" + directory = "plugins/ltac" + + archive(byte) = "ltac_plugin.cmo" + archive(native) = "ltac_plugin.cmx" + +) @@ -17,7 +17,7 @@ # read # http://miller.emu.id.au/pmiller/books/rmch/ # before complaining. -# +# # When you are working in a subdir, you can compile without moving to the # upper directory using "make -C ..", and the output is still understood # by Emacs' next-error. @@ -168,7 +168,7 @@ Makefile $(wildcard Makefile.*) config/Makefile : ; # Cleaning ########################################################################### -.PHONY: clean cleankeepvo objclean cruftclean indepclean docclean archclean optclean clean-ide ml4clean depclean cleanconfig distclean voclean devdocclean +.PHONY: clean cleankeepvo objclean cruftclean indepclean docclean archclean optclean clean-ide ml4clean depclean cleanconfig distclean voclean timingclean devdocclean clean: objclean cruftclean depclean docclean devdocclean @@ -239,16 +239,19 @@ cacheclean: cleanconfig: rm -f config/Makefile config/coq_config.ml myocamlbuild_config.ml dev/ocamldebug-coq dev/camlp4.dbg config/Info-*.plist -distclean: clean cleanconfig cacheclean +distclean: clean cleanconfig cacheclean timingclean voclean: find theories plugins test-suite \( -name '*.vo' -o -name '*.glob' -o -name "*.cmxs" -o -name "*.native" -o -name "*.cmx" -o -name "*.cmi" -o -name "*.o" \) -delete find theories plugins test-suite -name .coq-native -empty -delete +timingclean: + find theories plugins test-suite \( -name '*.v.timing' -o -name '*.v.before-timing' -o -name "*.v.after-timing" -o -name "*.v.timing.diff" -o -name "time-of-build.log" -o -name "time-of-build-before.log" -o -name "time-of-build-after.log" -o -name "time-of-build-pretty.log" -o -name "time-of-build-both.log" \) -delete + devdocclean: find . -name '*.dep.ps' -o -name '*.dot' | xargs rm -f - rm -f $(OCAMLDOCDIR)/*.log $(OCAMLDOCDIR)/*.aux $(OCAMLDOCDIR)/*.toc - rm -f $(OCAMLDOCDIR)/ocamldoc.sty $(OCAMLDOCDIR)/coq.tex + rm -f $(OCAMLDOCDIR)/*.log $(OCAMLDOCDIR)/*.aux $(OCAMLDOCDIR)/*.toc + rm -f $(OCAMLDOCDIR)/ocamldoc.sty $(OCAMLDOCDIR)/coq.tex rm -f $(OCAMLDOCDIR)/html/*.html ########################################################################### @@ -299,4 +302,3 @@ printenv: @env | wc -L @echo -n "Total (win32 limit is 32k) : " @env | wc -m - diff --git a/Makefile.build b/Makefile.build index 0dafde997..7703df08f 100644 --- a/Makefile.build +++ b/Makefile.build @@ -34,6 +34,12 @@ TIMED ?= # it could be set to "'/usr/bin/time -p'". TIMECMD ?= +# When non-empty, -time is passed to coqc and the output is recorded +# in a timing file for each .v file. If set to "before" or "after", +# the file name for foo.v is foo.v.$(TIMING)-timing; otherwise, it is +# foo.v.timing +TIMING ?= + # Non-empty skips the update of all dependency .d files: NO_RECALC_DEPS ?= @@ -43,6 +49,16 @@ VALIDATE ?= # Is "-xml" when building XML library: COQ_XML ?= +# Output file names for timed builds +TIME_OF_BUILD_FILE ?= time-of-build.log +TIME_OF_BUILD_BEFORE_FILE ?= time-of-build-before.log +TIME_OF_BUILD_AFTER_FILE ?= time-of-build-after.log +TIME_OF_PRETTY_BUILD_FILE ?= time-of-build-pretty.log +TIME_OF_PRETTY_BOTH_BUILD_FILE ?= time-of-build-both.log +TIME_OF_PRETTY_BUILD_EXTRA_FILES ?= - # also output to the command line +BEFORE ?= +AFTER ?= + ########################################################################### # Default starting rule ########################################################################### @@ -53,6 +69,9 @@ world: coq coqide documentation revision coq: coqlib coqbinaries tools +world.timing.diff: coq.timing.diff +coq.timing.diff: coqlib.timing.diff + # Note: 'world' does not build the bytecode binaries anymore. # For that, you can use the 'byte' rule. Native and byte compilations # shouldn't be done in a same make -j... run, otherwise both ocamlc and @@ -60,7 +79,7 @@ coq: coqlib coqbinaries tools byte: coqbyte coqide-byte pluginsbyte printers -.PHONY: world coq byte +.PHONY: world coq byte world.timing.diff coq.timing.diff ########################################################################### # Includes @@ -78,6 +97,53 @@ include Makefile.install include Makefile.dev ## provides the 'printers' and 'revision' rules ########################################################################### +# Timing targets +########################################################################### +make-pretty-timed-before:: TIME_OF_BUILD_FILE=$(TIME_OF_BUILD_BEFORE_FILE) +make-pretty-timed-after:: TIME_OF_BUILD_FILE=$(TIME_OF_BUILD_AFTER_FILE) +make-pretty-timed make-pretty-timed-before make-pretty-timed-after:: + $(HIDE)rm -f pretty-timed-success.ok + $(HIDE)($(MAKE) --no-print-directory $(TGTS) TIMED=1 2>&1 && touch pretty-timed-success.ok) | tee -a $(TIME_OF_BUILD_FILE) + $(HIDE)rm pretty-timed-success.ok # must not be -f; must fail if the touch failed +print-pretty-timed:: + $(HIDE)$(COQMAKE_ONE_TIME_FILE) $(TIME_OF_BUILD_FILE) $(TIME_OF_PRETTY_BUILD_FILE) $(TIME_OF_PRETTY_BUILD_EXTRA_FILES) +print-pretty-timed-diff:: + $(HIDE)$(COQMAKE_BOTH_TIME_FILES) $(TIME_OF_BUILD_BEFORE_FILE) $(TIME_OF_BUILD_AFTER_FILE) $(TIME_OF_PRETTY_BOTH_BUILD_FILE) $(TIME_OF_PRETTY_BUILD_EXTRA_FILES) +ifeq (,$(BEFORE)) +print-pretty-single-time-diff:: + @echo 'Error: Usage: $(MAKE) print-pretty-single-time-diff BEFORE=path/to/file.v.before-timing AFTER=path/to/file.v.after-timing' + $(HIDE)false +else +ifeq (,$(AFTER)) +print-pretty-single-time-diff:: + @echo 'Error: Usage: $(MAKE) print-pretty-single-time-diff BEFORE=path/to/file.v.before-timing AFTER=path/to/file.v.after-timing' + $(HIDE)false +else +print-pretty-single-time-diff:: + $(HIDE)$(COQMAKE_BOTH_SINGLE_TIMING_FILES) $(BEFORE) $(AFTER) $(TIME_OF_PRETTY_BUILD_FILE) $(TIME_OF_PRETTY_BUILD_EXTRA_FILES) +endif +endif +pretty-timed: + $(HIDE)$(MAKE) --no-print-directory make-pretty-timed + $(HIDE)$(MAKE) --no-print-directory print-pretty-timed +.PHONY: pretty-timed make-pretty-timed make-pretty-timed-before make-pretty-timed-after print-pretty-timed print-pretty-timed-diff + +ifneq (,$(TIMING)) +TIMING_ARG=-time +ifeq (after,$(TIMING)) +TIMING_EXT=after-timing +else +ifeq (before,$(TIMING)) +TIMING_EXT=before-timing +else +TIMING_EXT=timing +endif +endif +else +TIMING_ARG= +endif + +########################################################################### # This include below will lauch the build of all .d. # The - at front is for disabling warnings about currently missing ones. @@ -101,7 +167,21 @@ DEPENDENCIES := \ ########################################################################### # Default timing command -STDTIME=/usr/bin/time -f "$* (user: %U mem: %M ko)" +# Use /usr/bin/time on linux, gtime on Mac OS +TIMEFMT?="$* (real: %e, user: %U, sys: %S, mem: %M ko)" +ifneq (,$(TIMED)) +ifeq (0,$(shell /usr/bin/time -f $(TIMEFMT) true >/dev/null 2>/dev/null; echo $$?)) +STDTIME?=/usr/bin/time -f $(TIMEFMT) +else +ifeq (0,$(shell gtime -f $(TIMEFMT) true >/dev/null 2>/dev/null; echo $$?)) +STDTIME?=gtime -f $(TIMEFMT) +else +STDTIME?=time +endif +endif +else +STDTIME?=/usr/bin/time -f $(TIMEFMT) +endif TIMER=$(if $(TIMED), $(STDTIME), $(TIMECMD)) @@ -112,7 +192,7 @@ TIMER=$(if $(TIMED), $(STDTIME), $(TIMECMD)) COQOPTS=$(COQ_XML) $(NATIVECOMPUTE) BOOTCOQC=$(TIMER) $(COQTOPBEST) -boot $(COQOPTS) -compile -LOCALINCLUDES=$(if $(filter plugins/%,$<),-I lib -I API $(addprefix -I plugins/,$(PLUGINDIRS)),$(addprefix -I ,$(SRCDIRS))) +LOCALINCLUDES=$(if $(filter plugins/%,$<),-I lib -I API -open API $(addprefix -I plugins/,$(PLUGINDIRS)),$(addprefix -I ,$(SRCDIRS))) MLINCLUDES=$(LOCALINCLUDES) -I $(MYCAMLP4LIB) OCAMLC := $(OCAMLFIND) ocamlc $(CAMLFLAGS) @@ -275,7 +355,7 @@ grammar/grammar.cma : $(GRAMCMO) @touch grammar/test.mlp $(HIDE)$(GRAMC) -pp '$(CAMLP4O) -I $(MYCAMLP4LIB) $^ -impl' -impl grammar/test.mlp -o grammar/test @rm -f grammar/test.* grammar/test - $(SHOW)'OCAMLC -a $@' + $(SHOW)'OCAMLC -a $@' $(HIDE)$(GRAMC) $^ -linkall -a -o $@ ## Support of Camlp5 and Camlp5 @@ -307,7 +387,7 @@ coqbyte: $(COQTOPBYTE) $(CHICKENBYTE) ifeq ($(BEST),opt) $(COQTOPEXE): $(COQMKTOP) $(LINKCMX) $(LIBCOQRUN) $(TOPLOOPCMA:.cma=.cmxs) - $(SHOW)'COQMKTOP -o $@' + $(SHOW)'COQMKTOP -o $@' $(HIDE)$(COQMKTOP) -boot -opt $(OPTFLAGS) $(LINKMETADATA) -o $@ $(STRIP) $@ $(CODESIGN) $@ @@ -317,7 +397,7 @@ $(COQTOPEXE): $(COQTOPBYTE) endif $(COQTOPBYTE): $(COQMKTOP) $(LINKCMO) $(LIBCOQRUN) $(TOPLOOPCMA) - $(SHOW)'COQMKTOP -o $@' + $(SHOW)'COQMKTOP -o $@' $(HIDE)$(COQMKTOP) -boot -top $(BYTEFLAGS) -o $@ # coqmktop @@ -602,18 +682,28 @@ OCAMLDEP = $(OCAMLFIND) ocamldep -slash -ml-synonym .ml4 -ml-synonym .mlpack # since they are all mentioned in at least one Declare ML Module in some .v coqlib: theories plugins +coqlib.timing.diff: theories.timing.diff plugins.timing.diff theories: $(THEORIESVO) plugins: $(PLUGINSVO) -.PHONY: coqlib theories plugins +theories.timing.diff: $(THEORIESVO:.vo=.v.timing.diff) +plugins.timing.diff: $(PLUGINSVO:.vo=.v.timing.diff) + +.PHONY: coqlib theories plugins coqlib.timing.diff theories.timing.diff plugins.timing.diff # The .vo files in Init are built with the -noinit option +ifneq (,$(TIMING)) +TIMING_EXTRA = > $<.$(TIMING_EXT) +else +TIMING_EXTRA = +endif + theories/Init/%.vo theories/Init/%.glob: theories/Init/%.v $(VO_TOOLS_DEP) $(SHOW)'COQC $(COQ_XML) -noinit $<' $(HIDE)rm -f theories/Init/$*.glob - $(HIDE)$(BOOTCOQC) $< $(COQ_XML) -noinit -R theories Coq + $(HIDE)$(BOOTCOQC) $< $(COQ_XML) -noinit -R theories Coq $(TIMING_ARG) $(TIMING_EXTRA) # MExtraction.v generates the ml core file of the micromega tactic. # We check that this generated code is still in sync with the version @@ -640,13 +730,18 @@ $(MICROMEGAV:.v=.vo) $(MICROMEGAV:.v=.glob) : $(MICROMEGAV) theories/Init/Prelud %.vo %.glob: %.v theories/Init/Prelude.vo $(VO_TOOLS_DEP) $(SHOW)'COQC $<' $(HIDE)rm -f $*.glob - $(HIDE)$(BOOTCOQC) $< + $(HIDE)$(BOOTCOQC) $< $(TIMING_ARG) $(TIMING_EXTRA) ifdef VALIDATE $(SHOW)'COQCHK $(call vo_to_mod,$@)' $(HIDE)$(CHICKEN) -boot -silent -norec $(call vo_to_mod,$@) \ || ( RV=$$?; rm -f "$@"; exit $${RV} ) endif +%.v.timing.diff: %.v.before-timing %.v.after-timing + $(SHOW)PYTHON TIMING-DIFF $< + $(HIDE)$(MAKE) --no-print-directory print-pretty-single-time-diff BEFORE=$*.v.before-timing AFTER=$*.v.after-timing TIME_OF_PRETTY_BUILD_FILE="$@" + + # Dependencies of .v files %.v.d: $(D_DEPEND_BEFORE_SRC) %.v $(D_DEPEND_AFTER_SRC) $(COQDEPBOOT) @@ -667,7 +762,7 @@ Makefile $(wildcard Makefile.*) config/Makefile : ; %: @echo "Error: no rule to make target $@ (or missing .PHONY)" && false -# For emacs: -# Local Variables: -# mode: makefile +# For emacs: +# Local Variables: +# mode: makefile # End: diff --git a/Makefile.common b/Makefile.common index 100698321..85ecb1a08 100644 --- a/Makefile.common +++ b/Makefile.common @@ -12,7 +12,7 @@ # Executables ########################################################################### -COQMKTOP:=bin/coqmktop$(EXE) +COQMKTOP:=bin/coqmktop$(EXE) COQTOPBYTE:=bin/coqtop.byte$(EXE) COQTOPEXE:=bin/coqtop$(EXE) @@ -25,9 +25,15 @@ COQWC:=bin/coqwc$(EXE) COQDOC:=bin/coqdoc$(EXE) COQC:=bin/coqc$(EXE) COQWORKMGR:=bin/coqworkmgr$(EXE) +COQMAKE_ONE_TIME_FILE:=tools/make-one-time-file.py +COQTIME_FILE_MAKER:=tools/TimeFileMaker.py +COQMAKE_BOTH_TIME_FILES:=tools/make-both-time-files.py +COQMAKE_BOTH_SINGLE_TIMING_FILES:=tools/make-both-single-timing-files.py TOOLS:=$(COQDEP) $(COQMAKEFILE) $(GALLINA) $(COQTEX) $(COQWC) $(COQDOC) $(COQC)\ $(COQWORKMGR) +TOOLS_HELPERS:=tools/CoqMakefile.in $(COQMAKE_ONE_TIME_FILE) $(COQTIME_FILE_MAKER)\ + $(COQMAKE_BOTH_TIME_FILES) $(COQMAKE_BOTH_SINGLE_TIMING_FILES) COQDEPBOOT:=bin/coqdep_boot$(EXE) OCAMLLIBDEP:=bin/ocamllibdep$(EXE) @@ -64,7 +70,7 @@ DYNLIB:=.cma endif INSTALLBIN:=install -INSTALLLIB:=install -m 644 +INSTALLLIB:=install -m 644 INSTALLSH:=./install.sh MKDIR:=install -d @@ -191,7 +197,7 @@ LIBFILES:=$(ALLVO) $(call vo_to_cm,$(ALLVO)) \ $(call vo_to_obj,$(ALLVO)) \ $(VFILES) $(GLOBFILES) -# For emacs: -# Local Variables: -# mode: makefile +# For emacs: +# Local Variables: +# mode: makefile # End: diff --git a/Makefile.ide b/Makefile.ide index 0cfbdeb4e..b534b385b 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/Makefile.install b/Makefile.install index 4a3227620..02ae724df 100644 --- a/Makefile.install +++ b/Makefile.install @@ -107,7 +107,7 @@ install-devfiles: $(MKDIR) $(FULLCOQLIB) $(INSTALLSH) $(FULLCOQLIB) $(GRAMMARCMA) $(INSTALLSH) $(FULLCOQLIB) $(INSTALLCMI) - $(INSTALLSH) $(FULLCOQLIB) tools/CoqMakefile.in + $(INSTALLSH) $(FULLCOQLIB) $(TOOLS_HELPERS) ifeq ($(BEST),opt) $(INSTALLSH) $(FULLCOQLIB) $(LINKCMX) $(CORECMA:.cma=.a) $(STATICPLUGINS:.cma=.a) endif @@ -1,6 +1,6 @@ # Coq -[](https://travis-ci.org/coq/coq/builds) [](https://gitter.im/coq/coq) +[](https://travis-ci.org/coq/coq/builds) [](https://gitter.im/coq/coq) Coq is a formal proof management system. It provides a formal language to write mathematical definitions, executable algorithms and theorems together with an diff --git a/appveyor.yml b/appveyor.yml new file mode 100644 index 000000000..ec6ded721 --- /dev/null +++ b/appveyor.yml @@ -0,0 +1,26 @@ +version: '{branch}~{build}' +clone_depth: 10 + +platform: +- x64 + +image: +- Visual Studio 2017 + +environment: + CYGROOT: C:\cygwin64 + CYGMIRROR: http://ftp.inf.tu-dresden.de/software/windows/cygwin32 + CYGCACHE: C:\cygwin64\var\cache\setup + opam_url: https://github.com/fdopen/opam-repository-mingw/releases/download/0.0.0.1/opam64.tar.xz + +install: +- cmd: '%CYGROOT%\setup-x86_64.exe -qnNdO -R %CYGROOT% -l %CYGCACHE% -s + %CYGMIRROR% -P rsync -P patch -P diffutils -P curl -P make -P unzip -P git -p m4 + -P perl -P findutils -P time' +- cmd: '%CYGROOT%/bin/bash -l %APPVEYOR_BUILD_FOLDER%/dev/build/windows/appveyor.sh' + +build_script: +- cmd: '%CYGROOT%/bin/bash -lc "cd $APPVEYOR_BUILD_FOLDER && ./configure -local && make"' + +test_script: +- cmd: '%CYGROOT%/bin/bash -lc "cd $APPVEYOR_BUILD_FOLDER && make -C test-suite && make validate"' diff --git a/checker/environ.ml b/checker/environ.ml index 11b8ea67c..d3f393c65 100644 --- a/checker/environ.ml +++ b/checker/environ.ml @@ -122,8 +122,7 @@ type const_evaluation_result = NoBody | Opaque | IsProj let constraints_of cb u = match cb.const_universes with | Monomorphic_const _ -> Univ.Constraint.empty - | Polymorphic_const ctx -> - Univ.UContext.constraints (Univ.subst_instance_context u ctx) + | Polymorphic_const ctx -> Univ.AUContext.instantiate u ctx let map_regular_arity f = function | RegularArity a as ar -> diff --git a/checker/indtypes.ml b/checker/indtypes.ml index 92e94c1ab..22c843812 100644 --- a/checker/indtypes.ml +++ b/checker/indtypes.ml @@ -525,10 +525,10 @@ let check_positivity env_ar mind params nrecp inds = Array.iter2 (fun ind wfpi -> check_subtree ind.mind_recargs wfpi) inds wfp (* Check arities and constructors *) -let check_subtyping_arity_constructor env (subst : constr -> constr) (arcn : constr) numparams is_arity = +let check_subtyping_arity_constructor env (subst : Univ.Instance.t) (arcn : constr) numparams is_arity = let numchecked = ref 0 in let basic_check ev tp = - if !numchecked < numparams then () else conv_leq ev tp (subst tp); + if !numchecked < numparams then () else conv_leq ev tp (Term.subst_instance_constr subst tp); numchecked := !numchecked + 1 in let check_typ typ typ_env = @@ -548,26 +548,27 @@ let check_subtyping_arity_constructor env (subst : constr -> constr) (arcn : con (* Check that the subtyping information inferred for inductive types in the block is correct. *) (* This check produces a value of the unit type if successful or raises an anomaly if check fails. *) -let check_subtyping cumi paramsctxt env_ar inds = +let check_subtyping cumi paramsctxt env inds = + let open Univ in let numparams = rel_context_nhyps paramsctxt in - let sbsubst = Univ.CumulativityInfo.subtyping_susbst cumi in - let other_instnace = Univ.CumulativityInfo.subtyping_other_instance cumi in - let dosubst = subst_univs_level_constr sbsubst in - let uctx = Univ.CumulativityInfo.univ_context cumi in - let uctx_other = Univ.UContext.make (other_instnace, Univ.UContext.constraints uctx) in - let env = Environ.push_context uctx env_ar - in - let env = Environ.push_context uctx_other env - in - let env = Environ.push_context - (Univ.CumulativityInfo.subtyp_context cumi) env - in + (** In [env] we already have [ Var(0) ... Var(n-1) |- cst ] available. + We must produce the substitution σ : [ Var(i) -> Var (i + n) | 0 <= i < n] + and push the constraints [ Var(n) ... Var(2n - 1) |- cst{σ} ], together + with the cumulativity constraints [ cumul_cst ]. *) + let len = AUContext.size (ACumulativityInfo.univ_context cumi) in + let inst = Instance.of_array (Array.init len (fun i -> Level.var (i + len))) in + let other_context = ACumulativityInfo.univ_context cumi in + let uctx_other = UContext.make (inst, AUContext.instantiate inst other_context) in + let cumul_context = AUContext.repr (ACumulativityInfo.subtyp_context cumi) in + let cumul_cst = UContext.constraints cumul_context in + let env = Environ.push_context uctx_other env in + let env = Environ.add_constraints cumul_cst env in (* process individual inductive types: *) Array.iter (fun { mind_user_lc = lc; mind_arity = arity } -> match arity with | RegularArity { mind_user_arity = full_arity} -> - check_subtyping_arity_constructor env dosubst full_arity numparams true; - Array.iter (fun cnt -> check_subtyping_arity_constructor env dosubst cnt numparams false) lc + check_subtyping_arity_constructor env inst full_arity numparams true; + Array.iter (fun cnt -> check_subtyping_arity_constructor env inst cnt numparams false) lc | TemplateArity _ -> () ) inds @@ -579,10 +580,10 @@ let check_inductive env kn mib = (* check mind_constraints: should be consistent with env *) let ind_ctx = match mib.mind_universes with - | Monomorphic_ind ctx -> ctx - | Polymorphic_ind auctx -> Univ.instantiate_univ_context auctx + | Monomorphic_ind _ -> Univ.UContext.empty (** Already in the global environment *) + | Polymorphic_ind auctx -> Univ.AUContext.repr auctx | Cumulative_ind cumi -> - Univ.instantiate_univ_context (Univ.ACumulativityInfo.univ_context cumi) + Univ.AUContext.repr (Univ.ACumulativityInfo.univ_context cumi) in let env = Environ.push_context ind_ctx env in (* check mind_record : TODO ? check #constructor = 1 ? *) @@ -606,8 +607,7 @@ let check_inductive env kn mib = match mib.mind_universes with | Monomorphic_ind _ | Polymorphic_ind _ -> () | Cumulative_ind acumi -> - check_subtyping - (Univ.instantiate_cumulativity_info acumi) params env_ar mib.mind_packets + check_subtyping acumi params env_ar mib.mind_packets in (* check mind_nparams_rec: positivity condition *) check_positivity env_ar kn params mib.mind_nparams_rec mib.mind_packets; diff --git a/checker/inductive.ml b/checker/inductive.ml index 93ffa329a..1271a02b0 100644 --- a/checker/inductive.ml +++ b/checker/inductive.ml @@ -66,20 +66,6 @@ let inductive_is_cumulative mib = | Polymorphic_ind ctx -> false | Cumulative_ind cumi -> true -let inductive_polymorphic_instance mib = - match mib.mind_universes with - | Monomorphic_ind _ -> Univ.Instance.empty - | Polymorphic_ind ctx -> Univ.AUContext.instance ctx - | Cumulative_ind cumi -> - Univ.AUContext.instance (Univ.ACumulativityInfo.univ_context cumi) - -let inductive_polymorphic_context mib = - match mib.mind_universes with - | Monomorphic_ind _ -> Univ.UContext.empty - | Polymorphic_ind ctx -> Univ.instantiate_univ_context ctx - | Cumulative_ind cumi -> - Univ.instantiate_univ_context (Univ.ACumulativityInfo.univ_context cumi) - (************************************************************************) (* Build the substitution that replaces Rels by the appropriate *) diff --git a/checker/inductive.mli b/checker/inductive.mli index 698b8b77c..8f605935d 100644 --- a/checker/inductive.mli +++ b/checker/inductive.mli @@ -26,10 +26,6 @@ val inductive_is_polymorphic : mutual_inductive_body -> bool val inductive_is_cumulative : mutual_inductive_body -> bool -val inductive_polymorphic_instance : mutual_inductive_body -> Univ.universe_instance - -val inductive_polymorphic_context : mutual_inductive_body -> Univ.universe_context - val type_of_inductive : env -> mind_specif puniverses -> constr (* Return type as quoted by the user *) diff --git a/checker/mod_checking.ml b/checker/mod_checking.ml index 15e9ae295..4948f6008 100644 --- a/checker/mod_checking.ml +++ b/checker/mod_checking.ml @@ -26,22 +26,21 @@ let refresh_arity ar = let check_constant_declaration env kn cb = Feedback.msg_notice (str " checking cst:" ++ prcon kn); - let env', u = + (** [env'] contains De Bruijn universe variables *) + let env' = match cb.const_universes with - | Monomorphic_const ctx -> push_context ~strict:true ctx env, Univ.Instance.empty + | Monomorphic_const ctx -> push_context ~strict:true ctx env | Polymorphic_const auctx -> - let ctx = Univ.instantiate_univ_context auctx in - push_context ~strict:false ctx env, Univ.UContext.instance ctx + let ctx = Univ.AUContext.repr auctx in + push_context ~strict:false ctx env in let envty, ty = match cb.const_type with RegularArity ty -> - let ty = subst_instance_constr u ty in 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) -> - assert(Univ.Instance.is_empty u); let _ = check_ctxt env' ctxt in check_polymorphic_arity env' ctxt par; env', it_mkProd_or_LetIn (Sort(Type par.template_level)) ctxt @@ -49,7 +48,6 @@ let check_constant_declaration env kn cb = let () = match body_of_constant cb with | Some bd -> - let bd = subst_instance_constr u bd in (match cb.const_proj with | None -> let j = infer envty bd in conv_leq envty j ty diff --git a/checker/reduction.ml b/checker/reduction.ml index 93b8b907c..6d8783d7e 100644 --- a/checker/reduction.ml +++ b/checker/reduction.ml @@ -157,25 +157,23 @@ let compare_stacks f fmind lft1 stk1 lft2 stk2 = else raise NotConvertible let convert_inductive_instances cv_pb cumi u u' univs = - let ind_instance = - Univ.AUContext.instance (Univ.ACumulativityInfo.univ_context cumi) in + let len_instance = + Univ.AUContext.size (Univ.ACumulativityInfo.univ_context cumi) in let ind_subtypctx = Univ.ACumulativityInfo.subtyp_context cumi in - if not ((Univ.Instance.length ind_instance = Univ.Instance.length u) && - (Univ.Instance.length ind_instance = Univ.Instance.length u')) then + if not ((len_instance = Univ.Instance.length u) && + (len_instance = Univ.Instance.length u')) then anomaly (Pp.str "Invalid inductive subtyping encountered!") else let comp_cst = let comp_subst = (Univ.Instance.append u u') in - Univ.UContext.constraints - (Univ.subst_instance_context comp_subst ind_subtypctx) + Univ.AUContext.instantiate comp_subst ind_subtypctx in let comp_cst = match cv_pb with CONV -> let comp_cst' = let comp_subst = (Univ.Instance.append u' u) in - Univ.UContext.constraints - (Univ.subst_instance_context comp_subst ind_subtypctx) + Univ.AUContext.instantiate comp_subst ind_subtypctx in Univ.Constraint.union comp_cst comp_cst' | CUMUL -> comp_cst diff --git a/checker/subtyping.ml b/checker/subtyping.ml index 5fd5510a7..3097c3a0b 100644 --- a/checker/subtyping.ml +++ b/checker/subtyping.ml @@ -81,6 +81,14 @@ let check_conv_error error f env a1 a2 = with NotConvertible -> error () +let check_polymorphic_instance error env auctx1 auctx2 = + if not (Univ.AUContext.size auctx1 == Univ.AUContext.size auctx2) then + error () + else if not (Univ.check_subtype (Environ.universes env) auctx2 auctx1) then + error () + else + Environ.push_context ~strict:false (Univ.AUContext.repr auctx2) env + (* for now we do not allow reorderings *) let check_inductive env mp1 l info1 mib2 spec2 subst1 subst2= let kn = MutInd.make2 mp1 l in @@ -93,19 +101,17 @@ let check_inductive env mp1 l info1 mib2 spec2 subst1 subst2= in let mib2 = subst_mind subst2 mib2 in let check eq f = if not (eq (f mib1) (f mib2)) then error () in - let u = - let process inst inst' = - if Univ.Instance.equal inst inst' then inst else error () - in + let env, u = match mib1.mind_universes, mib2.mind_universes with - | Monomorphic_ind _, Monomorphic_ind _ -> Univ.Instance.empty + | Monomorphic_ind _, Monomorphic_ind _ -> env, Univ.Instance.empty | Polymorphic_ind auctx, Polymorphic_ind auctx' -> - process - (Univ.AUContext.instance auctx) (Univ.AUContext.instance auctx') + let env = check_polymorphic_instance error env auctx auctx' in + env, Univ.make_abstract_instance auctx' | Cumulative_ind cumi, Cumulative_ind cumi' -> - process - (Univ.AUContext.instance (Univ.ACumulativityInfo.univ_context cumi)) - (Univ.AUContext.instance (Univ.ACumulativityInfo.univ_context cumi')) + let auctx = Univ.ACumulativityInfo.univ_context cumi in + let auctx' = Univ.ACumulativityInfo.univ_context cumi' in + let env = check_polymorphic_instance error env auctx auctx' in + env, Univ.make_abstract_instance auctx' | _ -> error () in let eq_projection_body p1 p2 = @@ -118,7 +124,7 @@ let check_inductive env mp1 l info1 mib2 spec2 subst1 subst2= check (eq_constr) (fun x -> snd x.proj_eta); check (eq_constr) (fun x -> x.proj_body); true in - let check_inductive_type env t1 t2 = + let check_inductive_type t1 t2 = (* Due to template polymorphism, the conclusions of t1 and t2, if in Type, are generated as the least upper bounds @@ -170,8 +176,8 @@ let check_inductive env mp1 l info1 mib2 spec2 subst1 subst2= (* nparams done *) (* params_ctxt done because part of the inductive types *) (* Don't check the sort of the type if polymorphic *) - check_inductive_type env - (type_of_inductive env ((mib1,p1),u)) (type_of_inductive env ((mib2,p2),u)) + check_inductive_type + (type_of_inductive env ((mib1,p1), u)) (type_of_inductive env ((mib2,p2),u)) in let check_cons_types i p1 p2 = Array.iter2 (check_conv conv env) @@ -309,27 +315,17 @@ let check_constant env mp1 l info1 cb2 spec2 subst1 subst2 = let c2 = force_constr lc2 in check_conv conv env c1 c2)) | IndType ((kn,i),mind1) -> - ignore (CErrors.user_err (Pp.str ( + CErrors.user_err (Pp.str ( "The kernel does not recognize yet that a parameter can be " ^ "instantiated by an inductive type. Hint: you can rename the " ^ "inductive type and give a definition to map the old name to the new " ^ - "name."))); - if constant_has_body cb2 then error () ; - let u = inductive_polymorphic_instance mind1 in - let arity1 = type_of_inductive env ((mind1,mind1.mind_packets.(i)),u) in - let typ2 = Typeops.type_of_constant_type env cb2.const_type in - check_conv conv_leq env arity1 typ2 - | IndConstr (((kn,i),j) as cstr,mind1) -> - ignore (CErrors.user_err (Pp.str ( + "name.")) + | IndConstr (((kn,i),j),mind1) -> + CErrors.user_err (Pp.str ( "The kernel does not recognize yet that a parameter can be " ^ "instantiated by a constructor. Hint: you can rename the " ^ "constructor and give a definition to map the old name to the new " ^ - "name."))); - if constant_has_body cb2 then error () ; - let u1 = inductive_polymorphic_instance mind1 in - let ty1 = type_of_constructor (cstr,u1) (mind1,mind1.mind_packets.(i)) in - let ty2 = Typeops.type_of_constant_type env cb2.const_type in - check_conv conv env ty1 ty2 + "name.")) let rec check_modules env msb1 msb2 subst1 subst2 = let mty1 = module_type_of_module None msb1 in diff --git a/checker/term.ml b/checker/term.ml index 9bcb15bc7..5995dfcc6 100644 --- a/checker/term.ml +++ b/checker/term.ml @@ -447,37 +447,3 @@ let subst_instance_constr subst c = let subst_instance_context s ctx = if Univ.Instance.is_empty s then ctx else map_rel_context (fun x -> subst_instance_constr s x) ctx - -let subst_univs_level_constr subst c = - if Univ.is_empty_level_subst subst then c - else - let f = Univ.Instance.subst_fn (Univ.subst_univs_level_level subst) in - let changed = ref false in - let rec aux t = - match t with - | Const (c, u) -> - if Univ.Instance.is_empty u then t - else - let u' = f u in - if u' == u then t - else (changed := true; Const (c, u')) - | Ind (i, u) -> - if Univ.Instance.is_empty u then t - else - let u' = f u in - if u' == u then t - else (changed := true; Ind (i, u')) - | Construct (c, u) -> - if Univ.Instance.is_empty u then t - else - let u' = f u in - if u' == u then t - else (changed := true; Construct (c, u')) - | Sort (Type u) -> - let u' = Univ.subst_univs_level_universe subst u in - if u' == u then t else - (changed := true; Sort (sort_of_univ u')) - | _ -> map_constr aux t - in - let c' = aux c in - if !changed then c' else c diff --git a/checker/term.mli b/checker/term.mli index ccf5b59e0..679a56ee4 100644 --- a/checker/term.mli +++ b/checker/term.mli @@ -57,4 +57,3 @@ val eq_constr : constr -> constr -> bool (** Instance substitution for polymorphism. *) val subst_instance_constr : Univ.universe_instance -> constr -> constr val subst_instance_context : Univ.universe_instance -> rel_context -> rel_context -val subst_univs_level_constr : Univ.universe_level_subst -> constr -> constr diff --git a/checker/univ.ml b/checker/univ.ml index b434db129..e3abc436f 100644 --- a/checker/univ.ml +++ b/checker/univ.ml @@ -1075,6 +1075,7 @@ module Instance : sig val check_eq : t check_function val length : t -> int val append : t -> t -> t + val of_array : Level.t array -> t end = struct type t = Level.t array @@ -1157,9 +1158,38 @@ struct let length = Array.length let append = Array.append - + + let of_array i = i + end +(** Substitute instance inst for ctx in csts *) + +let subst_instance_level s l = + match l.Level.data with + | Level.Var n -> s.(n) + | _ -> l + +let subst_instance_instance s i = + Array.smartmap (fun l -> subst_instance_level s l) i + +let subst_instance_universe s u = + let f x = Universe.Expr.map (fun u -> subst_instance_level s u) x in + let u' = Universe.smartmap f u in + if u == u' then u + else Universe.sort u' + +let subst_instance_constraint s (u,d,v as c) = + let u' = subst_instance_level s u in + let v' = subst_instance_level s v in + if u' == u && v' == v then c + else (u',d,v') + +let subst_instance_constraints s csts = + Constraint.fold + (fun c csts -> Constraint.add (subst_instance_constraint s c) csts) + csts Constraint.empty + type universe_instance = Instance.t type 'a puniverses = 'a * Instance.t @@ -1175,6 +1205,7 @@ struct let make x = x let instance (univs, cst) = univs let constraints (univs, cst) = cst + let size (univs, _) = Instance.length univs let is_empty (univs, cst) = Instance.is_empty univs && Constraint.is_empty cst let pr prl (univs, cst as ctx) = @@ -1184,7 +1215,18 @@ end type universe_context = UContext.t -module AUContext = UContext +module AUContext = +struct + include UContext + + let repr (inst, cst) = + (Array.mapi (fun i l -> Level.var i) inst, cst) + + let instantiate inst (u, cst) = + assert (Array.length u = Array.length inst); + subst_instance_constraints inst cst + +end type abstract_universe_context = AUContext.t @@ -1192,43 +1234,11 @@ module CumulativityInfo = struct type t = universe_context * universe_context - let make x = - if (Array.length (UContext.instance (snd x))) = - (Array.length (UContext.instance (fst x))) * 2 then x - else anomaly (Pp.str "Invalid subtyping information encountered!") - - let empty = (UContext.empty, UContext.empty) - - let halve_context ctx = - let len = Array.length ctx in - let halflen = len / 2 in - ((Array.sub ctx 0 halflen), (Array.sub ctx halflen halflen)) - let univ_context (univcst, subtypcst) = univcst let subtyp_context (univcst, subtypcst) = subtypcst - let create_trivial_subtyping ctx ctx' = - CArray.fold_left_i - (fun i cst l -> Constraint.add (l, Eq, Array.get ctx' i) cst) - Constraint.empty ctx - - let from_universe_context univcst freshunivs = - let inst = (UContext.instance univcst) in - assert (Array.length freshunivs = Array.length inst); - (univcst, UContext.make (Array.append inst freshunivs, - create_trivial_subtyping inst freshunivs)) - - let subtyping_other_instance (univcst, subtypcst) = - let (_, ctx') = (halve_context (UContext.instance subtypcst)) in ctx' - - let subtyping_susbst (univcst, subtypcst) = - let (ctx, ctx') = (halve_context (UContext.instance subtypcst)) in - Array.fold_left2 (fun subst l1 l2 -> LMap.add l1 l2 subst) LMap.empty ctx ctx' - end -type cumulativity_info = CumulativityInfo.t - module ACumulativityInfo = CumulativityInfo type abstract_cumulativity_info = ACumulativityInfo.t @@ -1242,7 +1252,17 @@ struct end type universe_context_set = ContextSet.t +(** Instance subtyping *) +let check_subtype univs ctxT ctx = + if AUContext.size ctx == AUContext.size ctx then + let (inst, cst) = AUContext.repr ctx in + let cstT = UContext.constraints (AUContext.repr ctxT) in + let push accu v = add_universe v false accu in + let univs = Array.fold_left push univs inst in + let univs = merge_constraints cstT univs in + check_constraints cst univs + else false (** Substitutions. *) @@ -1263,46 +1283,9 @@ let subst_univs_level_universe subst u = if u == u' then u else Universe.sort u' -(** Substitute instance inst for ctx in csts *) - -let subst_instance_level s l = - match l.Level.data with - | Level.Var n -> s.(n) - | _ -> l - -let subst_instance_instance s i = - Array.smartmap (fun l -> subst_instance_level s l) i - -let subst_instance_universe s u = - let f x = Universe.Expr.map (fun u -> subst_instance_level s u) x in - let u' = Universe.smartmap f u in - if u == u' then u - else Universe.sort u' - -let subst_instance_constraint s (u,d,v as c) = - let u' = subst_instance_level s u in - let v' = subst_instance_level s v in - if u' == u && v' == v then c - else (u',d,v') - -let subst_instance_constraints s csts = - Constraint.fold - (fun c csts -> Constraint.add (subst_instance_constraint s c) csts) - csts Constraint.empty - -let subst_instance_context inst (inner_inst, inner_constr) = - (inner_inst, subst_instance_constraints inst inner_constr) - let make_abstract_instance (ctx, _) = Array.mapi (fun i l -> Level.var i) ctx -(** Substitute instance inst for ctx in csts *) -let instantiate_univ_context (ctx, csts) = - (ctx, subst_instance_constraints ctx csts) - -let instantiate_cumulativity_info (ctx, ctx') = - (instantiate_univ_context ctx, instantiate_univ_context ctx') - (** With level to universe substitutions. *) type universe_subst_fn = universe_level -> universe diff --git a/checker/univ.mli b/checker/univ.mli index 457ccbdff..7f5aa7626 100644 --- a/checker/univ.mli +++ b/checker/univ.mli @@ -18,6 +18,8 @@ sig (** Create a new universe level from a unique identifier and an associated module path. *) + val var : int -> t + val pr : t -> Pp.std_ppcmds (** Pretty-printing *) @@ -179,6 +181,8 @@ sig val length : t -> int (** Compute the length of the instance *) + val of_array : Level.t array -> t + val append : t -> t -> t (** Append two universe instances *) end @@ -208,32 +212,14 @@ module AUContext : sig type t - val instance : t -> Instance.t - -end - -type abstract_universe_context = AUContext.t - -module CumulativityInfo : -sig - type t - - val make : universe_context * universe_context -> t - - val empty : t - - val univ_context : t -> universe_context - val subtyp_context : t -> universe_context - - val from_universe_context : universe_context -> universe_instance -> t + val size : t -> int - val subtyping_other_instance : t -> universe_instance - - val subtyping_susbst : t -> universe_level_subst + val instantiate : Instance.t -> t -> Constraint.t + val repr : t -> UContext.t end -type cumulativity_info = CumulativityInfo.t +type abstract_universe_context = AUContext.t module ACumulativityInfo : sig @@ -276,18 +262,16 @@ val subst_univs_universe : universe_subst_fn -> universe -> universe (** Substitution of instances *) val subst_instance_instance : universe_instance -> universe_instance -> universe_instance val subst_instance_universe : universe_instance -> universe -> universe -val subst_instance_context : universe_instance -> abstract_universe_context -> universe_context (* val make_instance_subst : universe_instance -> universe_level_subst *) (* val make_inverse_instance_subst : universe_instance -> universe_level_subst *) -(** Get the instantiated graph. *) -val instantiate_univ_context : abstract_universe_context -> universe_context -val instantiate_cumulativity_info : abstract_cumulativity_info -> cumulativity_info - (** Build the relative instance corresponding to the context *) val make_abstract_instance : abstract_universe_context -> universe_instance - + +(** Check instance subtyping *) +val check_subtype : universes -> AUContext.t -> AUContext.t -> bool + (** {6 Pretty-printing of universes. } *) val pr_constraint_type : constraint_type -> Pp.std_ppcmds diff --git a/configure.ml b/configure.ml index c75c3d7e1..4eac8eacc 100644 --- a/configure.ml +++ b/configure.ml @@ -11,7 +11,7 @@ #load "str.cma" open Printf -let coq_version = "trunk" +let coq_version = "8.7+alpha" let coq_macos_version = "8.6.90" (** "[...] should be a string comprised of three non-negative, period-separated integers [...]" *) let vo_magic = 8691 @@ -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 8ee1cceb2..bfbf6bb5d 100644 --- a/dev/base_include +++ b/dev/base_include @@ -215,7 +215,7 @@ open Declareops;; let constbody_of_string s = let b = Global.lookup_constant (Nametab.locate_constant (qualid_of_string s)) in - Option.get (Declareops.body_of_constant Opaqueproof.empty_opaquetab b);; + Option.get (Global.body_of_constant_body b);; (* Get the current goal *) (* diff --git a/dev/build/windows/appveyor.sh b/dev/build/windows/appveyor.sh new file mode 100644 index 000000000..53f7a2346 --- /dev/null +++ b/dev/build/windows/appveyor.sh @@ -0,0 +1,8 @@ +#!/bin/bash +set -e -x +wget $opam_url +tar -xf opam64.tar.xz +bash opam64/install.sh +opam init -a mingw https://github.com/fdopen/opam-repository-mingw.git --comp 4.02.3+mingw64c --switch 4.02.3+mingw64c +eval $(opam config env) +opam install -y ocamlfind camlp5 diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index 99ec43e41..656030543 100644 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -79,8 +79,8 @@ ######################################################################## # VST ######################################################################## -: ${VST_CI_BRANCH:=less_init_plugins} -: ${VST_CI_GITURL:=https://github.com/letouzey/VST.git} +: ${VST_CI_BRANCH:=master} +: ${VST_CI_GITURL:=https://github.com/Zimmi48/VST.git} ######################################################################## # fiat_parsers @@ -91,8 +91,8 @@ ######################################################################## # fiat_crypto ######################################################################## -: ${fiat_crypto_CI_BRANCH:=less_init_plugins} -: ${fiat_crypto_CI_GITURL:=https://github.com/letouzey/fiat-crypto.git} +: ${fiat_crypto_CI_BRANCH:=master} +: ${fiat_crypto_CI_GITURL:=https://github.com/mit-plv/fiat-crypto.git} ######################################################################## # formal-topology diff --git a/dev/ci/ci-compcert.sh b/dev/ci/ci-compcert.sh index 0dd904648..4cfe0911b 100755 --- a/dev/ci/ci-compcert.sh +++ b/dev/ci/ci-compcert.sh @@ -9,4 +9,5 @@ opam install -j ${NJOBS} -y menhir git_checkout ${CompCert_CI_BRANCH} ${CompCert_CI_GITURL} ${CompCert_CI_DIR} # Patch to avoid the upper version limit -( cd ${CompCert_CI_DIR} && sed -i.bak 's/8.6)/8.6|trunk)/' configure && ./configure x86_32-linux && make ) +( cd ${CompCert_CI_DIR} && ./configure -ignore-coq-version x86_32-linux && make ) + diff --git a/dev/ci/ci-vst.sh b/dev/ci/ci-vst.sh index 27a336d80..5bfc408e9 100755 --- a/dev/ci/ci-vst.sh +++ b/dev/ci/ci-vst.sh @@ -10,4 +10,4 @@ git_checkout ${VST_CI_BRANCH} ${VST_CI_GITURL} ${VST_CI_DIR} # Targets are: msl veric floyd # Patch to avoid the upper version limit -( cd ${VST_CI_DIR} && sed -i.bak 's/8.6$/8.6 or-else trunk/' Makefile && make ) +( cd ${VST_CI_DIR} && make IGNORECOQVERSION=true ) @@ -32,6 +32,16 @@ install_printer Top_printers.ppeconstr install_printer Top_printers.ppuni install_printer Top_printers.ppuniverses install_printer Top_printers.ppconstraints +install_printer Top_printers.ppuniverse_set +install_printer Top_printers.ppuniverse_instance +install_printer Top_printers.ppuniverse_context +install_printer Top_printers.ppuniverse_context_set +install_printer Top_printers.ppuniverse_subst +install_printer Top_printers.ppuniverse_opt_subst +install_printer Top_printers.ppuniverse_level_subst +install_printer Top_printers.ppevar_universe_context +install_printer Top_printers.ppcumulativity_info +install_printer Top_printers.ppabstract_cumulativity_info install_printer Top_printers.pptype install_printer Top_printers.ppj install_printer Top_printers.ppenv diff --git a/dev/doc/changes.txt b/dev/doc/changes.txt index 159be9a58..57c7a97d5 100644 --- a/dev/doc/changes.txt +++ b/dev/doc/changes.txt @@ -1,4 +1,24 @@ ========================================= += CHANGES BETWEEN COQ V8.7 AND COQ V8.8 = +========================================= + +* ML API * + +We removed the following functions: + +- Universes.unsafe_constr_of_global: use Global.constr_of_global_in_context + instead. The returned term contains De Bruijn universe variables. If you don't + depend on universes being instantiated, simply drop the context. +- Universes.unsafe_type_of_global: same as above with + Global.type_of_global_in_context + +We changed the type of the following functions: + +- Global.body_of_constant_body: now also returns the abstract universe context. + The returned term contains De Bruijn universe variables. +- Global.body_of_constant: same as above. + +========================================= = CHANGES BETWEEN COQ V8.6 AND COQ V8.7 = ========================================= @@ -8,6 +28,16 @@ Coq is compiled with -safe-string enabled and requires plugins to do the same. This means that code using `String` in an imperative way will fail to compile now. They should switch to `Bytes.t` +* Plugin API * + +Coq 8.7 offers a new module overlay containing a proposed plugin API +in `API/API.ml`; this overlay is enabled by adding the `-open API` +flag to the OCaml compiler; this happens automatically for +developments in the `plugin` folder and `coq_makefile`. + +However, `coq_makefile` can be instructed not to enable this flag by +passing `-bypass-API`. + * ML API * Added two functions for declaring hooks to be executed in reduction diff --git a/dev/include b/dev/include index 31ae5da71..0d34595f4 100644 --- a/dev/include +++ b/dev/include @@ -31,6 +31,7 @@ #install_printer (* glob_constr *) ppglob_constr;; #install_printer (* open constr *) ppopenconstr;; #install_printer (* constr *) ppconstr;; +#install_printer (* econstr *) ppeconstr;; #install_printer (* constr_substituted *) ppsconstr;; #install_printer (* constraints *) ppconstraints;; #install_printer (* univ constraints *) ppuniverseconstraints;; diff --git a/doc/refman/Classes.tex b/doc/refman/Classes.tex index 5966ac468..7e07868a3 100644 --- a/doc/refman/Classes.tex +++ b/doc/refman/Classes.tex @@ -486,15 +486,17 @@ where there is a hole in that place. \subsection{\tt Set Typeclasses Legacy Resolution} \optindex{Typeclasses Legacy Resolution} +\emph{Deprecated since 8.7} This option (off by default) uses the 8.5 implementation of resolution. Use for compatibility purposes only (porting and debugging). \subsection{\tt Set Typeclasses Module Eta} \optindex{Typeclasses Modulo Eta} +\emph{Deprecated since 8.7} This option allows eta-conversion for functions and records during -unification of type-classes. This option is now unsupported in 8.6 with +unification of type-classes. This option is unsupported since 8.6 with {\tt Typeclasses Filtered Unification} set, but still affects the default unification strategy, and the one used in {\tt Legacy Resolution} mode. It is \emph{unset} by default. If {\tt Typeclasses @@ -505,7 +507,7 @@ pattern-matching is not up-to eta. \subsection{\tt Set Typeclasses Limit Intros} \optindex{Typeclasses Limit Intros} -This option (on by default in Coq 8.6 and below) controls the ability to +This option (on by default) controls the ability to apply hints while avoiding (functional) eta-expansions in the generated proof term. It does so by allowing hints that conclude in a product to apply to a goal with a matching product directly, avoiding an diff --git a/doc/refman/Program.tex b/doc/refman/Program.tex index 2fc1c8764..f60908da6 100644 --- a/doc/refman/Program.tex +++ b/doc/refman/Program.tex @@ -278,7 +278,8 @@ tactic is replaced by the default one if not specified. as implicit arguments of the special constant \texttt{Program.Tactics.obligation}. \item {\tt Set Shrink Obligations}\optindex{Shrink Obligations} - Control whether obligations should have their +\emph{Deprecated since 8.7} + This option (on by default) controls whether obligations should have their context minimized to the set of variables used in the proof of the obligation, to avoid unnecessary dependencies. \end{itemize} diff --git a/doc/refman/RefMan-ext.tex b/doc/refman/RefMan-ext.tex index f338c3055..713f344cb 100644 --- a/doc/refman/RefMan-ext.tex +++ b/doc/refman/RefMan-ext.tex @@ -705,20 +705,20 @@ when the {\tt FunInd} library has been loaded via {\tt Require Import FunInd}: This command can be seen as a generalization of {\tt Fixpoint}. It is actually a wrapper for several ways of defining a function \emph{and other useful related objects}, namely: an induction principle that reflects the -recursive structure of the function (see \ref{FunInduction}), and its +recursive structure of the function (see \ref{FunInduction}) and its fixpoint equality. The meaning of this declaration is to define a function {\it ident}, similarly to {\tt Fixpoint}. Like in {\tt Fixpoint}, the decreasing argument must be -given (unless the function is not recursive), but it must not -necessary be \emph{structurally} decreasing. The point of the {\tt +given (unless the function is not recursive), but it might not +necessarily be \emph{structurally} decreasing. The point of the {\tt \{\}} annotation is to name the decreasing argument \emph{and} to describe which kind of decreasing criteria must be used to ensure termination of recursive calls. -The {\tt Function} construction enjoys also the {\tt with} extension +The {\tt Function} construction also enjoys the {\tt with} extension to define mutually recursive definitions. However, this feature does -not work for non structural recursive functions. % VRAI?? +not work for non structurally recursive functions. % VRAI?? See the documentation of {\tt functional induction} (see Section~\ref{FunInduction}) and {\tt Functional Scheme} @@ -749,7 +749,7 @@ Function plus (n m : nat) {struct n} : nat := \end{coq_example*} \paragraph[Limitations]{Limitations\label{sec:Function-limitations}} -\term$_0$ must be build as a \emph{pure pattern-matching tree} +\term$_0$ must be built as a \emph{pure pattern-matching tree} (\texttt{match...with}) with applications only \emph{at the end} of each branch. @@ -776,7 +776,7 @@ For now dependent cases are not treated for non structurally terminating functio The generation of the graph relation \texttt{(R\_\ident)} used to compute the induction scheme of \ident\ raised a typing error. Only - the ident is defined, the induction scheme will not be generated. + the ident is defined; the induction scheme will not be generated. This error happens generally when: @@ -848,14 +848,14 @@ the following: being the decreasing argument and \term$_1$ being a function from type of \ident$_0$ to \texttt{nat} for which value on the decreasing argument decreases (for the {\tt lt} order on {\tt - nat}) at each recursive call of \term$_0$, parameters of the + nat}) at each recursive call of \term$_0$. Parameters of the function are bound in \term$_0$; \item {\tt \{wf} \term$_1$ \ident$_0${\tt\}} with \ident$_0$ being the decreasing argument and \term$_1$ an ordering relation on the type of \ident$_0$ (i.e. of type T$_{\ident_0}$ $\to$ T$_{\ident_0}$ $\to$ {\tt Prop}) for which the decreasing argument decreases at each recursive call of - \term$_0$. The order must be well founded. parameters of the + \term$_0$. The order must be well founded. Parameters of the function are bound in \term$_0$. \end{itemize} diff --git a/doc/refman/RefMan-ind.tex b/doc/refman/RefMan-ind.tex deleted file mode 100644 index 43bd2419f..000000000 --- a/doc/refman/RefMan-ind.tex +++ /dev/null @@ -1,510 +0,0 @@ - -%\documentstyle[11pt]{article} -%\input{title} - -%\include{macros} -%\makeindex - -%\begin{document} -%\coverpage{The module {\tt Equality}}{Cristina CORNES} - -%\tableofcontents - -\chapter[Tactics for inductive types and families]{Tactics for inductive types and families\label{Addoc-equality}} - -This chapter details a few special tactics useful for inferring facts -from inductive hypotheses. They can be considered as tools that -macro-generate complicated uses of the basic elimination tactics for -inductive types. - -Sections \ref{inversion_introduction} to \ref{inversion_using} present -inversion tactics and Section~\ref{scheme} describes -a command {\tt Scheme} for automatic generation of induction schemes -for mutual inductive types. - -%\end{document} -%\documentstyle[11pt]{article} -%\input{title} - -%\begin{document} -%\coverpage{Module Inv: Inversion Tactics}{Cristina CORNES} - -\section[Generalities about inversion]{Generalities about inversion\label{inversion_introduction}} -When working with (co)inductive predicates, we are very often faced to -some of these situations: -\begin{itemize} -\item we have an inconsistent instance of an inductive predicate in the - local context of hypotheses. Thus, the current goal can be trivially - proved by absurdity. - -\item we have a hypothesis that is an instance of an inductive - predicate, and the instance has some variables whose constraints we - would like to derive. -\end{itemize} - -The inversion tactics are very useful to simplify the work in these -cases. Inversion tools can be classified in three groups: -\begin{enumerate} -\item tactics for inverting an instance without stocking the inversion - lemma in the context: - (\texttt{Dependent}) \texttt{Inversion} and - (\texttt{Dependent}) \texttt{Inversion\_clear}. -\item commands for generating and stocking in the context the inversion - lemma corresponding to an instance: \texttt{Derive} - (\texttt{Dependent}) \texttt{Inversion}, \texttt{Derive} - (\texttt{Dependent}) \texttt{Inversion\_clear}. -\item tactics for inverting an instance using an already defined - inversion lemma: \texttt{Inversion \ldots using}. -\end{enumerate} - -These tactics work for inductive types of arity $(\vec{x}:\vec{T})s$ -where $s \in \{Prop,Set,Type\}$. Sections \ref{inversion_primitive}, -\ref{inversion_derivation} and \ref{inversion_using} -describe respectively each group of tools. - -As inversion proofs may be large in size, we recommend the user to -stock the lemmas whenever the same instance needs to be inverted -several times.\\ - -Let's consider the relation \texttt{Le} over natural numbers and the -following variables: - -\begin{coq_eval} -Restore State "Initial". -\end{coq_eval} - -\begin{coq_example*} -Inductive Le : nat -> nat -> Set := - | LeO : forall n:nat, Le 0%N n - | LeS : forall n m:nat, Le n m -> Le (S n) (S m). -Variable P : nat -> nat -> Prop. -Variable Q : forall n m:nat, Le n m -> Prop. -\end{coq_example*} - -For example purposes we defined \verb+Le: nat->nat->Set+ - but we may have defined -it \texttt{Le} of type \verb+nat->nat->Prop+ or \verb+nat->nat->Type+. - - -\section[Inverting an instance]{Inverting an instance\label{inversion_primitive}} -\subsection{The non dependent case} -\begin{itemize} - -\item \texttt{Inversion\_clear} \ident~\\ -\index{Inversion-clear@{\tt Inversion\_clear}} - Let the type of \ident~ in the local context be $(I~\vec{t})$, - where $I$ is a (co)inductive predicate. Then, - \texttt{Inversion} applied to \ident~ derives for each possible - constructor $c_i$ of $(I~\vec{t})$, {\bf all} the necessary - conditions that should hold for the instance $(I~\vec{t})$ to be - proved by $c_i$. Finally it erases \ident~ from the context. - - - -For example, consider the goal: -\begin{coq_eval} -Lemma ex : forall n m:nat, Le (S n) m -> P n m. -intros. -\end{coq_eval} - -\begin{coq_example} -Show. -\end{coq_example} - -To prove the goal we may need to reason by cases on \texttt{H} and to - derive that \texttt{m} is necessarily of -the form $(S~m_0)$ for certain $m_0$ and that $(Le~n~m_0)$. -Deriving these conditions corresponds to prove that the -only possible constructor of \texttt{(Le (S n) m)} is -\texttt{LeS} and that we can invert the -\texttt{->} in the type of \texttt{LeS}. -This inversion is possible because \texttt{Le} is the smallest set closed by -the constructors \texttt{LeO} and \texttt{LeS}. - - -\begin{coq_example} -inversion_clear H. -\end{coq_example} - -Note that \texttt{m} has been substituted in the goal for \texttt{(S m0)} -and that the hypothesis \texttt{(Le n m0)} has been added to the -context. - -\item \texttt{Inversion} \ident~\\ -\index{Inversion@{\tt Inversion}} - This tactic differs from {\tt Inversion\_clear} in the fact that - it adds the equality constraints in the context and - it does not erase the hypothesis \ident. - - -In the previous example, {\tt Inversion\_clear} -has substituted \texttt{m} by \texttt{(S m0)}. Sometimes it is -interesting to have the equality \texttt{m=(S m0)} in the -context to use it after. In that case we can use \texttt{Inversion} that -does not clear the equalities: - -\begin{coq_example*} -Undo. -\end{coq_example*} -\begin{coq_example} -inversion H. -\end{coq_example} - -\begin{coq_eval} -Undo. -\end{coq_eval} - -Note that the hypothesis \texttt{(S m0)=m} has been deduced and -\texttt{H} has not been cleared from the context. - -\end{itemize} - -\begin{Variants} - -\item \texttt{Inversion\_clear } \ident~ \texttt{in} \ident$_1$ \ldots - \ident$_n$\\ -\index{Inversion_clear...in@{\tt Inversion\_clear...in}} - Let \ident$_1$ \ldots \ident$_n$, be identifiers in the local context. This - tactic behaves as generalizing \ident$_1$ \ldots \ident$_n$, and then performing - {\tt Inversion\_clear}. - -\item \texttt{Inversion } \ident~ \texttt{in} \ident$_1$ \ldots \ident$_n$\\ -\index{Inversion ... in@{\tt Inversion ... in}} - Let \ident$_1$ \ldots \ident$_n$, be identifiers in the local context. This - tactic behaves as generalizing \ident$_1$ \ldots \ident$_n$, and then performing - \texttt{Inversion}. - - -\item \texttt{Simple Inversion} \ident~ \\ -\index{Simple Inversion@{\tt Simple Inversion}} - It is a very primitive inversion tactic that derives all the necessary - equalities but it does not simplify - the constraints as \texttt{Inversion} and - {\tt Inversion\_clear} do. - -\end{Variants} - - -\subsection{The dependent case} -\begin{itemize} -\item \texttt{Dependent Inversion\_clear} \ident~\\ -\index{Dependent Inversion-clear@{\tt Dependent Inversion\_clear}} - Let the type of \ident~ in the local context be $(I~\vec{t})$, - where $I$ is a (co)inductive predicate, and let the goal depend both on - $\vec{t}$ and \ident. Then, - \texttt{Dependent Inversion\_clear} applied to \ident~ derives - for each possible constructor $c_i$ of $(I~\vec{t})$, {\bf all} the - necessary conditions that should hold for the instance $(I~\vec{t})$ to be - proved by $c_i$. It also substitutes \ident~ for the corresponding - term in the goal and it erases \ident~ from the context. - - -For example, consider the goal: -\begin{coq_eval} -Lemma ex_dep : forall (n m:nat) (H:Le (S n) m), Q (S n) m H. -intros. -\end{coq_eval} - -\begin{coq_example} -Show. -\end{coq_example} - -As \texttt{H} occurs in the goal, we may want to reason by cases on its -structure and so, we would like inversion tactics to -substitute \texttt{H} by the corresponding term in constructor form. -Neither \texttt{Inversion} nor {\tt Inversion\_clear} make such a -substitution. To have such a behavior we use the dependent inversion tactics: - -\begin{coq_example} -dependent inversion_clear H. -\end{coq_example} - -Note that \texttt{H} has been substituted by \texttt{(LeS n m0 l)} and -\texttt{m} by \texttt{(S m0)}. - - -\end{itemize} - -\begin{Variants} - -\item \texttt{Dependent Inversion\_clear } \ident~ \texttt{ with } \term\\ -\index{Dependent Inversion_clear...with@{\tt Dependent Inversion\_clear...with}} - \noindent Behaves as \texttt{Dependent Inversion\_clear} but allows giving - explicitly the good generalization of the goal. It is useful when - the system fails to generalize the goal automatically. If - \ident~ has type $(I~\vec{t})$ and $I$ has type - $(\vec{x}:\vec{T})s$, then \term~ must be of type - $I:(\vec{x}:\vec{T})(I~\vec{x})\rightarrow s'$ where $s'$ is the - type of the goal. - - - -\item \texttt{Dependent Inversion} \ident~\\ -\index{Dependent Inversion@{\tt Dependent Inversion}} - This tactic differs from \texttt{Dependent Inversion\_clear} in the fact that - it also adds the equality constraints in the context and - it does not erase the hypothesis \ident~. - -\item \texttt{Dependent Inversion } \ident~ \texttt{ with } \term \\ -\index{Dependent Inversion...with@{\tt Dependent Inversion...with}} - Analogous to \texttt{Dependent Inversion\_clear .. with..} above. -\end{Variants} - - - -\section[Deriving the inversion lemmas]{Deriving the inversion lemmas\label{inversion_derivation}} -\subsection{The non dependent case} - -The tactics (\texttt{Dependent}) \texttt{Inversion} and (\texttt{Dependent}) -{\tt Inversion\_clear} work on a -certain instance $(I~\vec{t})$ of an inductive predicate. At each -application, they inspect the given instance and derive the -corresponding inversion lemma. If we have to invert the same -instance several times it is recommended to stock the lemma in the -context and to reuse it whenever we need it. - -The families of commands \texttt{Derive Inversion}, \texttt{Derive -Dependent Inversion}, \texttt{Derive} \\ {\tt Inversion\_clear} and \texttt{Derive Dependent Inversion\_clear} -allow to generate inversion lemmas for given instances and sorts. Next -section describes the tactic \texttt{Inversion}$\ldots$\texttt{using} that refines the -goal with a specified inversion lemma. - -\begin{itemize} - -\item \texttt{Derive Inversion\_clear} \ident~ \texttt{with} - $(\vec{x}:\vec{T})(I~\vec{t})$ \texttt{Sort} \sort~ \\ -\index{Derive Inversion_clear...with@{\tt Derive Inversion\_clear...with}} - Let $I$ be an inductive predicate and $\vec{x}$ the variables - occurring in $\vec{t}$. This command generates and stocks - the inversion lemma for the sort \sort~ corresponding to the instance - $(\vec{x}:\vec{T})(I~\vec{t})$ with the name \ident~ in the {\bf - global} environment. When applied it is equivalent to have - inverted the instance with the tactic {\tt Inversion\_clear}. - - - For example, to generate the inversion lemma for the instance - \texttt{(Le (S n) m)} and the sort \texttt{Prop} we do: -\begin{coq_example} -Derive Inversion_clear leminv with (forall n m:nat, Le (S n) m) Sort - Prop. -\end{coq_example} - -Let us inspect the type of the generated lemma: -\begin{coq_example} -Check leminv. -\end{coq_example} - - - -\end{itemize} - -%\variants -%\begin{enumerate} -%\item \verb+Derive Inversion_clear+ \ident$_1$ \ident$_2$ \\ -%\index{Derive Inversion_clear@{\tt Derive Inversion\_clear}} -% Let \ident$_1$ have type $(I~\vec{t})$ in the local context ($I$ -% an inductive predicate). Then, this command has the same semantics -% as \verb+Derive Inversion_clear+ \ident$_2$~ \verb+with+ -% $(\vec{x}:\vec{T})(I~\vec{t})$ \verb+Sort Prop+ where $\vec{x}$ are the free -% variables of $(I~\vec{t})$ declared in the local context (variables -% of the global context are considered as constants). -%\item \verb+Derive Inversion+ \ident$_1$~ \ident$_2$~\\ -%\index{Derive Inversion@{\tt Derive Inversion}} -% Analogous to the previous command. -%\item \verb+Derive Inversion+ $num$ \ident~ \ident~ \\ -%\index{Derive Inversion@{\tt Derive Inversion}} -% This command behaves as \verb+Derive Inversion+ \ident~ {\it -% namehyp} performed on the goal number $num$. -% -%\item \verb+Derive Inversion_clear+ $num$ \ident~ \ident~ \\ -%\index{Derive Inversion_clear@{\tt Derive Inversion\_clear}} -% This command behaves as \verb+Derive Inversion_clear+ \ident~ -% \ident~ performed on the goal number $num$. -%\end{enumerate} - - - -A derived inversion lemma is adequate for inverting the instance -with which it was generated, \texttt{Derive} applied to -different instances yields different lemmas. In general, if we generate -the inversion lemma with -an instance $(\vec{x}:\vec{T})(I~\vec{t})$ and a sort $s$, the inversion lemma will -expect a predicate of type $(\vec{x}:\vec{T})s$ as first argument. \\ - -\begin{Variant} -\item \texttt{Derive Inversion} \ident~ \texttt{with} - $(\vec{x}:\vec{T})(I~\vec{t})$ \texttt{Sort} \sort\\ -\index{Derive Inversion...with@{\tt Derive Inversion...with}} - Analogous of \texttt{Derive Inversion\_clear .. with ..} but - when applied it is equivalent to having - inverted the instance with the tactic \texttt{Inversion}. -\end{Variant} - -\subsection{The dependent case} -\begin{itemize} -\item \texttt{Derive Dependent Inversion\_clear} \ident~ \texttt{with} - $(\vec{x}:\vec{T})(I~\vec{t})$ \texttt{Sort} \sort~ \\ -\index{Derive Dependent Inversion\_clear...with@{\tt Derive Dependent Inversion\_clear...with}} - Let $I$ be an inductive predicate. This command generates and stocks - the dependent inversion lemma for the sort \sort~ corresponding to the instance - $(\vec{x}:\vec{T})(I~\vec{t})$ with the name \ident~ in the {\bf - global} environment. When applied it is equivalent to having - inverted the instance with the tactic \texttt{Dependent Inversion\_clear}. -\end{itemize} - -\begin{coq_example} -Derive Dependent Inversion_clear leminv_dep with - (forall n m:nat, Le (S n) m) Sort Prop. -\end{coq_example} - -\begin{coq_example} -Check leminv_dep. -\end{coq_example} - -\begin{Variants} -\item \texttt{Derive Dependent Inversion} \ident~ \texttt{with} - $(\vec{x}:\vec{T})(I~\vec{t})$ \texttt{Sort} \sort~ \\ -\index{Derive Dependent Inversion...with@{\tt Derive Dependent Inversion...with}} - Analogous to \texttt{Derive Dependent Inversion\_clear}, but when - applied it is equivalent to having - inverted the instance with the tactic \texttt{Dependent Inversion}. - -\end{Variants} - -\section[Using already defined inversion lemmas]{Using already defined inversion lemmas\label{inversion_using}} -\begin{itemize} -\item \texttt{Inversion} \ident \texttt{ using} \ident$'$ \\ -\index{Inversion...using@{\tt Inversion...using}} - Let \ident~ have type $(I~\vec{t})$ ($I$ an inductive - predicate) in the local context, and \ident$'$ be a (dependent) inversion - lemma. Then, this tactic refines the current goal with the specified - lemma. - - -\begin{coq_eval} -Abort. -\end{coq_eval} - -\begin{coq_example} -Show. -\end{coq_example} -\begin{coq_example} -inversion H using leminv. -\end{coq_example} - - -\end{itemize} -\variant -\begin{enumerate} -\item \texttt{Inversion} \ident~ \texttt{using} \ident$'$ \texttt{in} \ident$_1$\ldots \ident$_n$\\ -\index{Inversion...using...in@{\tt Inversion...using...in}} -This tactic behaves as generalizing \ident$_1$\ldots \ident$_n$, -then doing \texttt{Use Inversion} \ident~\ident$'$. -\end{enumerate} - -\section[\tt Scheme ...]{\tt Scheme ...\index{Scheme@{\tt Scheme}}\label{Scheme} -\label{scheme}} -The {\tt Scheme} command is a high-level tool for generating -automatically (possibly mutual) induction principles for given types -and sorts. Its syntax follows the schema : - -\noindent -{\tt Scheme {\ident$_1$} := Induction for \term$_1$ Sort {\sort$_1$} \\ - with\\ - \mbox{}\hspace{0.1cm} .. \\ - with {\ident$_m$} := Induction for {\term$_m$} Sort - {\sort$_m$}}\\ -\term$_1$ \ldots \term$_m$ are different inductive types belonging to -the same package of mutual inductive definitions. This command -generates {\ident$_1$}\ldots{\ident$_m$} to be mutually recursive -definitions. Each term {\ident$_i$} proves a general principle -of mutual induction for objects in type {\term$_i$}. - -\Example -The definition of principle of mutual induction for {\tt tree} and -{\tt forest} over the sort {\tt Set} is defined by the command: -\begin{coq_eval} -Restore State "Initial". -Variables A B : Set. -Inductive tree : Set := - node : A -> forest -> tree -with forest : Set := - | leaf : B -> forest - | cons : tree -> forest -> forest. -\end{coq_eval} -\begin{coq_example*} -Scheme tree_forest_rec := Induction for tree - Sort Set - with forest_tree_rec := Induction for forest Sort Set. -\end{coq_example*} -You may now look at the type of {\tt tree\_forest\_rec} : -\begin{coq_example} -Check tree_forest_rec. -\end{coq_example} -This principle involves two different predicates for {\tt trees} and -{\tt forests}; it also has three premises each one corresponding to a -constructor of one of the inductive definitions. - -The principle {\tt tree\_forest\_rec} shares exactly the same -premises, only the conclusion now refers to the property of forests. -\begin{coq_example} -Check forest_tree_rec. -\end{coq_example} - -\begin{Variant} -\item {\tt Scheme {\ident$_1$} := Minimality for \term$_1$ Sort {\sort$_1$} \\ - with\\ - \mbox{}\hspace{0.1cm} .. \\ - with {\ident$_m$} := Minimality for {\term$_m$} Sort - {\sort$_m$}}\\ -Same as before but defines a non-dependent elimination principle more -natural in case of inductively defined relations. -\end{Variant} - -\Example -With the predicates {\tt odd} and {\tt even} inductively defined as: -% \begin{coq_eval} -% Restore State "Initial". -% \end{coq_eval} -\begin{coq_example*} -Inductive odd : nat -> Prop := - oddS : forall n:nat, even n -> odd (S n) -with even : nat -> Prop := - | evenO : even 0%N - | evenS : forall n:nat, odd n -> even (S n). -\end{coq_example*} -The following command generates a powerful elimination -principle: -\begin{coq_example*} -Scheme odd_even := Minimality for odd Sort Prop - with even_odd := Minimality for even Sort Prop. -\end{coq_example*} -The type of {\tt odd\_even} for instance will be: -\begin{coq_example} -Check odd_even. -\end{coq_example} -The type of {\tt even\_odd} shares the same premises but the -conclusion is {\tt (n:nat)(even n)->(Q n)}. - -\subsection[\tt Combined Scheme ...]{\tt Combined Scheme ...\index{CombinedScheme@{\tt Combined Scheme}}\label{CombinedScheme} -\label{combinedscheme}} -The {\tt Combined Scheme} command is a tool for combining -induction principles generated by the {\tt Scheme} command. -Its syntax follows the schema : - -\noindent -{\tt Combined Scheme {\ident$_0$} from {\ident$_1$}, .., {\ident$_n$}}\\ -\ident$_1$ \ldots \ident$_n$ are different inductive principles that must belong to -the same package of mutual inductive principle definitions. This command -generates {\ident$_0$} to be the conjunction of the principles: it is -build from the common premises of the principles and concluded by the -conjunction of their conclusions. For exemple, we can combine the -induction principles for trees and forests: - -\begin{coq_example*} -Combined Scheme tree_forest_mutind from tree_ind, forest_ind. -Check tree_forest_mutind. -\end{coq_example*} - -%\end{document} - diff --git a/doc/refman/RefMan-ltac.tex b/doc/refman/RefMan-ltac.tex index f3bc2dd05..3ce1d4ecd 100644 --- a/doc/refman/RefMan-ltac.tex +++ b/doc/refman/RefMan-ltac.tex @@ -1131,8 +1131,9 @@ on. This can be obtained thanks to the option below. \optindex{Shrink Abstract} {\tt Set Shrink Abstract} \end{quote} +\emph{Deprecated since 8.7} -When set, all lemmas generated through \texttt{abstract {\tacexpr}} +When set (default), all lemmas generated through \texttt{abstract {\tacexpr}} and \texttt{transparent\_abstract {\tacexpr}} are quantified only over the variables that appear in the term constructed by \texttt{\tacexpr}. diff --git a/doc/refman/RefMan-tac.tex b/doc/refman/RefMan-tac.tex index 4931ca3b6..a23c43232 100644 --- a/doc/refman/RefMan-tac.tex +++ b/doc/refman/RefMan-tac.tex @@ -352,7 +352,7 @@ Section~\ref{pattern} to transform the goal so that it gets the form The tactic {\tt eapply} behaves like {\tt apply} but it does not fail when no instantiations are deducible for some variables in the - premises. Rather, it turns these variables into + premises. Rather, it turns these variables into existential variables which are variables still to instantiate (see Section~\ref{evars}). The instantiation is intended to be found later in the proof. @@ -1411,7 +1411,7 @@ in the list of subgoals remaining to prove. quantifications or non-dependent implications) are instantiated by concrete terms coming either from arguments \term$_1$ $\ldots$ \term$_n$ or from a bindings list (see - Section~\ref{Binding-list} for more about bindings lists). + Section~\ref{Binding-list} for more about bindings lists). In the first form the application to \term$_1$ {\ldots} \term$_n$ can be partial. The first form is equivalent to {\tt assert ({\ident} := {\ident} {\term$_1$} \dots\ \term$_n$)}. @@ -2604,6 +2604,21 @@ Abort. This tactic behaves as generalizing \ident$_1$\dots\ \ident$_n$, then doing \texttt{inversion {\ident} using \ident$'$}. +\item \tacindex{inversion\_sigma} \texttt{inversion\_sigma} + + This tactic turns equalities of dependent pairs (e.g., + \texttt{existT P x p = existT P y q}, frequently left over by + \texttt{inversion} on a dependent type family) into pairs of + equalities (e.g., a hypothesis \texttt{H : x = y} and a hypothesis + of type \texttt{rew H in p = q}); these hypotheses can subsequently + be simplified using \texttt{subst}, without ever invoking any kind + of axiom asserting uniqueness of identity proofs. If you want to + explicitly specify the hypothesis to be inverted, or name the + generated hypotheses, you can invoke \texttt{induction H as [H1 H2] + using eq\_sigT\_rect}. This tactic also works for \texttt{sig}, + \texttt{sigT2}, and \texttt{sig2}, and there are similar + \texttt{eq\_sig\emph{*}\_rect} induction lemmas. + \end{Variants} \firstexample @@ -2698,6 +2713,64 @@ dependent inversion_clear H. Note that \texttt{H} has been substituted by \texttt{(LeS n m0 l)} and \texttt{m} by \texttt{(S m0)}. +\example{Using \texorpdfstring{\texttt{inversion\_sigma}}{inversion\_sigma}} + +Let us consider the following inductive type of length-indexed lists, +and a lemma about inverting equality of \texttt{cons}: + +\begin{coq_eval} +Reset Initial. +Set Printing Compact Contexts. +\end{coq_eval} + +\begin{coq_example*} +Require Coq.Logic.Eqdep_dec. + +Inductive vec A : nat -> Type := +| nil : vec A O +| cons {n} (x : A) (xs : vec A n) : vec A (S n). + +Lemma invert_cons : forall A n x xs y ys, + @cons A n x xs = @cons A n y ys + -> xs = ys. +Proof. +\end{coq_example*} + +\begin{coq_example} +intros A n x xs y ys H. +\end{coq_example} + +After performing \texttt{inversion}, we are left with an equality of +\texttt{existT}s: + +\begin{coq_example} +inversion H. +\end{coq_example} + +We can turn this equality into a usable form with +\texttt{inversion\_sigma}: + +\begin{coq_example} +inversion_sigma. +\end{coq_example} + +To finish cleaning up the proof, we will need to use the fact that +that all proofs of \texttt{n = n} for \texttt{n} a \texttt{nat} are +\texttt{eq\_refl}: + +\begin{coq_example} +let H := match goal with H : n = n |- _ => H end in +pose proof (Eqdep_dec.UIP_refl_nat _ H); subst H. +simpl in *. +\end{coq_example} + +Finally, we can finish the proof: + +\begin{coq_example} +assumption. +Qed. +\end{coq_example} + \subsection{\tt fix {\ident} {\num}} \tacindex{fix} \label{tactic:fix} @@ -2998,7 +3071,7 @@ activated, {\tt subst} also deals with the following corner cases: \item The presence of a recursive equation which without the option would be a cause of failure of {\tt subst}. - + \item A context with cyclic dependencies as with hypotheses {\tt \ident$_1$ = f~\ident$_2$} and {\tt \ident$_2$ = g~\ident$_1$} which without the option would be a cause of failure of {\tt subst}. @@ -3293,7 +3366,7 @@ a sort of strong normalization with two key differences: \begin{itemize} \item They unfold a constant if and only if it leads to a $\iota$-reduction, i.e. reducing a match or unfolding a fixpoint. -\item While reducing a constant unfolding to (co)fixpoints, +\item While reducing a constant unfolding to (co)fixpoints, the tactics use the name of the constant the (co)fixpoint comes from instead of the (co)fixpoint definition in recursive calls. @@ -3412,6 +3485,7 @@ reduced to \texttt{S t}. \optindex{Refolding Reduction} {\tt Refolding Reduction} \end{quote} +\emph{Deprecated since 8.7} This option (off by default) controls the use of the refolding strategy of {\tt cbn} while doing reductions in unification, type inference and @@ -4024,7 +4098,7 @@ Abort. & & e * & \text{ Kleene star } \\ & & \texttt{emp} & \text{ empty } \\ & & \texttt{eps} & \text{ epsilon } \\ - & & \texttt{(} e \texttt{)} & + & & \texttt{(} e \texttt{)} & \end{array}\] The \texttt{emp} regexp does not match any search path while @@ -5188,7 +5262,7 @@ Reset Initial. \subsection[\tt swap \num$_1$ \num$_2$]{\tt swap \num$_1$ \num$_2$\tacindex{swap}} -This tactic switches the position of the goals of indices $\num_1$ and $\num_2$. If either $\num_1$ or $\num_2$ is negative then goals are counted from the end of the focused goal list. Goals are indexed from $1$, there is no goal with position $0$. +This tactic switches the position of the goals of indices $\num_1$ and $\num_2$. If either $\num_1$ or $\num_2$ is negative then goals are counted from the end of the focused goal list. Goals are indexed from $1$, there is no goal with position $0$. \Example \begin{coq_example*} diff --git a/doc/refman/RefMan-uti.tex b/doc/refman/RefMan-uti.tex index fee4de336..768d0df76 100644 --- a/doc/refman/RefMan-uti.tex +++ b/doc/refman/RefMan-uti.tex @@ -60,7 +60,7 @@ subdirectory of the sources. The majority of \Coq\ projects are very similar: a collection of {\tt .v} files and eventually some {\tt .ml} ones (a \Coq\ plugin). The main piece -of metadata needed in order to build the project are the command +of metadata needed in order to build the project are the command line options to {\tt coqc} (e.g. {\tt -R, -I}, \SeeAlso Section~\ref{coqoptions}). Collecting the list of files and options is the job of the {\tt \_CoqProject} file. @@ -108,12 +108,171 @@ used in order to decide how to build them. In particular: \end{itemize} The use of \texttt{.mlpack} files has to be preferred over \texttt{.mllib} -files, since it results in a ``packed'' plugin: All auxiliary +files, since it results in a ``packed'' plugin: All auxiliary modules (as {\tt Baz} and {\tt Bazaux}) are hidden inside the plugin's ``name space'' ({\tt Qux\_plugin}). This reduces the chances of begin unable to load two distinct plugins because of a clash in their auxiliary module names. +\paragraph{Timing targets and performance testing} +The generated \texttt{Makefile} supports the generation of two kinds +of timing data: per-file build-times, and per-line times for an +individual file. + +The following targets and \texttt{Makefile} variables allow collection +of per-file timing data: +\begin{itemize} +\item \texttt{TIMED=1} --- passing this variable will cause + \texttt{make} to emit a line describing the user-space build-time + and peak memory usage for each file built. + + \texttt{Note}: On Mac OS, this works best if you've installed + \texttt{gnu-time}. + + \texttt{Example}: For example, the output of \texttt{make TIMED=1} + may look like this: +\begin{verbatim} +COQDEP Fast.v +COQDEP Slow.v +COQC Slow.v +Slow (user: 0.34 mem: 395448 ko) +COQC Fast.v +Fast (user: 0.01 mem: 45184 ko) +\end{verbatim} +\item \texttt{pretty-timed} --- this target stores the output of + \texttt{make TIMED=1} into \texttt{time-of-build.log}, and displays + a table of the times, sorted from slowest to fastest, which is also + stored in \texttt{time-of-build-pretty.log}. If you want to + construct the log for targets other than the default one, you can + pass them via the variable \texttt{TGTS}, e.g., \texttt{make + pretty-timed TGTS="a.vo b.vo"}. + + \texttt{Note}: This target requires \texttt{python} to build the table. + + \texttt{Note}: This target will \emph{append} to the timing log; if + you want a fresh start, you must remove the file + \texttt{time-of-build.log} or run \texttt{make cleanall}. + + \texttt{Example}: For example, the output of \texttt{make + pretty-timed} may look like this: +\begin{verbatim} +COQDEP Fast.v +COQDEP Slow.v +COQC Slow.v +Slow (user: 0.36 mem: 393912 ko) +COQC Fast.v +Fast (user: 0.05 mem: 45992 ko) +Time | File Name +-------------------- +0m00.41s | Total +-------------------- +0m00.36s | Slow +0m00.05s | Fast +\end{verbatim} +\item \texttt{print-pretty-timed-diff} --- this target builds a table + of timing changes between two compilations; run \texttt{make + make-pretty-timed-before} to build the log of the ``before'' + times, and run \texttt{make make-pretty-timed-after} to build the + log of the ``after'' times. The table is printed on the command + line, and stored in \texttt{time-of-build-both.log}. This target is + most useful for profiling the difference between two commits to a + repo. + + \texttt{Note}: This target requires \texttt{python} to build the table. + + \texttt{Note}: The \texttt{make-pretty-timed-before} and + \texttt{make-pretty-timed-after} targets will \emph{append} to the + timing log; if you want a fresh start, you must remove the files + \texttt{time-of-build-before.log} and + \texttt{time-of-build-after.log} or run \texttt{make cleanall} + \emph{before} building either the ``before'' or ``after'' targets. + + \texttt{Note}: The table will be sorted first by absolute time + differences rounded towards zero to a whole-number of seconds, then + by times in the ``after'' column, and finally lexicographically by + file name. This will put the biggest changes in either direction + first, and will prefer sorting by build-time over subsecond changes + in build time (which are frequently noise); lexicographic sorting + forces an order on files which take effectively no time to compile. + + \texttt{Example}: For example, the output table from \texttt{make + print-pretty-timed-diff} may look like this: +\begin{verbatim} +After | File Name | Before || Change | % Change +-------------------------------------------------------- +0m00.39s | Total | 0m00.35s || +0m00.03s | +11.42% +-------------------------------------------------------- +0m00.37s | Slow | 0m00.01s || +0m00.36s | +3600.00% +0m00.02s | Fast | 0m00.34s || -0m00.32s | -94.11% +\end{verbatim} +\end{itemize} + +The following targets and \texttt{Makefile} variables allow collection +of per-line timing data: +\begin{itemize} +\item \texttt{TIMING=1} --- passing this variable will cause + \texttt{make} to use \texttt{coqc -time} to write to a + \texttt{.v.timing} file for each \texttt{.v} file compiled, which + contains line-by-line timing information. + + \texttt{Example}: For example, running \texttt{make all TIMING=1} may + result in a file like this: +\begin{verbatim} +Chars 0 - 26 [Require~Coq.ZArith.BinInt.] 0.157 secs (0.128u,0.028s) +Chars 27 - 68 [Declare~Reduction~comp~:=~vm_c...] 0. secs (0.u,0.s) +Chars 69 - 162 [Definition~foo0~:=~Eval~comp~i...] 0.153 secs (0.136u,0.019s) +Chars 163 - 208 [Definition~foo1~:=~Eval~comp~i...] 0.239 secs (0.236u,0.s) +\end{verbatim} + +\item \texttt{print-pretty-single-time-diff + BEFORE=path/to/file.v.before-timing + AFTER=path/to/file.v.after-timing} --- this target will make a + sorted table of the per-line timing differences between the timing + logs in the \texttt{BEFORE} and \texttt{AFTER} files, display it, + and save it to the file specified by the + \texttt{TIME\_OF\_PRETTY\_BUILD\_FILE} variable, which defaults to + \texttt{time-of-build-pretty.log}. + + To generate the \texttt{.v.before-timing} or + \texttt{.v.after-timing} files, you should pass + \texttt{TIMING=before} or \texttt{TIMING=after} rather than + \texttt{TIMING=1}. + + \texttt{Note}: The sorting used here is the same as in the + \texttt{print-pretty-timed-diff} target. + + \texttt{Note}: This target requires \texttt{python} to build the table. + + \texttt{Example}: For example, running + \texttt{print-pretty-single-time-diff} might give a table like this: +\begin{verbatim} +After | Code | Before || Change | % Change +--------------------------------------------------------------------------------------------------- +0m00.50s | Total | 0m04.17s || -0m03.66s | -87.96% +--------------------------------------------------------------------------------------------------- +0m00.145s | Chars 069 - 162 [Definition~foo0~:=~Eval~comp~i...] | 0m00.192s || -0m00.04s | -24.47% +0m00.126s | Chars 000 - 026 [Require~Coq.ZArith.BinInt.] | 0m00.143s || -0m00.01s | -11.88% + N/A | Chars 027 - 068 [Declare~Reduction~comp~:=~nati...] | 0m00.s || +0m00.00s | N/A +0m00.s | Chars 027 - 068 [Declare~Reduction~comp~:=~vm_c...] | N/A || +0m00.00s | N/A +0m00.231s | Chars 163 - 208 [Definition~foo1~:=~Eval~comp~i...] | 0m03.836s || -0m03.60s | -93.97% +\end{verbatim} + +\item \texttt{all.timing.diff}, \texttt{path/to/file.v.timing.diff} + --- The \texttt{path/to/file.v.timing.diff} target will make a + \texttt{.v.timing.diff} file for the corresponding \texttt{.v} file, + with a table as would be generated by the + \texttt{print-pretty-single-time-diff} target; it depends on having + already made the corresponding \texttt{.v.before-timing} and + \texttt{.v.after-timing} files, which can be made by passing + \texttt{TIMING=before} and \texttt{TIMING=after}. The + \texttt{all.timing.diff} target will make such timing difference + files for all of the \texttt{.v} files that the \texttt{Makefile} + knows about. It will fail if some \texttt{.v.before-timing} or + \texttt{.v.after-timing} files don't exist. + + \texttt{Note}: This target requires \texttt{python} to build the table. +\end{itemize} + \paragraph{Notes about including the generated Makefile} This practice is discouraged. The contents of this file, including variable names @@ -165,7 +324,7 @@ invoke-coqmakefile: CoqMakefile or after the build (like invoking make on a subdirectory) one can hook in {\tt pre-all} and {\tt post-all} extension points \item \texttt{-extra-phony} and \texttt{-extra} are deprecated. To provide - additional target ({\tt .PHONY} or not) please use + additional target ({\tt .PHONY} or not) please use {\tt CoqMakefile.local} \end{itemize} diff --git a/doc/tutorial/Tutorial.tex b/doc/tutorial/Tutorial.tex index 30b6304c1..8337b1c48 100644 --- a/doc/tutorial/Tutorial.tex +++ b/doc/tutorial/Tutorial.tex @@ -23,7 +23,7 @@ of Inductive Constructions. It allows the interactive construction of formal proofs, and also the manipulation of functional programs consistently with their specifications. It runs as a computer program on many architectures. -%, and mainly on Unix machines. + It is available with a variety of user interfaces. The present document does not attempt to present a comprehensive view of all the possibilities of \Coq, but rather to present in the most elementary @@ -33,63 +33,34 @@ proof tools. For more advanced information, the reader could refer to the \Coq{} Reference Manual or the \textit{Coq'Art}, a book by Y. Bertot and P. Castéran on practical uses of the \Coq{} system. -Coq can be used from a standard teletype-like shell window but -preferably through the graphical user interface -CoqIde\footnote{Alternative graphical interfaces exist: Proof General -and Pcoq.}. - Instructions on installation procedures, as well as more comprehensive documentation, may be found in the standard distribution of \Coq, -which may be obtained from \Coq{} web site \url{https://coq.inria.fr/}. - -In the following, we assume that \Coq{} is called from a standard -teletype-like shell window. All examples preceded by the prompting -sequence \verb:Coq < : represent user input, terminated by a -period. - -The following lines usually show \Coq's answer as it appears on the -users screen. When used from a graphical user interface such as -CoqIde, the prompt is not displayed: user input is given in one window +which may be obtained from \Coq{} web site +\url{https://coq.inria.fr/}\footnote{You can report any bug you find +while using \Coq{} at \url{https://coq.inria.fr/bugs}. Make sure to +always provide a way to reproduce it and to specify the exact version +you used. You can get this information by running \texttt{coqc -v}}. +\Coq{} is distributed together with a graphical user interface called +CoqIDE. Alternative interfaces exist such as +Proof General\footnote{See \url{https://proofgeneral.github.io/}.}. + +In the following examples, lines preceded by the prompt \verb:Coq < : +represent user input, terminated by a period. +The following lines usually show \Coq's answer. +When used from a graphical user interface such as +CoqIDE, the prompt is not displayed: user input is given in one window and \Coq's answers are displayed in a different window. -The sequence of such examples is a valid \Coq{} -session, unless otherwise specified. This version of the tutorial has -been prepared on a PC workstation running Linux. The standard -invocation of \Coq{} delivers a message such as: - -\begin{small} -\begin{flushleft} -\begin{verbatim} -unix:~> coqtop -Welcome to Coq 8.2 (January 2009) - -Coq < -\end{verbatim} -\end{flushleft} -\end{small} - -The first line gives a banner stating the precise version of \Coq{} -used. You should always return this banner when you report an anomaly -to our bug-tracking system -\url{https://coq.inria.fr/bugs/}. - \chapter{Basic Predicate Calculus} \section{An overview of the specification language Gallina} A formal development in Gallina consists in a sequence of {\sl declarations} -and {\sl definitions}. You may also send \Coq{} {\sl commands} which are -not really part of the formal development, but correspond to information -requests, or service routine invocations. For instance, the command: -\begin{verbatim} -Coq < Quit. -\end{verbatim} -terminates the current session. +and {\sl definitions}. \subsection{Declarations} -A declaration associates a {\sl name} with -a {\sl specification}. +A declaration associates a {\sl name} with a {\sl specification}. A name corresponds roughly to an identifier in a programming language, i.e. to a string of letters, digits, and a few ASCII symbols like underscore (\verb"_") and prime (\verb"'"), starting with a letter. @@ -165,25 +136,25 @@ in the current context: Check gt. \end{coq_example} -which tells us that \verb:gt: is a function expecting two arguments of -type \verb:nat: in order to build a logical proposition. +which tells us that \texttt{gt} is a function expecting two arguments of +type \texttt{nat} in order to build a logical proposition. What happens here is similar to what we are used to in a functional -programming language: we may compose the (specification) type \verb:nat: -with the (abstract) type \verb:Prop: of logical propositions through the +programming language: we may compose the (specification) type \texttt{nat} +with the (abstract) type \texttt{Prop} of logical propositions through the arrow function constructor, in order to get a functional type -\verb:nat->Prop:: +\texttt{nat -> Prop}: \begin{coq_example} Check (nat -> Prop). \end{coq_example} -which may be composed one more times with \verb:nat: in order to obtain the -type \verb:nat->nat->Prop: of binary relations over natural numbers. -Actually the type \verb:nat->nat->Prop: is an abbreviation for -\verb:nat->(nat->Prop):. +which may be composed once more with \verb:nat: in order to obtain the +type \texttt{nat -> nat -> Prop} of binary relations over natural numbers. +Actually the type \texttt{nat -> nat -> Prop} is an abbreviation for +\texttt{nat -> (nat -> Prop)}. Functional notions may be composed in the usual way. An expression $f$ of type $A\ra B$ may be applied to an expression $e$ of type $A$ in order to form the expression $(f~e)$ of type $B$. Here we get that -the expression \verb:(gt n): is well-formed of type \verb:nat->Prop:, +the expression \verb:(gt n): is well-formed of type \texttt{nat -> Prop}, and thus that the expression \verb:(gt n O):, which abbreviates \verb:((gt n) O):, is a well-formed proposition. \begin{coq_example} @@ -193,11 +164,12 @@ Check gt n O. \subsection{Definitions} The initial prelude contains a few arithmetic definitions: -\verb:nat: is defined as a mathematical collection (type \verb:Set:), constants -\verb:O:, \verb:S:, \verb:plus:, are defined as objects of types -respectively \verb:nat:, \verb:nat->nat:, and \verb:nat->nat->nat:. +\texttt{nat} is defined as a mathematical collection (type \texttt{Set}), +constants \texttt{O}, \texttt{S}, \texttt{plus}, are defined as objects of +types respectively \texttt{nat}, \texttt{nat -> nat}, and \texttt{nat -> +nat -> nat}. You may introduce new definitions, which link a name to a well-typed value. -For instance, we may introduce the constant \verb:one: as being defined +For instance, we may introduce the constant \texttt{one} as being defined to be equal to the successor of zero: \begin{coq_example} Definition one := (S O). @@ -217,17 +189,18 @@ argument \verb:m: of type \verb:nat: in order to build its result as \verb:(plus m m):: \begin{coq_example} -Definition double (m:nat) := plus m m. +Definition double (m : nat) := plus m m. \end{coq_example} This introduces the constant \texttt{double} defined as the -expression \texttt{fun m:nat => plus m m}. -The abstraction introduced by \texttt{fun} is explained as follows. The expression -\verb+fun x:A => e+ is well formed of type \verb+A->B+ in a context -whenever the expression \verb+e+ is well-formed of type \verb+B+ in -the given context to which we add the declaration that \verb+x+ -is of type \verb+A+. Here \verb+x+ is a bound, or dummy variable in -the expression \verb+fun x:A => e+. For instance we could as well have -defined \verb:double: as \verb+fun n:nat => (plus n n)+. +expression \texttt{fun m : nat => plus m m}. +The abstraction introduced by \texttt{fun} is explained as follows. +The expression \texttt{fun x : A => e} is well formed of type +\texttt{A -> B} in a context whenever the expression \texttt{e} is +well-formed of type \texttt{B} in the given context to which we add the +declaration that \texttt{x} is of type \texttt{A}. Here \texttt{x} is a +bound, or dummy variable in the expression \texttt{fun x : A => e}. +For instance we could as well have defined \texttt{double} as +\texttt{fun n : nat => (plus n n)}. Bound (local) variables and free (global) variables may be mixed. For instance, we may define the function which adds the constant \verb:n: @@ -243,19 +216,17 @@ Binding operations are well known for instance in logic, where they are called quantifiers. Thus we may universally quantify a proposition such as $m>0$ in order to get a universal proposition $\forall m\cdot m>0$. Indeed this operator is available in \Coq, with -the following syntax: \verb+forall m:nat, gt m O+. Similarly to the +the following syntax: \texttt{forall m : nat, gt m O}. Similarly to the case of the functional abstraction binding, we are obliged to declare explicitly the type of the quantified variable. We check: \begin{coq_example} -Check (forall m:nat, gt m 0). -\end{coq_example} -We may revert to the clean state of -our initial session using the \Coq{} \verb:Reset: command: -\begin{coq_example} -Reset Initial. +Check (forall m : nat, gt m 0). \end{coq_example} + \begin{coq_eval} +Reset Initial. Set Printing Width 60. +Set Printing Compact Contexts. \end{coq_eval} \section{Introduction to the proof engine: Minimal Logic} @@ -340,17 +311,12 @@ the current goal is solvable from the current local assumptions: assumption. \end{coq_example} -The proof is now finished. We may either discard it, by using the -command \verb:Abort: which returns to the standard \Coq{} toplevel loop -without further ado, or else save it as a lemma in the current context, -under name say \verb:trivial_lemma:: +The proof is now finished. We are now going to ask \Coq{}'s kernel +to check and save the proof. \begin{coq_example} -Save trivial_lemma. +Qed. \end{coq_example} -As a comment, the system shows the proof script listing all tactic -commands used in the proof. - Let us redo the same proof with a few variations. First of all we may name the initial goal as a conjectured lemma: \begin{coq_example} @@ -383,46 +349,30 @@ We may thus complete the proof of \verb:distr_impl: with one composite tactic: apply H; [ assumption | apply H0; assumption ]. \end{coq_example} -Let us now save lemma \verb:distr_impl:: -\begin{coq_example} -Qed. -\end{coq_example} - -Here \verb:Qed: needs no argument, since we gave the name \verb:distr_impl: -in advance. +You should be aware however that relying on automatically generated names is +not robust to slight updates to this proof script. Consequently, it is +discouraged in finished proof scripts. As for the composition of tactics with +\texttt{:} it may hinder the readability of the proof script and it is also +harder to see what's going on when replaying the proof because composed +tactics are evaluated in one go. Actually, such an easy combination of tactics \verb:intro:, \verb:apply: and \verb:assumption: may be found completely automatically by an automatic tactic, called \verb:auto:, without user guidance: -\begin{coq_example} -Lemma distr_imp : (A -> B -> C) -> (A -> B) -> A -> C. -auto. -\end{coq_example} - -This time, we do not save the proof, we just discard it with the \verb:Abort: -command: -\begin{coq_example} +\begin{coq_eval} Abort. +\end{coq_eval} +\begin{coq_example} +Lemma distr_impl : (A -> B -> C) -> (A -> B) -> A -> C. +auto. \end{coq_example} -At any point during a proof, we may use \verb:Abort: to exit the proof mode -and go back to Coq's main loop. We may also use \verb:Restart: to restart -from scratch the proof of the same lemma. We may also use \verb:Undo: to -backtrack one step, and more generally \verb:Undo n: to -backtrack n steps. - -We end this section by showing a useful command, \verb:Inspect n.:, -which inspects the global \Coq{} environment, showing the last \verb:n: declared -notions: +Let us now save lemma \verb:distr_impl:: \begin{coq_example} -Inspect 3. +Qed. \end{coq_example} -The declarations, whether global parameters or axioms, are shown preceded by -\verb:***:; definitions and lemmas are stated with their specification, but -their value (or proof-term) is omitted. - \section{Propositional Calculus} \subsection{Conjunction} @@ -438,7 +388,7 @@ connective. Let us show how to use these ideas for the propositional connectives \begin{coq_example} Lemma and_commutative : A /\ B -> B /\ A. -intro. +intro H. \end{coq_example} We make use of the conjunctive hypothesis \verb:H: with the \verb:elim: tactic, @@ -453,8 +403,11 @@ conjunctive goal into the two subgoals: split. \end{coq_example} and the proof is now trivial. Indeed, the whole proof is obtainable as follows: +\begin{coq_eval} +Abort. +\end{coq_eval} \begin{coq_example} -Restart. +Lemma and_commutative : A /\ B -> B /\ A. intro H; elim H; auto. Qed. \end{coq_example} @@ -465,7 +418,7 @@ conjunction introduction operator \verb+conj+ Check conj. \end{coq_example} -Actually, the tactic \verb+Split+ is just an abbreviation for \verb+apply conj.+ +Actually, the tactic \verb+split+ is just an abbreviation for \verb+apply conj.+ What we have just seen is that the \verb:auto: tactic is more powerful than just a simple application of local hypotheses; it tries to apply as well @@ -498,6 +451,17 @@ clear away unnecessary hypotheses which may clutter your screen. clear H. \end{coq_example} +The tactic \verb:destruct: combines the effects of \verb:elim:, \verb:intros:, +and \verb:clear:: + +\begin{coq_eval} +Abort. +\end{coq_eval} +\begin{coq_example} +Lemma or_commutative : A \/ B -> B \/ A. +intros H; destruct H. +\end{coq_example} + The disjunction connective has two introduction rules, since \verb:P\/Q: may be obtained from \verb:P: or from \verb:Q:; the two corresponding proof constructors are called respectively \verb:or_introl: and @@ -528,8 +492,11 @@ such a simple tautology. The reason is that we want to keep A complete tactic for propositional tautologies is indeed available in \Coq{} as the \verb:tauto: tactic. +\begin{coq_eval} +Abort. +\end{coq_eval} \begin{coq_example} -Restart. +Lemma or_commutative : A \/ B -> B \/ A. tauto. Qed. \end{coq_example} @@ -541,8 +508,8 @@ currently defined in the context: Print or_commutative. \end{coq_example} -It is not easy to understand the notation for proof terms without a few -explanations. The \texttt{fun} prefix, such as \verb+fun H:A\/B =>+, +It is not easy to understand the notation for proof terms without some +explanations. The \texttt{fun} prefix, such as \verb+fun H : A\/B =>+, corresponds to \verb:intro H:, whereas a subterm such as \verb:(or_intror: \verb:B H0): @@ -572,15 +539,17 @@ Lemma Peirce : ((A -> B) -> A) -> A. try tauto. \end{coq_example} -Note the use of the \verb:Try: tactical, which does nothing if its tactic +Note the use of the \verb:try: tactical, which does nothing if its tactic argument fails. This may come as a surprise to someone familiar with classical reasoning. Peirce's lemma is true in Boolean logic, i.e. it evaluates to \verb:true: for every truth-assignment to \verb:A: and \verb:B:. Indeed the double negation of Peirce's law may be proved in \Coq{} using \verb:tauto:: -\begin{coq_example} +\begin{coq_eval} Abort. +\end{coq_eval} +\begin{coq_example} Lemma NNPeirce : ~ ~ (((A -> B) -> A) -> A). tauto. Qed. @@ -651,26 +620,20 @@ function and predicate symbols. \subsection{Sections and signatures} Usually one works in some domain of discourse, over which range the individual -variables and function symbols. In \Coq{} we speak in a language with a rich -variety of types, so me may mix several domains of discourse, in our +variables and function symbols. In \Coq{}, we speak in a language with a rich +variety of types, so we may mix several domains of discourse, in our multi-sorted language. For the moment, we just do a few exercises, over a domain of discourse \verb:D: axiomatised as a \verb:Set:, and we consider two predicate symbols \verb:P: and \verb:R: over \verb:D:, of arities -respectively 1 and 2. Such abstract entities may be entered in the context -as global variables. But we must be careful about the pollution of our -global environment by such declarations. For instance, we have already -polluted our \Coq{} session by declaring the variables -\verb:n:, \verb:Pos_n:, \verb:A:, \verb:B:, and \verb:C:. +1 and 2, respectively. -\begin{coq_example} -Reset Initial. -\end{coq_example} \begin{coq_eval} +Reset Initial. Set Printing Width 60. +Set Printing Compact Contexts. \end{coq_eval} -We shall now declare a new \verb:Section:, which will allow us to define -notions local to a well-delimited scope. We start by assuming a domain of +We start by assuming a domain of discourse \verb:D:, and a binary relation \verb:R: over \verb:D:: \begin{coq_example} Section Predicate_calculus. @@ -686,18 +649,19 @@ a theory, but rather local hypotheses to a theorem, we open a specific section to this effect. \begin{coq_example} Section R_sym_trans. -Hypothesis R_symmetric : forall x y:D, R x y -> R y x. -Hypothesis R_transitive : forall x y z:D, R x y -> R y z -> R x z. +Hypothesis R_symmetric : forall x y : D, R x y -> R y x. +Hypothesis R_transitive : + forall x y z : D, R x y -> R y z -> R x z. \end{coq_example} -Remark the syntax \verb+forall x:D,+ which stands for universal quantification +Remark the syntax \verb+forall x : D,+ which stands for universal quantification $\forall x : D$. \subsection{Existential quantification} We now state our lemma, and enter proof mode. \begin{coq_example} -Lemma refl_if : forall x:D, (exists y, R x y) -> R x x. +Lemma refl_if : forall x : D, (exists y, R x y) -> R x x. \end{coq_example} Remark that the hypotheses which are local to the currently opened sections @@ -711,13 +675,13 @@ predicate as argument: \begin{coq_example} Check ex. \end{coq_example} -and the notation \verb+(exists x:D, P x)+ is just concrete syntax for -the expression \verb+(ex D (fun x:D => P x))+. +and the notation \verb+(exists x : D, P x)+ is just concrete syntax for +the expression \verb+(ex D (fun x : D => P x))+. Existential quantification is handled in \Coq{} in a similar -fashion to the connectives \verb:/\: and \verb:\/: : it is introduced by +fashion to the connectives \verb:/\: and \verb:\/:: it is introduced by the proof combinator \verb:ex_intro:, which is invoked by the specific -tactic \verb:Exists:, and its elimination provides a witness \verb+a:D+ to -\verb:P:, together with an assumption \verb+h:(P a)+ that indeed \verb+a+ +tactic \verb:exists:, and its elimination provides a witness \verb+a : D+ to +\verb:P:, together with an assumption \verb+h : (P a)+ that indeed \verb+a+ verifies \verb:P:. Let us see how this works on this simple example. \begin{coq_example} intros x x_Rlinked. @@ -773,8 +737,8 @@ End R_sym_trans. All the local hypotheses have been discharged in the statement of \verb:refl_if:, which now becomes a general theorem in the first-order language declared in section -\verb:Predicate_calculus:. In this particular example, the use of section -\verb:R_sym_trans: has not been really significant, since we could have +\verb:Predicate_calculus:. In this particular example, section +\verb:R_sym_trans: has not been really useful, since we could have instead stated theorem \verb:refl_if: in its general form, and done basically the same proof, obtaining \verb:R_symmetric: and \verb:R_transitive: as local hypotheses by initial \verb:intros: rather @@ -802,7 +766,7 @@ Lemma weird : (forall x:D, P x) -> exists a, P a. \end{coq_example} First of all, notice the pair of parentheses around -\verb+forall x:D, P x+ in +\verb+forall x : D, P x+ in the statement of lemma \verb:weird:. If we had omitted them, \Coq's parser would have interpreted the statement as a truly trivial fact, since we would @@ -820,7 +784,7 @@ systematically inhabited, lemma \verb:weird: only holds in signatures which allow the explicit construction of an element in the domain of the predicate. -Let us conclude the proof, in order to show the use of the \verb:Exists: +Let us conclude the proof, in order to show the use of the \verb:exists: tactic: \begin{coq_example} exists d; trivial. @@ -836,8 +800,8 @@ We shall need classical reasoning. Instead of loading the \verb:Classical: module as we did above, we just state the law of excluded middle as a local hypothesis schema at this point: \begin{coq_example} -Hypothesis EM : forall A:Prop, A \/ ~ A. -Lemma drinker : exists x:D, P x -> forall x:D, P x. +Hypothesis EM : forall A : Prop, A \/ ~ A. +Lemma drinker : exists x : D, P x -> forall x : D, P x. \end{coq_example} The proof goes by cases on whether or not there is someone who does not drink. Such reasoning by cases proceeds @@ -847,10 +811,11 @@ proper instance of \verb:EM:: elim (EM (exists x, ~ P x)). \end{coq_example} -We first look at the first case. Let Tom be the non-drinker: +We first look at the first case. Let Tom be the non-drinker. +The following combines at once the effect of \verb:intros: and +\verb:destruct:: \begin{coq_example} -intro Non_drinker; elim Non_drinker; - intros Tom Tom_does_not_drink. +intros (Tom, Tom_does_not_drink). \end{coq_example} We conclude in that case by considering Tom, since his drinking leads to @@ -860,9 +825,10 @@ exists Tom; intro Tom_drinks. \end{coq_example} There are several ways in which we may eliminate a contradictory case; -a simple one is to use the \verb:absurd: tactic as follows: +in this case, we use \verb:contradiction: to let \Coq{} find out the +two contradictory hypotheses: \begin{coq_example} -absurd (P Tom); trivial. +contradiction. \end{coq_example} We now proceed with the second case, in which actually any person will do; @@ -904,9 +870,10 @@ Finally, the excluded middle hypothesis is discharged only in Note that the name \verb:d: has vanished as well from the statements of \verb:weird: and \verb:drinker:, since \Coq's pretty-printer replaces -systematically a quantification such as \verb+forall d:D, E+, where \verb:d: -does not occur in \verb:E:, by the functional notation \verb:D->E:. -Similarly the name \verb:EM: does not appear in \verb:drinker:. +systematically a quantification such as \texttt{forall d : D, E}, +where \texttt{d} does not occur in \texttt{E}, +by the functional notation \texttt{D -> E}. +Similarly the name \texttt{EM} does not appear in \texttt{drinker}. Actually, universal quantification, implication, as well as function formation, are @@ -935,12 +902,12 @@ intros. generalize H0. \end{coq_example} -Sometimes it may be convenient to use a lemma, although we do not have -a direct way to appeal to such an already proven fact. The tactic \verb:cut: -permits to use the lemma at this point, keeping the corresponding proof -obligation as a new subgoal: +Sometimes it may be convenient to state an intermediate fact. +The tactic \verb:assert: does this and introduces a new subgoal +for this fact to be proved first. The tactic \verb:enough: does +the same while keeping this goal for later. \begin{coq_example} -cut (R x x); trivial. +enough (R x x) by auto. \end{coq_example} We clean the goal by doing an \verb:Abort: command. \begin{coq_example*} @@ -951,10 +918,10 @@ Abort. \subsection{Equality} The basic equality provided in \Coq{} is Leibniz equality, noted infix like -\verb+x=y+, when \verb:x: and \verb:y: are two expressions of -type the same Set. The replacement of \verb:x: by \verb:y: in any -term is effected by a variety of tactics, such as \verb:rewrite: -and \verb:replace:. +\texttt{x = y}, when \texttt{x} and \texttt{y} are two expressions of +type the same Set. The replacement of \texttt{x} by \texttt{y} in any +term is effected by a variety of tactics, such as \texttt{rewrite} +and \texttt{replace}. Let us give a few examples of equality replacement. Let us assume that some arithmetic function \verb:f: is null in zero: @@ -1009,10 +976,14 @@ In case the equality $t=u$ generated by \verb:replace: $u$ \verb:with: $t$ is an assumption (possibly modulo symmetry), it will be automatically proved and the corresponding goal will not appear. For instance: -\begin{coq_example} + +\begin{coq_eval} Restart. -replace (f 0) with 0. -rewrite f10; rewrite foo; trivial. +\end{coq_eval} +\begin{coq_example} +Lemma L2 : f (f 1) = 0. +replace (f 1) with (f 0). +replace (f 0) with 0; trivial. Qed. \end{coq_example} @@ -1033,20 +1004,20 @@ predicates over some universe \verb:U:. For instance: \begin{coq_example} Variable U : Type. Definition set := U -> Prop. -Definition element (x:U) (S:set) := S x. -Definition subset (A B:set) := - forall x:U, element x A -> element x B. +Definition element (x : U) (S : set) := S x. +Definition subset (A B : set) := + forall x : U, element x A -> element x B. \end{coq_example} Now, assume that we have loaded a module of general properties about relations over some abstract type \verb:T:, such as transitivity: \begin{coq_example} -Definition transitive (T:Type) (R:T -> T -> Prop) := - forall x y z:T, R x y -> R y z -> R x z. +Definition transitive (T : Type) (R : T -> T -> Prop) := + forall x y z : T, R x y -> R y z -> R x z. \end{coq_example} -Now, assume that we want to prove that \verb:subset: is a \verb:transitive: +We want to prove that \verb:subset: is a \verb:transitive: relation. \begin{coq_example} Lemma subset_transitive : transitive set subset. @@ -1071,9 +1042,12 @@ auto. \end{coq_example} Many variations on \verb:unfold: are provided in \Coq. For instance, -we may selectively unfold one designated occurrence: -\begin{coq_example} +instead of unfolding all occurrences of \verb:subset:, we may want to +unfold only one designated occurrence: +\begin{coq_eval} Undo 2. +\end{coq_eval} +\begin{coq_example} unfold subset at 2. \end{coq_example} @@ -1111,6 +1085,7 @@ are {\sl transparent}. \begin{coq_eval} Reset Initial. Set Printing Width 60. +Set Printing Compact Contexts. \end{coq_eval} \section{Data Types as Inductively Defined Mathematical Collections} @@ -1166,11 +1141,14 @@ right; trivial. \end{coq_example} Indeed, the whole proof can be done with the combination of the - \verb:simple: \verb:induction:, which combines \verb:intro: and \verb:elim:, + \verb:destruct:, which combines \verb:intro: and \verb:elim:, with good old \verb:auto:: +\begin{coq_eval} +Abort. +\end{coq_eval} \begin{coq_example} -Restart. -simple induction b; auto. +Lemma duality : forall b:bool, b = true \/ b = false. +destruct b; auto. Qed. \end{coq_example} @@ -1194,7 +1172,7 @@ Check nat_rec. Let us start by showing how to program the standard primitive recursion operator \verb:prim_rec: from the more general \verb:nat_rec:: \begin{coq_example} -Definition prim_rec := nat_rec (fun i:nat => nat). +Definition prim_rec := nat_rec (fun i : nat => nat). \end{coq_example} That is, instead of computing for natural \verb:i: an element of the indexed @@ -1205,22 +1183,27 @@ About prim_rec. \end{coq_example} Oops! Instead of the expected type \verb+nat->(nat->nat->nat)->nat->nat+ we -get an apparently more complicated expression. Indeed the type of -\verb:prim_rec: is equivalent by rule $\beta$ to its expected type; this may -be checked in \Coq{} by command \verb:Eval Cbv Beta:, which $\beta$-reduces -an expression to its {\sl normal form}: +get an apparently more complicated expression. +In fact, the two types are convertible and one way of having the proper +type would be to do some computation before actually defining \verb:prim_rec: +as such: + +\begin{coq_eval} +Reset Initial. +Set Printing Width 60. +Set Printing Compact Contexts. +\end{coq_eval} + \begin{coq_example} -Eval cbv beta in - ((fun _:nat => nat) O -> - (forall y:nat, - (fun _:nat => nat) y -> (fun _:nat => nat) (S y)) -> - forall n:nat, (fun _:nat => nat) n). +Definition prim_rec := + Eval compute in nat_rec (fun i : nat => nat). +About prim_rec. \end{coq_example} Let us now show how to program addition with primitive recursion: \begin{coq_example} Definition addition (n m:nat) := - prim_rec m (fun p rec:nat => S rec) n. + prim_rec m (fun p rec : nat => S rec) n. \end{coq_example} That is, we specify that \verb+(addition n m)+ computes by cases on \verb:n: @@ -1244,15 +1227,11 @@ Fixpoint plus (n m:nat) {struct n} : nat := end. \end{coq_example} -For the rest of the session, we shall clean up what we did so far with -types \verb:bool: and \verb:nat:, in order to use the initial definitions -given in \Coq's \verb:Prelude: module, and not to get confusing error -messages due to our redefinitions. We thus revert to the initial state: +\begin{coq_eval} \begin{coq_example} Reset Initial. -\end{coq_example} -\begin{coq_eval} Set Printing Width 60. +Set Printing Compact Contexts. \end{coq_eval} \subsection{Simple proofs by induction} @@ -1261,20 +1240,21 @@ Let us now show how to do proofs by structural induction. We start with easy properties of the \verb:plus: function we just defined. Let us first show that $n=n+0$. \begin{coq_example} -Lemma plus_n_O : forall n:nat, n = n + 0. +Lemma plus_n_O : forall n : nat, n = n + 0. intro n; elim n. \end{coq_example} -What happened was that \verb:elim n:, in order to construct a \verb:Prop: -(the initial goal) from a \verb:nat: (i.e. \verb:n:), appealed to the -corresponding induction principle \verb:nat_ind: which we saw was indeed +What happened was that \texttt{elim n}, in order to construct a \texttt{Prop} +(the initial goal) from a \texttt{nat} (i.e. \texttt{n}), appealed to the +corresponding induction principle \texttt{nat\_ind} which we saw was indeed exactly Peano's induction scheme. Pattern-matching instantiated the -corresponding predicate \verb:P: to \verb+fun n:nat => n = n + 0+, and we get -as subgoals the corresponding instantiations of the base case \verb:(P O): , -and of the inductive step \verb+forall y:nat, P y -> P (S y)+. -In each case we get an instance of function \verb:plus: in which its second +corresponding predicate \texttt{P} to \texttt{fun n : nat => n = n + 0}, +and we get as subgoals the corresponding instantiations of the base case +\texttt{(P O)}, and of the inductive step +\texttt{forall y : nat, P y -> P (S y)}. +In each case we get an instance of function \texttt{plus} in which its second argument starts with a constructor, and is thus amenable to simplification -by primitive recursion. The \Coq{} tactic \verb:simpl: can be used for +by primitive recursion. The \Coq{} tactic \texttt{simpl} can be used for this purpose: \begin{coq_example} simpl. @@ -1305,12 +1285,12 @@ We now proceed to the similar property concerning the other constructor Lemma plus_n_S : forall n m:nat, S (n + m) = n + S m. \end{coq_example} -We now go faster, remembering that tactic \verb:simple induction: does the +We now go faster, using the tactic \verb:induction:, which does the necessary \verb:intros: before applying \verb:elim:. Factoring simplification and automation in both cases thanks to tactic composition, we prove this lemma in one line: \begin{coq_example} -simple induction n; simpl; auto. +induction n; simpl; auto. Qed. Hint Resolve plus_n_S . \end{coq_example} @@ -1324,7 +1304,7 @@ Lemma plus_com : forall n m:nat, n + m = m + n. Here we have a choice on doing an induction on \verb:n: or on \verb:m:, the situation being symmetric. For instance: \begin{coq_example} -simple induction m; simpl; auto. +induction m as [ | m IHm ]; simpl; auto. \end{coq_example} Here \verb:auto: succeeded on the base case, thanks to our hint @@ -1332,7 +1312,7 @@ Here \verb:auto: succeeded on the base case, thanks to our hint \verb:auto: does not handle: \begin{coq_example} -intros m' E; rewrite <- E; auto. +rewrite <- IHm; auto. Qed. \end{coq_example} @@ -1344,13 +1324,13 @@ the constructors \verb:O: and \verb:S:: it computes to \verb:False: when its argument is \verb:O:, and to \verb:True: when its argument is of the form \verb:(S n):: \begin{coq_example} -Definition Is_S (n:nat) := match n with - | O => False - | S p => True - end. +Definition Is_S (n : nat) := match n with + | O => False + | S p => True + end. \end{coq_example} -Now we may use the computational power of \verb:Is_S: in order to prove +Now we may use the computational power of \verb:Is_S: to prove trivially that \verb:(Is_S (S n)):: \begin{coq_example} Lemma S_Is_S : forall n:nat, Is_S (S n). @@ -1389,8 +1369,11 @@ Actually, a specific tactic \verb:discriminate: is provided to produce mechanically such proofs, without the need for the user to define explicitly the relevant discrimination predicates: +\begin{coq_eval} +Abort. +\end{coq_eval} \begin{coq_example} -Restart. +Lemma no_confusion : forall n:nat, 0 <> S n. intro n; discriminate. Qed. \end{coq_example} @@ -1403,12 +1386,13 @@ may define inductive families, and for instance inductive predicates. Here is the definition of predicate $\le$ over type \verb:nat:, as given in \Coq's \verb:Prelude: module: \begin{coq_example*} -Inductive le (n:nat) : nat -> Prop := +Inductive le (n : nat) : nat -> Prop := | le_n : le n n - | le_S : forall m:nat, le n m -> le n (S m). + | le_S : forall m : nat, le n m -> le n (S m). \end{coq_example*} -This definition introduces a new predicate \verb+le:nat->nat->Prop+, +This definition introduces a new predicate +\verb+le : nat -> nat -> Prop+, and the two constructors \verb:le_n: and \verb:le_S:, which are the defining clauses of \verb:le:. That is, we get not only the ``axioms'' \verb:le_n: and \verb:le_S:, but also the converse property, that @@ -1426,7 +1410,7 @@ Check le_ind. Let us show how proofs may be conducted with this principle. First we show that $n\le m \Rightarrow n+1\le m+1$: \begin{coq_example} -Lemma le_n_S : forall n m:nat, le n m -> le (S n) (S m). +Lemma le_n_S : forall n m : nat, le n m -> le (S n) (S m). intros n m n_le_m. elim n_le_m. \end{coq_example} @@ -1442,10 +1426,14 @@ intros; apply le_S; trivial. Now we know that it is a good idea to give the defining clauses as hints, so that the proof may proceed with a simple combination of -\verb:induction: and \verb:auto:. +\verb:induction: and \verb:auto:. \verb:Hint Constructors le: +is just an abbreviation for \verb:Hint Resolve le_n le_S:. +\begin{coq_eval} +Abort. +\end{coq_eval} \begin{coq_example} -Restart. -Hint Resolve le_n le_S . +Hint Constructors le. +Lemma le_n_S : forall n m : nat, le n m -> le (S n) (S m). \end{coq_example} We have a slight problem however. We want to say ``Do an induction on @@ -1453,7 +1441,7 @@ hypothesis \verb:(le n m):'', but we have no explicit name for it. What we do in this case is to say ``Do an induction on the first unnamed hypothesis'', as follows. \begin{coq_example} -simple induction 1; auto. +induction 1; auto. Qed. \end{coq_example} @@ -1483,6 +1471,7 @@ Qed. \begin{coq_eval} Reset Initial. Set Printing Width 60. +Set Printing Compact Contexts. \end{coq_eval} \section{Opening library modules} @@ -1552,6 +1541,7 @@ known lemmas about both the successor and the less or equal relation, just ask: \begin{coq_eval} Reset Initial. Set Printing Width 60. +Set Printing Compact Contexts. \end{coq_eval} \begin{coq_example} Search S le. @@ -1562,14 +1552,13 @@ predicate appears at the head position in the conclusion. SearchHead le. \end{coq_example} -A new and more convenient search tool is \verb:SearchPattern: -developed by Yves Bertot. It allows finding the theorems with a -conclusion matching a given pattern, where \verb:_: can be used in -place of an arbitrary term. We remark in this example, that \Coq{} +The \verb:Search: commands also allows finding the theorems +containing a given pattern, where \verb:_: can be used in +place of an arbitrary term. As shown in this example, \Coq{} provides usual infix notations for arithmetic operators. \begin{coq_example} -SearchPattern (_ + _ = _). +Search (_ + _ = _). \end{coq_example} \section{Now you are on your own} diff --git a/engine/proofview.ml b/engine/proofview.ml index c542fd976..b4e2160f4 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -1072,13 +1072,6 @@ module Goal = struct end end - exception NotExactlyOneSubgoal - let _ = CErrors.register_handler begin function - | NotExactlyOneSubgoal -> - CErrors.user_err (Pp.str"Not exactly one subgoal.") - | _ -> raise CErrors.Unhandled - end - let enter_one f = let open Proof in Comb.get >>= function @@ -1090,7 +1083,7 @@ module Goal = struct let (e, info) = CErrors.push e in tclZERO ~info e end - | _ -> tclZERO NotExactlyOneSubgoal + | _ -> assert false (* unsatisfied not-exactly-one-goal precondition *) let goals = Pv.get >>= fun step -> diff --git a/engine/proofview.mli b/engine/proofview.mli index e98f59f0f..957c9213c 100644 --- a/engine/proofview.mli +++ b/engine/proofview.mli @@ -25,7 +25,7 @@ type proofview new nearly identical function everytime. Hence the generic name. *) (* In this version: returns the list of focused goals together with the [evar_map] context. *) -val proofview : proofview -> Goal.goal list * Evd.evar_map +val proofview : proofview -> Evd.evar list * Evd.evar_map (** {6 Starting and querying a proof view} *) @@ -88,7 +88,7 @@ type focus_context new nearly identical function everytime. Hence the generic name. *) (* In this version: the goals in the context, as a "zipper" (the first list is in reversed order). *) -val focus_context : focus_context -> Goal.goal list * Goal.goal list +val focus_context : focus_context -> Evd.evar list * Evd.evar list (** [focus i j] focuses a proofview on the goals from index [i] to index [j] (inclusive, goals are indexed from [1]). I.e. goals @@ -148,7 +148,7 @@ type +'a tactic {!Logic_monad.TacticFailure}*) 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 (** {7 Monadic primitives} *) @@ -304,12 +304,12 @@ val shelve : unit tactic (** Shelves the given list of goals, which might include some that are under focus and some that aren't. All the goals are placed on the shelf for later use (or being solved by side-effects). *) -val shelve_goals : Goal.goal list -> unit tactic +val shelve_goals : Evd.evar list -> unit tactic (** [unifiable sigma g l] checks whether [g] appears in another subgoal of [l]. The list [l] may contain [g], but it does not affect the result. Used by [shelve_unifiable]. *) -val unifiable : Evd.evar_map -> Goal.goal -> Goal.goal list -> bool +val unifiable : Evd.evar_map -> Evd.evar -> Evd.evar list -> bool (** Shelves the unifiable goals under focus, i.e. the goals which appear in other goals under focus (the unfocused goals are not @@ -322,15 +322,15 @@ val guard_no_unifiable : Names.Name.t list option tactic (** [unshelve l p] adds all the goals in [l] at the end of the focused goals of p *) -val unshelve : Goal.goal list -> proofview -> proofview +val unshelve : Evd.evar list -> proofview -> proofview (** [depends_on g1 g2 sigma] checks if g1 occurs in the type/ctx of g2 *) -val depends_on : Evd.evar_map -> Goal.goal -> Goal.goal -> bool +val depends_on : Evd.evar_map -> Evd.evar -> Evd.evar -> bool (** [with_shelf tac] executes [tac] and returns its result together with the set of goals shelved by [tac]. The current shelf is unchanged and the returned list contains only unsolved goals. *) -val with_shelf : 'a tactic -> (Goal.goal list * 'a) tactic +val with_shelf : 'a tactic -> (Evd.evar list * 'a) tactic (** If [n] is positive, [cycle n] puts the [n] first goal last. If [n] is negative, then it puts the [n] last goals first.*) @@ -416,14 +416,14 @@ module Unsafe : sig (** [tclNEWGOALS gls] adds the goals [gls] to the ones currently being proved, appending them to the list of focused goals. If a goal is already solved, it is not added. *) - val tclNEWGOALS : Goal.goal list -> unit tactic + val tclNEWGOALS : Evd.evar list -> unit tactic (** [tclSETGOALS gls] sets goals [gls] as the goals being under focus. If a goal is already solved, it is not set. *) - val tclSETGOALS : Goal.goal list -> unit tactic + val tclSETGOALS : Evd.evar list -> unit tactic (** [tclGETGOALS] returns the list of goals under focus. *) - val tclGETGOALS : Goal.goal list tactic + val tclGETGOALS : Evd.evar list tactic (** Sets the evar universe context. *) val tclEVARUNIVCONTEXT : Evd.evar_universe_context -> unit tactic @@ -498,7 +498,7 @@ module Goal : sig val enter : ([ `LZ ] t -> unit tactic) -> unit tactic (** Like {!enter}, but assumes exactly one goal under focus, raising *) - (** an error otherwise. *) + (** a fatal error otherwise. *) val enter_one : ([ `LZ ] t -> 'a tactic) -> 'a tactic (** Recover the list of current goals under focus, without evar-normalization. diff --git a/engine/termops.ml b/engine/termops.ml index fc3291df1..1aba2bbdd 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -906,7 +906,7 @@ let collect_vars sigma c = aux Id.Set.empty c let vars_of_global_reference env gr = - let c, _ = Universes.unsafe_constr_of_global gr in + let c, _ = Global.constr_of_global_in_context env gr in vars_of_global (Global.env ()) c (* Tests whether [m] is a subterm of [t]: diff --git a/engine/universes.ml b/engine/universes.ml index 28058aeed..08461a218 100644 --- a/engine/universes.ml +++ b/engine/universes.ml @@ -282,28 +282,27 @@ let new_Type dp = mkType (new_univ dp) let new_Type_sort dp = Type (new_univ dp) let fresh_universe_instance ctx = - Instance.subst_fn (fun _ -> new_univ_level (Global.current_dirpath ())) - (AUContext.instance ctx) + let init _ = new_univ_level (Global.current_dirpath ()) in + Instance.of_array (Array.init (AUContext.size ctx) init) let fresh_instance_from_context ctx = let inst = fresh_universe_instance ctx in - let constraints = UContext.constraints (subst_instance_context inst ctx) in + let constraints = AUContext.instantiate inst ctx in inst, constraints let fresh_instance ctx = let ctx' = ref LSet.empty in - let inst = - Instance.subst_fn (fun v -> - let u = new_univ_level (Global.current_dirpath ()) in - ctx' := LSet.add u !ctx'; u) - (AUContext.instance ctx) + let init _ = + let u = new_univ_level (Global.current_dirpath ()) in + ctx' := LSet.add u !ctx'; u + in + let inst = Instance.of_array (Array.init (AUContext.size ctx) init) in !ctx', inst let existing_instance ctx inst = let () = - let a1 = Instance.to_array inst - and a2 = Instance.to_array (AUContext.instance ctx) in - let len1 = Array.length a1 and len2 = Array.length a2 in + let len1 = Array.length (Instance.to_array inst) + and len2 = AUContext.size ctx in if not (len1 == len2) then CErrors.user_err ~hdr:"Universes" (str "Polymorphic constant expected " ++ int len2 ++ @@ -317,12 +316,9 @@ let fresh_instance_from ctx inst = | Some inst -> existing_instance ctx inst | None -> fresh_instance ctx in - let constraints = UContext.constraints (subst_instance_context inst ctx) in + let constraints = AUContext.instantiate inst ctx in inst, (ctx', constraints) -let unsafe_instance_from ctx = - (Univ.AUContext.instance ctx, Univ.instantiate_univ_context ctx) - (** Fresh universe polymorphic construction *) let fresh_constant_instance env c inst = @@ -359,34 +355,6 @@ let fresh_constructor_instance env (ind,i) inst = let inst, ctx = fresh_instance_from (ACumulativityInfo.univ_context acumi) inst in (((ind,i),inst), ctx) -let unsafe_constant_instance env c = - let cb = lookup_constant c env in - match cb.Declarations.const_universes with - | Declarations.Monomorphic_const _ -> - ((c,Instance.empty), UContext.empty) - | Declarations.Polymorphic_const auctx -> - let inst, ctx = unsafe_instance_from auctx in ((c, inst), ctx) - -let unsafe_inductive_instance env ind = - let mib, mip = Inductive.lookup_mind_specif env ind in - match mib.Declarations.mind_universes with - | Declarations.Monomorphic_ind _ -> ((ind,Instance.empty), UContext.empty) - | Declarations.Polymorphic_ind auctx -> - let inst, ctx = unsafe_instance_from auctx in ((ind,inst), ctx) - | Declarations.Cumulative_ind acumi -> - let inst, ctx = unsafe_instance_from (ACumulativityInfo.univ_context acumi) in - ((ind,inst), ctx) - -let unsafe_constructor_instance env (ind,i) = - let mib, mip = Inductive.lookup_mind_specif env ind in - match mib.Declarations.mind_universes with - | Declarations.Monomorphic_ind _ -> (((ind, i),Instance.empty), UContext.empty) - | Declarations.Polymorphic_ind auctx -> - let inst, ctx = unsafe_instance_from auctx in (((ind, i),inst), ctx) - | Declarations.Cumulative_ind acumi -> - let inst, ctx = unsafe_instance_from (ACumulativityInfo.univ_context acumi) in - (((ind, i),inst), ctx) - open Globnames let fresh_global_instance ?names env gr = @@ -411,19 +379,6 @@ let fresh_inductive_instance env sp = let fresh_constructor_instance env sp = fresh_constructor_instance env sp None -let unsafe_global_instance env gr = - match gr with - | VarRef id -> mkVar id, UContext.empty - | ConstRef sp -> - let c, ctx = unsafe_constant_instance env sp in - mkConstU c, ctx - | ConstructRef sp -> - let c, ctx = unsafe_constructor_instance env sp in - mkConstructU c, ctx - | IndRef sp -> - let c, ctx = unsafe_inductive_instance env sp in - mkIndU c, ctx - let constr_of_global gr = let c, ctx = fresh_global_instance (Global.env ()) gr in if not (Univ.ContextSet.is_empty ctx) then @@ -438,9 +393,6 @@ let constr_of_global gr = let constr_of_reference = constr_of_global -let unsafe_constr_of_global gr = - unsafe_global_instance (Global.env ()) gr - let constr_of_global_univ (gr,u) = match gr with | VarRef id -> mkVar id @@ -514,25 +466,6 @@ let type_of_reference env r = let type_of_global t = type_of_reference (Global.env ()) t -let unsafe_type_of_reference env r = - match r with - | VarRef id -> Environ.named_type id env - | ConstRef c -> - let cb = Environ.lookup_constant c env in - Typeops.type_of_constant_type env cb.const_type - - | IndRef ind -> - let (mib, oib as specif) = Inductive.lookup_mind_specif env ind in - let (_, inst), _ = unsafe_inductive_instance env ind in - Inductive.type_of_inductive env (specif, inst) - - | ConstructRef (ind, _ as cstr) -> - let (mib,oib as specif) = Inductive.lookup_mind_specif env (inductive_of_constructor cstr) in - let (_, inst), _ = unsafe_inductive_instance env ind in - Inductive.type_of_constructor (cstr,inst) specif - -let unsafe_type_of_global t = unsafe_type_of_reference (Global.env ()) t - let fresh_sort_in_family env = function | InProp -> prop_sort, ContextSet.empty | InSet -> set_sort, ContextSet.empty @@ -1015,34 +948,6 @@ let normalize_context_set ctx us algs = (* let normalize_conkey = Profile.declare_profile "normalize_context_set" *) (* let normalize_context_set a b c = Profile.profile3 normalize_conkey normalize_context_set a b c *) -let simplify_universe_context (univs,csts) = - let uf = UF.create () in - let noneqs = - Constraint.fold (fun (l,d,r) noneqs -> - if d == Eq && (LSet.mem l univs || LSet.mem r univs) then - (UF.union l r uf; noneqs) - else Constraint.add (l,d,r) noneqs) - csts Constraint.empty - in - let partition = UF.partition uf in - let flex x = LSet.mem x univs in - let subst, univs', csts' = List.fold_left (fun (subst, univs, cstrs) s -> - let canon, (global, rigid, flexible) = choose_canonical univs flex LSet.empty s in - (* Add equalities for globals which can't be merged anymore. *) - let cstrs = LSet.fold (fun g cst -> - Constraint.add (canon, Univ.Eq, g) cst) (LSet.union global rigid) - cstrs - in - let subst = LSet.fold (fun f -> LMap.add f canon) - flexible subst - in (subst, LSet.diff univs flexible, cstrs)) - (LMap.empty, univs, noneqs) partition - in - (* Noneqs is now in canonical form w.r.t. equality constraints, - and contains only inequality constraints. *) - let csts' = subst_univs_level_constraints subst csts' in - (univs', csts'), subst - let is_trivial_leq (l,d,r) = Univ.Level.is_prop l && (d == Univ.Le || (d == Univ.Lt && Univ.Level.is_set r)) diff --git a/engine/universes.mli b/engine/universes.mli index 5f4d212b6..0f6e419d0 100644 --- a/engine/universes.mli +++ b/engine/universes.mli @@ -189,30 +189,16 @@ val constr_of_global : Globnames.global_reference -> constr (** ** DEPRECATED ** synonym of [constr_of_global] *) val constr_of_reference : Globnames.global_reference -> constr -(** [unsafe_constr_of_global gr] turns [gr] into a constr, works on polymorphic - references by taking the original universe instance that is not recorded - anywhere. The constraints are forgotten as well. DO NOT USE in new code. *) -val unsafe_constr_of_global : Globnames.global_reference -> constr in_universe_context - (** Returns the type of the global reference, by creating a fresh instance of polymorphic references and computing their instantiated universe context. (side-effect on the universe counter, use with care). *) val type_of_global : Globnames.global_reference -> types in_universe_context_set -(** [unsafe_type_of_global gr] returns [gr]'s type, works on polymorphic - references by taking the original universe instance that is not recorded - anywhere. The constraints are forgotten as well. - USE with care. *) -val unsafe_type_of_global : Globnames.global_reference -> types - (** Full universes substitutions into terms *) val nf_evars_and_universes_opt_subst : (existential -> constr option) -> universe_opt_subst -> constr -> constr -val simplify_universe_context : universe_context_set -> - universe_context_set * universe_level_subst - val refresh_constraints : UGraph.t -> universe_context_set -> universe_context_set * UGraph.t (** Pretty-printing *) diff --git a/install.sh b/install.sh index c5835b014..f8589a3c7 100755 --- a/install.sh +++ b/install.sh @@ -8,7 +8,7 @@ for f; do dn=`dirname $f` install -d "$dest/$dn" case $bn in - *.cmxs) install -m 755 $f "$dest/$dn/$bn" + *.cmxs|*.py) install -m 755 $f "$dest/$dn/$bn" ;; *) install -m 644 $f "$dest/$dn/$bn" ;; diff --git a/library/declare.ml b/interp/declare.ml index 28f108a15..154793a32 100644 --- a/library/declare.ml +++ b/interp/declare.ml @@ -333,9 +333,9 @@ let discharge_inductive ((sp,kn),(dhyps,mie)) = let mind = Global.mind_of_delta_kn kn in let mie = Global.lookup_mind mind in let repl = replacement_context () in - let sechyps,usubst,uctx = section_segment_of_mutual_inductive mind in + let sechyps, _, _ as info = section_segment_of_mutual_inductive mind in Some (discharged_hyps kn sechyps, - Discharge.process_inductive (named_of_variable_context sechyps,uctx) repl mie) + Discharge.process_inductive info repl mie) let dummy_one_inductive_entry mie = { mind_entry_typename = mie.mind_entry_typename; diff --git a/library/declare.mli b/interp/declare.mli index 6a0943464..6a0943464 100644 --- a/library/declare.mli +++ b/interp/declare.mli diff --git a/library/impargs.ml b/interp/impargs.ml index 351addf2f..b7125fc85 100644 --- a/library/impargs.ml +++ b/interp/impargs.ml @@ -431,12 +431,13 @@ let compute_mib_implicits flags manual kn = (Array.mapi (* No need to lift, arities contain no de Bruijn *) (fun i mip -> (** No need to care about constraints here *) - Context.Rel.Declaration.LocalAssum (Name mip.mind_typename, Global.type_of_global_unsafe (IndRef (kn,i)))) + let ty, _ = Global.type_of_global_in_context env (IndRef (kn,i)) in + Context.Rel.Declaration.LocalAssum (Name mip.mind_typename, ty)) mib.mind_packets) in let env_ar = push_rel_context ar env in let imps_one_inductive i mip = let ind = (kn,i) in - let ar = Global.type_of_global_unsafe (IndRef ind) in + let ar, _ = Global.type_of_global_in_context env (IndRef ind) in ((IndRef ind,compute_semi_auto_implicits env flags manual ar), Array.mapi (fun j c -> (ConstructRef (ind,j+1),compute_semi_auto_implicits env_ar flags manual c)) @@ -674,7 +675,7 @@ let projection_implicits env p impls = let declare_manual_implicits local ref ?enriching l = let flags = !implicit_args in let env = Global.env () in - let t = Global.type_of_global_unsafe ref in + let t, _ = Global.type_of_global_in_context (Global.env ()) ref in let enriching = Option.default flags.auto enriching in let isrigid,autoimpls = compute_auto_implicits env flags enriching t in let l' = match l with diff --git a/library/impargs.mli b/interp/impargs.mli index 4b78f54ea..4b78f54ea 100644 --- a/library/impargs.mli +++ b/interp/impargs.mli diff --git a/interp/notation.ml b/interp/notation.ml index 4067a6b94..c07a00943 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -718,13 +718,13 @@ let rebuild_arguments_scope (req,r,n,l,_) = match req with | ArgsScopeNoDischarge -> assert false | ArgsScopeAuto -> - let scs,cls = compute_arguments_scope_full (fst(Universes.type_of_global r)(*FIXME?*)) in + let scs,cls = compute_arguments_scope_full (fst(Global.type_of_global_in_context (Global.env ()) r)(*FIXME?*)) in (req,r,List.length scs,scs,cls) | ArgsScopeManual -> (* Add to the manually given scopes the one found automatically for the extra parameters of the section. Discard the classes of the manually given scopes to avoid further re-computations. *) - let l',cls = compute_arguments_scope_full (Global.type_of_global_unsafe r) in + let l',cls = compute_arguments_scope_full (fst (Global.type_of_global_in_context (Global.env ()) r)) in let l1 = List.firstn n l' in let cls1 = List.firstn n cls in (req,r,0,l1@l,cls1) @@ -768,7 +768,7 @@ let find_arguments_scope r = with Not_found -> [] let declare_ref_arguments_scope ref = - let t = Global.type_of_global_unsafe ref in + let t, _ = Global.type_of_global_in_context (Global.env ()) ref in let (scs,cls as o) = compute_arguments_scope_full t in declare_arguments_scope_gen ArgsScopeAuto ref (List.length scs) o diff --git a/kernel/cooking.ml b/kernel/cooking.ml index b9e7ec169..95822fac6 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -184,13 +184,14 @@ let lift_univs cb subst = if (Univ.LMap.is_empty subst) then subst, (Polymorphic_const auctx) else - let inst = Univ.AUContext.instance auctx in let len = Univ.LMap.cardinal subst in - let subst = - Array.fold_left_i - (fun i acc v -> Univ.LMap.add (Level.var i) (Level.var (i + len)) acc) - subst (Univ.Instance.to_array inst) + let rec gen_subst i acc = + if i < 0 then acc + else + let acc = Univ.LMap.add (Level.var i) (Level.var (i + len)) acc in + gen_subst (pred i) acc in + let subst = gen_subst (Univ.AUContext.size auctx - 1) subst in let auctx' = Univ.subst_univs_level_abstract_universe_context subst auctx in subst, (Polymorphic_const auctx') @@ -249,7 +250,7 @@ let cook_constant ~hcons env { from = cb; info } = let univs = match univs with | Monomorphic_const ctx -> - Monomorphic_const (UContext.union (instantiate_univ_context abs_ctx) ctx) + assert (AUContext.is_empty abs_ctx); univs | Polymorphic_const auctx -> Polymorphic_const (AUContext.union abs_ctx auctx) in diff --git a/kernel/declareops.ml b/kernel/declareops.ml index 9a75b1993..efce21982 100644 --- a/kernel/declareops.ml +++ b/kernel/declareops.ml @@ -44,78 +44,19 @@ let hcons_template_arity ar = (** {6 Constants } *) -let instantiate cb c = - match cb.const_universes with - | Monomorphic_const _ -> c - | Polymorphic_const ctx -> - Vars.subst_instance_constr (Univ.AUContext.instance ctx) c - let constant_is_polymorphic cb = match cb.const_universes with | Monomorphic_const _ -> false | Polymorphic_const _ -> true -let body_of_constant otab cb = match cb.const_body with - | Undef _ -> None - | Def c -> Some (instantiate cb (force_constr c)) - | OpaqueDef o -> Some (instantiate cb (Opaqueproof.force_proof otab o)) - -let type_of_constant cb = - match cb.const_type with - | RegularArity t as x -> - let t' = instantiate cb t in - if t' == t then x else RegularArity t' - | TemplateArity _ as x -> x - -let constraints_of_constant otab cb = - match cb.const_universes with - | Polymorphic_const ctx -> - Univ.UContext.constraints (Univ.instantiate_univ_context ctx) - | Monomorphic_const ctx -> - Univ.Constraint.union - (Univ.UContext.constraints ctx) - (match cb.const_body with - | Undef _ -> Univ.empty_constraint - | Def c -> Univ.empty_constraint - | OpaqueDef o -> - Univ.ContextSet.constraints (Opaqueproof.force_constraints otab o)) - -let universes_of_constant otab cb = - match cb.const_body with - | Undef _ | Def _ -> - begin - match cb.const_universes with - | Monomorphic_const ctx -> ctx - | Polymorphic_const ctx -> Univ.instantiate_univ_context ctx - end - | OpaqueDef o -> - let body_uctxs = Opaqueproof.force_constraints otab o in - match cb.const_universes with - | Monomorphic_const ctx -> - let uctxs = Univ.ContextSet.of_context ctx in - Univ.ContextSet.to_context (Univ.ContextSet.union body_uctxs uctxs) - | Polymorphic_const ctx -> - assert(Univ.ContextSet.is_empty body_uctxs); - Univ.instantiate_univ_context ctx - -let universes_of_polymorphic_constant otab cb = - match cb.const_universes with - | Monomorphic_const _ -> Univ.UContext.empty - | Polymorphic_const ctx -> Univ.instantiate_univ_context ctx - let constant_has_body cb = match cb.const_body with | Undef _ -> false | Def _ | OpaqueDef _ -> true -let constant_polymorphic_instance cb = - match cb.const_universes with - | Monomorphic_const _ -> Univ.Instance.empty - | Polymorphic_const ctx -> Univ.AUContext.instance ctx - let constant_polymorphic_context cb = match cb.const_universes with - | Monomorphic_const _ -> Univ.UContext.empty - | Polymorphic_const ctx -> Univ.instantiate_univ_context ctx + | Monomorphic_const _ -> Univ.AUContext.empty + | Polymorphic_const ctx -> ctx let is_opaque cb = match cb.const_body with | OpaqueDef _ -> true @@ -299,19 +240,11 @@ let subst_mind_body sub mib = mind_typing_flags = mib.mind_typing_flags; } -let inductive_polymorphic_instance mib = - match mib.mind_universes with - | Monomorphic_ind _ -> Univ.Instance.empty - | Polymorphic_ind ctx -> Univ.AUContext.instance ctx - | Cumulative_ind cumi -> - Univ.AUContext.instance (Univ.ACumulativityInfo.univ_context cumi) - let inductive_polymorphic_context mib = match mib.mind_universes with - | Monomorphic_ind _ -> Univ.UContext.empty - | Polymorphic_ind ctx -> Univ.instantiate_univ_context ctx - | Cumulative_ind cumi -> - Univ.instantiate_univ_context (Univ.ACumulativityInfo.univ_context cumi) + | Monomorphic_ind _ -> Univ.AUContext.empty + | Polymorphic_ind ctx -> ctx + | Cumulative_ind cumi -> Univ.ACumulativityInfo.univ_context cumi let inductive_is_polymorphic mib = match mib.mind_universes with diff --git a/kernel/declareops.mli b/kernel/declareops.mli index d698d88b4..a8ba5fa39 100644 --- a/kernel/declareops.mli +++ b/kernel/declareops.mli @@ -27,29 +27,14 @@ val subst_const_body : substitution -> constant_body -> constant_body val constant_has_body : constant_body -> bool -val constant_polymorphic_instance : constant_body -> universe_instance -val constant_polymorphic_context : constant_body -> universe_context +val constant_polymorphic_context : constant_body -> abstract_universe_context (** Is the constant polymorphic? *) val constant_is_polymorphic : constant_body -> bool -(** Accessing const_body, forcing access to opaque proof term if needed. - Only use this function if you know what you're doing. *) - -val body_of_constant : - Opaqueproof.opaquetab -> constant_body -> Term.constr option -val type_of_constant : constant_body -> constant_type -val constraints_of_constant : - Opaqueproof.opaquetab -> constant_body -> Univ.constraints -val universes_of_constant : - Opaqueproof.opaquetab -> constant_body -> Univ.universe_context - (** Return the universe context, in case the definition is polymorphic, otherwise the context is empty. *) -val universes_of_polymorphic_constant : - Opaqueproof.opaquetab -> constant_body -> Univ.universe_context - val is_opaque : constant_body -> bool (** Side effects *) @@ -72,8 +57,7 @@ val subst_wf_paths : substitution -> wf_paths -> wf_paths val subst_mind_body : substitution -> mutual_inductive_body -> mutual_inductive_body -val inductive_polymorphic_instance : mutual_inductive_body -> universe_instance -val inductive_polymorphic_context : mutual_inductive_body -> universe_context +val inductive_polymorphic_context : mutual_inductive_body -> abstract_universe_context (** Is the inductive polymorphic? *) val inductive_is_polymorphic : mutual_inductive_body -> bool diff --git a/kernel/entries.mli b/kernel/entries.ml index 3fa25c142..3fa25c142 100644 --- a/kernel/entries.mli +++ b/kernel/entries.ml diff --git a/kernel/environ.ml b/kernel/environ.ml index dd204c7d5..b01b65200 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -230,8 +230,7 @@ let add_constant kn cb env = let constraints_of cb u = match cb.const_universes with | Monomorphic_const _ -> Univ.Constraint.empty - | Polymorphic_const ctx -> - Univ.UContext.constraints (Univ.subst_instance_context u ctx) + | Polymorphic_const ctx -> Univ.AUContext.instantiate u ctx let map_regular_arity f = function | RegularArity a as ar -> @@ -248,17 +247,11 @@ let constant_type env (kn,u) = let csts = constraints_of cb u in (map_regular_arity (subst_instance_constr u) cb.const_type, csts) -let constant_instance env kn = - let cb = lookup_constant kn env in - match cb.const_universes with - | Monomorphic_const _ -> Univ.Instance.empty - | Polymorphic_const ctx -> Univ.AUContext.instance ctx - let constant_context env kn = let cb = lookup_constant kn env in match cb.const_universes with - | Monomorphic_const _ -> Univ.UContext.empty - | Polymorphic_const ctx -> Univ.instantiate_univ_context ctx + | Monomorphic_const _ -> Univ.AUContext.empty + | Polymorphic_const ctx -> ctx type const_evaluation_result = NoBody | Opaque | IsProj diff --git a/kernel/environ.mli b/kernel/environ.mli index f8887d8e8..cd7a9d279 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -160,10 +160,7 @@ val constant_value_and_type : env -> constant puniverses -> constr option * constant_type * Univ.constraints (** The universe context associated to the constant, empty if not polymorphic *) -val constant_context : env -> constant -> Univ.universe_context -(** The universe isntance associated to the constant, empty if not - polymorphic *) -val constant_instance : env -> constant -> Univ.universe_instance +val constant_context : env -> constant -> Univ.abstract_universe_context (* These functions should be called under the invariant that [env] already contains the constraints corresponding to the constant diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index 04971f83d..e248436ec 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -961,13 +961,10 @@ let build_inductive env prv iu env_ar paramsctxt kn isrecord isfinite inds nmr r && pkt.mind_consnrealargs.(0) > 0 -> (** The elimination criterion ensures that all projections can be defined. *) let u = - let process auctx = - subst_univs_level_instance substunivs (Univ.AUContext.instance auctx) - in match aiu with | Monomorphic_ind _ -> Univ.Instance.empty - | Polymorphic_ind auctx -> process auctx - | Cumulative_ind acumi -> process (Univ.ACumulativityInfo.univ_context acumi) + | Polymorphic_ind auctx -> Univ.make_abstract_instance auctx + | Cumulative_ind acumi -> Univ.make_abstract_instance (Univ.ACumulativityInfo.univ_context acumi) in let indsp = ((kn, 0), u) in let rctx, indty = decompose_prod_assum (subst1 (mkIndU indsp) pkt.mind_nf_lc.(0)) in diff --git a/kernel/inductive.ml b/kernel/inductive.ml index e3fb472be..1eaba49aa 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -54,9 +54,7 @@ let inductive_paramdecls (mib,u) = Vars.subst_instance_context u mib.mind_params_ctxt let instantiate_inductive_constraints mib u = - let process auctx = - Univ.UContext.constraints (Univ.subst_instance_context u auctx) - in + let process auctx = Univ.AUContext.instantiate u auctx in match mib.mind_universes with | Monomorphic_ind _ -> Univ.Constraint.empty | Polymorphic_ind auctx -> process auctx diff --git a/kernel/kernel.mllib b/kernel/kernel.mllib index 0813315b5..dd3f9a2f8 100644 --- a/kernel/kernel.mllib +++ b/kernel/kernel.mllib @@ -9,6 +9,8 @@ Constr Context Vars Term +Declarations +Entries Mod_subst Cbytecodes Copcodes @@ -41,5 +43,4 @@ Nativelibrary Safe_typing Vm Csymtable -Declarations Vconv diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml index f53ef6f56..c7f3e5c51 100644 --- a/kernel/mod_typing.ml +++ b/kernel/mod_typing.ml @@ -72,16 +72,13 @@ let rec check_with_def env struc (idl,(c,ctx)) mp equiv = (* In the spirit of subtyping.check_constant, we accept any implementations of parameters and opaques terms, as long as they have the right type *) - let uctx = Declareops.universes_of_constant (opaque_tables env) cb in - let uctx = (* Context of the spec *) + let c', univs, ctx' = match cb.const_universes with - | Monomorphic_const _ -> uctx - | Polymorphic_const auctx -> - Univ.instantiate_univ_context auctx - in - let c', univs, ctx' = - if not (Declareops.constant_is_polymorphic cb) then - let env' = Environ.push_context ~strict:true uctx env' in + | Monomorphic_const _ -> + (** We do not add the deferred constraints of the body in the + environment, because they do not appear in the type of the + definition. Any inconsistency will be raised at a later stage + when joining the environment. *) let env' = Environ.push_context ~strict:true ctx env' in let c',cst = match cb.const_body with | Undef _ | OpaqueDef _ -> @@ -94,37 +91,30 @@ let rec check_with_def env struc (idl,(c,ctx)) mp equiv = let c' = Mod_subst.force_constr cs in c, Reduction.infer_conv env' (Environ.universes env') c c' in c', Monomorphic_const ctx, Univ.ContextSet.add_constraints cst (Univ.ContextSet.of_context ctx) - else - let cus, ccst = Univ.UContext.dest uctx in - let newus, cst = Univ.UContext.dest ctx in - let () = - if not (Univ.Instance.length cus == Univ.Instance.length newus) then - error_incorrect_with_constraint lab - in - let inst = Univ.Instance.append cus newus in - let csti = Univ.enforce_eq_instances cus newus cst in - let csta = Univ.Constraint.union csti ccst in - let env' = Environ.push_context ~strict:false (Univ.UContext.make (inst, csta)) env in - let () = if not (UGraph.check_constraints cst (Environ.universes env')) then - error_incorrect_with_constraint lab - in + | Polymorphic_const uctx -> + let subst, ctx = Univ.abstract_universes ctx in + let c = Vars.subst_univs_level_constr subst c in + let () = + if not (UGraph.check_subtype (Environ.universes env) uctx ctx) then + error_incorrect_with_constraint lab + in + (** Terms are compared in a context with De Bruijn universe indices *) + let env' = Environ.push_context ~strict:false (Univ.AUContext.repr uctx) env in 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 = Vars.subst_instance_constr cus typ in let cst' = Reduction.infer_conv_leq env' (Environ.universes env') j.uj_type typ in cst' | Def cs -> - let c' = Vars.subst_instance_constr cus (Mod_subst.force_constr cs) in + let c' = Mod_subst.force_constr cs in let cst' = Reduction.infer_conv env' (Environ.universes env') c c' in cst' in if not (Univ.Constraint.is_empty cst) then error_incorrect_with_constraint lab; - let subst, ctx = Univ.abstract_universes ctx in - Vars.subst_univs_level_constr subst c, Polymorphic_const ctx, Univ.ContextSet.empty + c, Polymorphic_const ctx, Univ.ContextSet.empty in let def = Def (Mod_subst.from_val c') in (* let ctx' = Univ.UContext.make (newus, cst) in *) diff --git a/kernel/modops.ml b/kernel/modops.ml index 24be46933..a079bc893 100644 --- a/kernel/modops.ml +++ b/kernel/modops.ml @@ -49,7 +49,7 @@ type signature_mismatch_error = | IncompatibleInstances | IncompatibleUniverses of Univ.univ_inconsistency | IncompatiblePolymorphism of env * types * types - | IncompatibleConstraints of Univ.constraints + | IncompatibleConstraints of Univ.AUContext.t type module_typing_error = | SignatureMismatch of diff --git a/kernel/modops.mli b/kernel/modops.mli index 4a150d54b..e2a94b691 100644 --- a/kernel/modops.mli +++ b/kernel/modops.mli @@ -108,7 +108,7 @@ type signature_mismatch_error = | IncompatibleInstances | IncompatibleUniverses of Univ.univ_inconsistency | IncompatiblePolymorphism of env * types * types - | IncompatibleConstraints of Univ.constraints + | IncompatibleConstraints of Univ.AUContext.t type module_typing_error = | SignatureMismatch of diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml index eb238941b..da7fcd6f2 100644 --- a/kernel/nativecode.ml +++ b/kernel/nativecode.ml @@ -48,9 +48,9 @@ let fresh_lname n = (** Global names **) type gname = - | Gind of string * pinductive (* prefix, inductive name *) - | Gconstruct of string * pconstructor (* prefix, constructor name *) - | Gconstant of string * pconstant (* prefix, constant name *) + | Gind of string * inductive (* prefix, inductive name *) + | Gconstruct of string * constructor (* prefix, constructor name *) + | Gconstant of string * constant (* prefix, constant name *) | Gproj of string * constant (* prefix, constant name *) | Gcase of label option * int | Gpred of label option * int @@ -64,11 +64,11 @@ type gname = let eq_gname gn1 gn2 = match gn1, gn2 with | Gind (s1, ind1), Gind (s2, ind2) -> - String.equal s1 s2 && Univ.eq_puniverses eq_ind ind1 ind2 + String.equal s1 s2 && eq_ind ind1 ind2 | Gconstruct (s1, c1), Gconstruct (s2, c2) -> - String.equal s1 s2 && Univ.eq_puniverses eq_constructor c1 c2 + String.equal s1 s2 && eq_constructor c1 c2 | Gconstant (s1, c1), Gconstant (s2, c2) -> - String.equal s1 s2 && Univ.eq_puniverses Constant.equal c1 c2 + String.equal s1 s2 && Constant.equal c1 c2 | Gcase (None, i1), Gcase (None, i2) -> Int.equal i1 i2 | Gcase (Some l1, i1), Gcase (Some l2, i2) -> Int.equal i1 i2 && Label.equal l1 l2 | Gpred (None, i1), Gpred (None, i2) -> Int.equal i1 i2 @@ -92,12 +92,12 @@ let dummy_gname = open Hashset.Combine let gname_hash gn = match gn with -| Gind (s, (ind,u)) -> - combinesmall 1 (combine3 (String.hash s) (ind_hash ind) (Univ.Instance.hash u)) -| Gconstruct (s, (c,u)) -> - combinesmall 2 (combine3 (String.hash s) (constructor_hash c) (Univ.Instance.hash u)) -| Gconstant (s, (c,u)) -> - combinesmall 3 (combine3 (String.hash s) (Constant.hash c) (Univ.Instance.hash u)) +| Gind (s, ind) -> + combinesmall 1 (combine (String.hash s) (ind_hash ind)) +| Gconstruct (s, c) -> + combinesmall 2 (combine (String.hash s) (constructor_hash c)) +| Gconstant (s, c) -> + combinesmall 3 (combine (String.hash s) (Constant.hash c)) | Gcase (l, i) -> combinesmall 4 (combine (Option.hash Label.hash l) (Int.hash i)) | Gpred (l, i) -> combinesmall 5 (combine (Option.hash Label.hash l) (Int.hash i)) | Gfixtype (l, i) -> combinesmall 6 (combine (Option.hash Label.hash l) (Int.hash i)) @@ -1068,9 +1068,9 @@ let ml_of_instance instance u = MLlet(lname,def,body) | Lapp(f,args) -> MLapp(ml_of_lam env l f, Array.map (ml_of_lam env l) args) - | Lconst (prefix,c) -> - let args = ml_of_instance env.env_univ (snd c) in - mkMLapp (MLglobal(Gconstant (prefix,c))) args + | Lconst (prefix, (c, u)) -> + let args = ml_of_instance env.env_univ u in + mkMLapp (MLglobal(Gconstant (prefix, c))) args | Lproj (prefix,c) -> MLglobal(Gproj (prefix,c)) | Lprim _ -> let decl,cond,paux = extract_prim (ml_of_lam env l) t in @@ -1281,17 +1281,17 @@ let ml_of_instance instance u = MLconstruct(prefix,cn,args) | Lconstruct (prefix, (cn,u)) -> let uargs = ml_of_instance env.env_univ u in - mkMLapp (MLglobal (Gconstruct (prefix, (cn,u)))) uargs + mkMLapp (MLglobal (Gconstruct (prefix, cn))) uargs | Luint v -> (match v with | UintVal i -> MLapp(MLprimitive Mk_uint, [|MLuint i|]) | UintDigits (prefix,cn,ds) -> - let c = MLglobal (Gconstruct (prefix, (cn, Univ.Instance.empty))) in + let c = MLglobal (Gconstruct (prefix, cn)) in let ds = Array.map (ml_of_lam env l) ds in let i31 = MLapp (MLprimitive Mk_I31_accu, [|c|]) in MLapp(i31, ds) | UintDecomp (prefix,cn,t) -> - let c = MLglobal (Gconstruct (prefix, (cn, Univ.Instance.empty))) in + let c = MLglobal (Gconstruct (prefix, cn)) in let t = ml_of_lam env l t in MLapp (MLprimitive Decomp_uint, [|c;t|])) | Lval v -> @@ -1304,9 +1304,9 @@ let ml_of_instance instance u = in let uarg = MLapp(MLprimitive MLmagic, [|uarg|]) in MLapp(MLprimitive Mk_sort, [|get_sort_code i; uarg|]) - | Lind (prefix, pind) -> - let uargs = ml_of_instance env.env_univ (snd pind) in - mkMLapp (MLglobal (Gind (prefix, pind))) uargs + | Lind (prefix, (ind, u)) -> + let uargs = ml_of_instance env.env_univ u in + mkMLapp (MLglobal (Gind (prefix, ind))) uargs | Llazy -> MLglobal (Ginternal "lazy") | Lforce -> MLglobal (Ginternal "Lazy.force") @@ -1539,11 +1539,11 @@ let string_of_mind mind = string_of_kn (user_mind mind) let string_of_gname g = match g with - | Gind (prefix, ((mind,i), _)) -> + | Gind (prefix, (mind, i)) -> Format.sprintf "%sindaccu_%s_%i" prefix (string_of_mind mind) i - | Gconstruct (prefix, (((mind, i), j), _)) -> + | Gconstruct (prefix, ((mind, i), j)) -> Format.sprintf "%sconstruct_%s_%i_%i" prefix (string_of_mind mind) i (j-1) - | Gconstant (prefix, (c,_)) -> + | Gconstant (prefix, c) -> Format.sprintf "%sconst_%s" prefix (string_of_con c) | Gproj (prefix, c) -> Format.sprintf "%sproj_%s" prefix (string_of_con c) @@ -1754,9 +1754,8 @@ let pp_mllam fmt l = | Coq_primitive (op,None) -> Format.fprintf fmt "no_check_%s" (Primitives.to_string op) | Coq_primitive (op, Some (prefix,kn)) -> - let u = Univ.Instance.empty in Format.fprintf fmt "%s %a" (Primitives.to_string op) - pp_mllam (MLglobal (Gconstant (prefix,(kn,u)))) + pp_mllam (MLglobal (Gconstant (prefix, kn))) in Format.fprintf fmt "@[%a@]" pp_mllam l @@ -1862,10 +1861,10 @@ and compile_named env sigma univ auxdefs id = let compile_constant env sigma prefix ~interactive con cb = match cb.const_proj with | None -> - let u = + let no_univs = match cb.const_universes with - | Monomorphic_const _ -> Univ.Instance.empty - | Polymorphic_const ctx -> Univ.AUContext.instance ctx + | Monomorphic_const _ -> true + | Polymorphic_const ctx -> Int.equal (Univ.AUContext.size ctx) 0 in begin match cb.const_body with | Def t -> @@ -1880,7 +1879,7 @@ let compile_constant env sigma prefix ~interactive con cb = in let l = con_label con in let auxdefs,code = - if Univ.Instance.is_empty u then compile_with_fv env sigma None [] (Some l) code + if no_univs then compile_with_fv env sigma None [] (Some l) code else let univ = fresh_univ () in let (auxdefs,code) = compile_with_fv env sigma (Some univ) [] (Some l) code in @@ -1888,25 +1887,24 @@ let compile_constant env sigma prefix ~interactive con cb = in if !Flags.debug then Feedback.msg_debug (Pp.str "Generated mllambda code"); let code = - optimize_stk (Glet(Gconstant ("",(con,u)),code)::auxdefs) + optimize_stk (Glet(Gconstant ("", con),code)::auxdefs) in if !Flags.debug then Feedback.msg_debug (Pp.str "Optimized mllambda code"); code, name | _ -> let i = push_symbol (SymbConst con) in let args = - if Univ.Instance.is_empty u then [|get_const_code i; MLarray [||]|] + if no_univs then [|get_const_code i; MLarray [||]|] else [|get_const_code i|] in (* let t = mkMLlam [|univ|] (mkMLapp (MLprimitive Mk_const) *) - [Glet(Gconstant ("",(con,u)), mkMLapp (MLprimitive Mk_const) args)], + [Glet(Gconstant ("", con), mkMLapp (MLprimitive Mk_const) args)], if interactive then LinkedInteractive prefix else Linked prefix end | Some pb -> - let u = Univ.Instance.empty in let mind = pb.proj_ind in let ind = (mind,0) in let mib = lookup_mind mind env in @@ -1933,7 +1931,7 @@ let compile_constant env sigma prefix ~interactive con cb = let gn = Gproj ("",con) in let fargs = Array.init (pb.proj_npars + 1) (fun _ -> fresh_lname Anonymous) in let arg = fargs.(pb.proj_npars) in - Glet(Gconstant ("",(con,u)), mkMLlam fargs (MLapp (MLglobal gn, [|MLlocal + Glet(Gconstant ("", con), mkMLlam fargs (MLapp (MLglobal gn, [|MLlocal arg|]))):: [Glet(gn, mkMLlam [|c_uid|] code)], Linked prefix @@ -1961,14 +1959,14 @@ let param_name = Name (id_of_string "params") let arg_name = Name (id_of_string "arg") let compile_mind prefix ~interactive mb mind stack = - let u = Declareops.inductive_polymorphic_instance mb in + let u = Declareops.inductive_polymorphic_context mb in let f i stack ob = let gtype = Gtype((mind, i), Array.map snd ob.mind_reloc_tbl) in let j = push_symbol (SymbInd (mind,i)) in - let name = Gind ("", ((mind, i), u)) in + let name = Gind ("", (mind, i)) in let accu = let args = - if Univ.Instance.is_empty u then + if Int.equal (Univ.AUContext.size u) 0 then [|get_ind_code j; MLarray [||]|] else [|get_ind_code j|] in @@ -1980,7 +1978,7 @@ let compile_mind prefix ~interactive mb mind stack = let add_construct j acc (_,arity) = let args = Array.init arity (fun k -> {lname = arg_name; luid = k}) in let c = (mind,i), (j+1) in - Glet(Gconstruct ("",(c,u)), + Glet(Gconstruct ("", c), mkMLlam (Array.append params args) (MLconstruct("", c, Array.map (fun id -> MLlocal id) args)))::acc in diff --git a/kernel/reduction.ml b/kernel/reduction.ml index de4efbba9..2bf9f43a5 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -680,8 +680,7 @@ let infer_check_conv_constructors let check_inductive_instances cv_pb cumi u u' univs = let length_ind_instance = - Univ.Instance.length - (Univ.AUContext.instance (Univ.ACumulativityInfo.univ_context cumi)) + Univ.AUContext.size (Univ.ACumulativityInfo.univ_context cumi) in let ind_subtypctx = Univ.ACumulativityInfo.subtyp_context cumi in if not ((length_ind_instance = Univ.Instance.length u) && @@ -690,16 +689,14 @@ let check_inductive_instances cv_pb cumi u u' univs = else let comp_cst = let comp_subst = (Univ.Instance.append u u') in - Univ.UContext.constraints - (Univ.subst_instance_context comp_subst ind_subtypctx) + Univ.AUContext.instantiate comp_subst ind_subtypctx in let comp_cst = match cv_pb with CONV -> let comp_cst' = let comp_subst = (Univ.Instance.append u' u) in - Univ.UContext.constraints - (Univ.subst_instance_context comp_subst ind_subtypctx) + Univ.AUContext.instantiate comp_subst ind_subtypctx in Univ.Constraint.union comp_cst comp_cst' | CUMUL -> comp_cst @@ -767,8 +764,7 @@ let infer_convert_instances ~flex u u' (univs,cstrs) = let infer_inductive_instances cv_pb cumi u u' (univs, cstrs) = let length_ind_instance = - Univ.Instance.length - (Univ.AUContext.instance (Univ.ACumulativityInfo.univ_context cumi)) + Univ.AUContext.size (Univ.ACumulativityInfo.univ_context cumi) in let ind_subtypctx = Univ.ACumulativityInfo.subtyp_context cumi in if not ((length_ind_instance = Univ.Instance.length u) && @@ -777,16 +773,15 @@ let infer_inductive_instances cv_pb cumi u u' (univs, cstrs) = else let comp_cst = let comp_subst = (Univ.Instance.append u u') in - Univ.UContext.constraints - (Univ.subst_instance_context comp_subst ind_subtypctx) + Univ.AUContext.instantiate comp_subst ind_subtypctx in let comp_cst = match cv_pb with CONV -> let comp_cst' = let comp_subst = (Univ.Instance.append u' u) in - Univ.UContext.constraints - (Univ.subst_instance_context comp_subst ind_subtypctx) in + Univ.AUContext.instantiate comp_subst ind_subtypctx + in Univ.Constraint.union comp_cst comp_cst' | CUMUL -> comp_cst in diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml index 44a1e6191..bd82dd465 100644 --- a/kernel/subtyping.ml +++ b/kernel/subtyping.ml @@ -80,10 +80,8 @@ let make_labmap mp list = List.fold_right add_one list empty_labmap -let check_conv_error error why cst poly u f env a1 a2 = +let check_conv_error error why cst poly f env a1 a2 = try - let a1 = Vars.subst_instance_constr u a1 in - let a2 = Vars.subst_instance_constr u a2 in let cst' = f env (Environ.universes env) a1 a2 in if poly then if Constraint.is_empty cst' then cst @@ -92,36 +90,42 @@ let check_conv_error error why cst poly u f env a1 a2 = with NotConvertible -> error why | Univ.UniverseInconsistency e -> error (IncompatibleUniverses e) +let check_polymorphic_instance error env auctx1 auctx2 = + if not (Univ.AUContext.size auctx1 == Univ.AUContext.size auctx2) then + error IncompatibleInstances + else if not (UGraph.check_subtype (Environ.universes env) auctx2 auctx1) then + error (IncompatibleConstraints auctx1) + else + Environ.push_context ~strict:false (Univ.AUContext.repr auctx2) env + (* for now we do not allow reorderings *) let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2= let kn1 = KerName.make2 mp1 l in let kn2 = KerName.make2 mp2 l in let error why = error_signature_mismatch l spec2 why in - let check_conv why cst poly u f = check_conv_error error why cst poly u f in + let check_conv why cst poly f = check_conv_error error why cst poly f in let mib1 = match info1 with | IndType ((_,0), mib) -> Declareops.subst_mind_body subst1 mib | _ -> error (InductiveFieldExpected mib2) in - let u = - let process inst inst' = - if Univ.Instance.equal inst inst' then inst else error IncompatibleInstances - in + let env, inst = match mib1.mind_universes, mib2.mind_universes with - | Monomorphic_ind _, Monomorphic_ind _ -> Univ.Instance.empty + | Monomorphic_ind _, Monomorphic_ind _ -> env, Univ.Instance.empty | Polymorphic_ind auctx, Polymorphic_ind auctx' -> - process - (Univ.AUContext.instance auctx) (Univ.AUContext.instance auctx') + let env = check_polymorphic_instance error env auctx auctx' in + env, Univ.make_abstract_instance auctx' | Cumulative_ind cumi, Cumulative_ind cumi' -> - process - (Univ.AUContext.instance (Univ.ACumulativityInfo.univ_context cumi)) - (Univ.AUContext.instance (Univ.ACumulativityInfo.univ_context cumi')) + let auctx = Univ.ACumulativityInfo.univ_context cumi in + let auctx' = Univ.ACumulativityInfo.univ_context cumi' in + let env = check_polymorphic_instance error env auctx auctx' in + env, Univ.make_abstract_instance auctx' | _ -> error (CumulativeStatusExpected (Declareops.inductive_is_cumulative mib2)) in let mib2 = Declareops.subst_mind_body subst2 mib2 in - let check_inductive_type cst name env t1 t2 = + let check_inductive_type cst name t1 t2 = (* Due to template polymorphism, the conclusions of t1 and t2, if in Type, are generated as the least upper bounds @@ -154,7 +158,7 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2 error (NotConvertibleInductiveField name) | _ -> (s1, s2) in check_conv (NotConvertibleInductiveField name) - cst (inductive_is_polymorphic mib1) u infer_conv_leq env (mkArity (ctx1,s1)) (mkArity (ctx2,s2)) + cst (inductive_is_polymorphic mib1) infer_conv_leq env (mkArity (ctx1,s1)) (mkArity (ctx2,s2)) in let check_packet cst p1 p2 = @@ -172,21 +176,20 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2 (* nparams done *) (* params_ctxt done because part of the inductive types *) (* Don't check the sort of the type if polymorphic *) - let ty1, cst1 = constrained_type_of_inductive env ((mib1,p1),u) in - let ty2, cst2 = constrained_type_of_inductive env ((mib2,p2),u) in - let cst = Constraint.union cst1 (Constraint.union cst2 cst) in - let cst = check_inductive_type cst p2.mind_typename env ty1 ty2 in + let ty1 = type_of_inductive env ((mib1, p1), inst) in + let ty2 = type_of_inductive env ((mib2, p2), inst) in + let cst = check_inductive_type cst p2.mind_typename ty1 ty2 in cst in let mind = mind_of_kn kn1 in let check_cons_types i cst p1 p2 = Array.fold_left3 (fun cst id t1 t2 -> check_conv (NotConvertibleConstructorField id) cst - (inductive_is_polymorphic mib1) u infer_conv env t1 t2) + (inductive_is_polymorphic mib1) infer_conv env t1 t2) cst p2.mind_consnames - (arities_of_specif (mind,u) (mib1,p1)) - (arities_of_specif (mind,u) (mib2,p2)) + (arities_of_specif (mind, inst) (mib1, p1)) + (arities_of_specif (mind, inst) (mib2, p2)) in let check f test why = if not (test (f mib1) (f mib2)) then error (why (f mib2)) in check (fun mib -> mib.mind_finite<>Decl_kinds.CoFinite) (==) (fun x -> FiniteInductiveFieldExpected x); @@ -242,8 +245,8 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2 let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 = let error why = error_signature_mismatch l spec2 why in - let check_conv cst poly u f = check_conv_error error cst poly u f in - let check_type poly u cst env t1 t2 = + let check_conv cst poly f = check_conv_error error cst poly f in + let check_type poly cst env t1 t2 = let err = NotConvertibleTypeField (env, t1, t2) in @@ -290,7 +293,7 @@ let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 = t1,t2 else (t1,t2) in - check_conv err cst poly u infer_conv_leq env t1 t2 + check_conv err cst poly infer_conv_leq env t1 t2 in match info1 with | Constant cb1 -> @@ -298,48 +301,21 @@ let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 = let cb1 = Declareops.subst_const_body subst1 cb1 in let cb2 = Declareops.subst_const_body subst2 cb2 in (* Start by checking universes *) - let poly = - if not (Declareops.constant_is_polymorphic cb1 - == Declareops.constant_is_polymorphic cb2) then - error (PolymorphicStatusExpected (Declareops.constant_is_polymorphic cb2)) - else Declareops.constant_is_polymorphic cb2 - in - let cst', env', u = + let poly, env = match cb1.const_universes, cb2.const_universes with | Monomorphic_const _, Monomorphic_const _ -> - cst, env, Univ.Instance.empty + false, env | Polymorphic_const auctx1, Polymorphic_const auctx2 -> - begin - let ctx1 = Univ.instantiate_univ_context auctx1 in - let ctx2 = Univ.instantiate_univ_context auctx2 in - let inst1, ctx1 = Univ.UContext.dest ctx1 in - let inst2, ctx2 = Univ.UContext.dest ctx2 in - if not (Univ.Instance.length inst1 == Univ.Instance.length inst2) then - error IncompatibleInstances - else - let cstrs = Univ.enforce_eq_instances inst1 inst2 cst in - let cstrs = Univ.Constraint.union cstrs ctx2 in - try - (* The environment with the expected universes plus equality - of the body instances with the expected instance *) - let ctxi = Univ.Instance.append inst1 inst2 in - let ctx = Univ.UContext.make (ctxi, cstrs) in - let env = Environ.push_context ctx env in - (* Check that the given definition does not add any constraint over - the expected ones, so that it can be used in place of - the original. *) - if UGraph.check_constraints ctx1 (Environ.universes env) then - cstrs, env, inst2 - else error (IncompatibleConstraints ctx1) - with Univ.UniverseInconsistency incon -> - error (IncompatibleUniverses incon) - end - | _ -> assert false + true, check_polymorphic_instance error env auctx1 auctx2 + | Monomorphic_const _, Polymorphic_const _ -> + error (PolymorphicStatusExpected true) + | Polymorphic_const _, Monomorphic_const _ -> + 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 cst = check_type poly u cst env' typ1 typ2 in + 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 cst = check_type poly cst env typ1 typ2 in (* Now we check the bodies: - A transparent constant can only be implemented by a compatible transparent constant. @@ -356,40 +332,19 @@ let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 = Anyway [check_conv] will handle that afterwards. *) let c1 = Mod_subst.force_constr lc1 in let c2 = Mod_subst.force_constr lc2 in - check_conv NotConvertibleBodyField cst poly u infer_conv env' c1 c2)) + check_conv NotConvertibleBodyField cst poly infer_conv env c1 c2)) | IndType ((kn,i),mind1) -> - ignore (CErrors.user_err Pp.(str @@ + CErrors.user_err Pp.(str @@ "The kernel does not recognize yet that a parameter can be " ^ "instantiated by an inductive type. Hint: you can rename the " ^ "inductive type and give a definition to map the old name to the new " ^ - "name.")); - let () = assert (List.is_empty mind1.mind_hyps && List.is_empty cb2.const_hyps) in - if Declareops.constant_has_body cb2 then error DefinitionFieldExpected; - let u1 = inductive_polymorphic_instance mind1 in - let arity1,cst1 = constrained_type_of_inductive env - ((mind1,mind1.mind_packets.(i)),u1) in - let cst2 = - Declareops.constraints_of_constant (Environ.opaque_tables env) cb2 in - let typ2 = Typeops.type_of_constant_type env cb2.const_type in - let cst = Constraint.union cst (Constraint.union cst1 cst2) in - let error = NotConvertibleTypeField (env, arity1, typ2) in - check_conv error cst false Univ.Instance.empty infer_conv_leq env arity1 typ2 - | IndConstr (((kn,i),j) as cstr,mind1) -> - ignore (CErrors.user_err Pp.(str @@ + "name.") + | IndConstr (((kn,i),j),mind1) -> + CErrors.user_err Pp.(str @@ "The kernel does not recognize yet that a parameter can be " ^ "instantiated by a constructor. Hint: you can rename the " ^ "constructor and give a definition to map the old name to the new " ^ - "name.")); - let () = assert (List.is_empty mind1.mind_hyps && List.is_empty cb2.const_hyps) in - if Declareops.constant_has_body cb2 then error DefinitionFieldExpected; - let u1 = inductive_polymorphic_instance mind1 in - let ty1,cst1 = constrained_type_of_constructor (cstr,u1) (mind1,mind1.mind_packets.(i)) in - let cst2 = - Declareops.constraints_of_constant (Environ.opaque_tables env) cb2 in - let ty2 = Typeops.type_of_constant_type env cb2.const_type in - let cst = Constraint.union cst (Constraint.union cst1 cst2) in - let error = NotConvertibleTypeField (env, ty1, ty2) in - check_conv error cst false Univ.Instance.empty infer_conv env ty1 ty2 + "name.") let rec check_modules cst env msb1 msb2 subst1 subst2 = let mty1 = module_type_of_module msb1 in diff --git a/kernel/subtyping.mli b/kernel/subtyping.mli index 6590d7e71..b24c20aa0 100644 --- a/kernel/subtyping.mli +++ b/kernel/subtyping.mli @@ -11,5 +11,3 @@ open Declarations open Environ val check_subtypes : env -> module_type_body -> module_type_body -> constraints - - diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index 283febed2..cf82d54ec 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -131,8 +131,7 @@ let inline_side_effects env body ctx side_eff = (subst, var + 1, ctx, (cname c, b, ty, opaque) :: args) | Polymorphic_const auctx -> (** Inline the term to emulate universe polymorphism *) - let data = (Univ.AUContext.instance auctx, b) in - let subst = Cmap_env.add c (Inl data) subst in + let subst = Cmap_env.add c (Inl b) subst in (subst, var, ctx, args) in let (subst, len, ctx, args) = List.fold_left fold (Cmap_env.empty, 1, ctx, []) side_eff in @@ -142,7 +141,7 @@ let inline_side_effects env body ctx side_eff = let data = try Some (Cmap_env.find c subst) with Not_found -> None in begin match data with | None -> t - | Some (Inl (inst, b)) -> + | Some (Inl b) -> (** [b] is closed but may refer to other constants *) subst_const i k (Vars.subst_instance_constr u b) | Some (Inr n) -> @@ -266,11 +265,8 @@ let infer_declaration ~trust env kn dcl = let body,env,ectx = skip_trusted_seff valid_signatures body env in let j = infer env body in unzip ectx j in - let subst = Univ.LMap.empty in let _ = judge_of_cast env j DEFAULTcast tyj in - assert (eq_constr typ tyj.utj_val); let c = hcons_constr j.uj_val in - let _typ = RegularArity (Vars.subst_univs_level_constr subst typ) in feedback_completion_typecheck feedback_id; c, uctx) in let def = OpaqueDef (Opaqueproof.create proofterm) in @@ -300,7 +296,6 @@ let infer_declaration ~trust env kn dcl = | Some t -> let tj = infer_type env t in let _ = judge_of_cast env j DEFAULTcast tj in - assert (eq_constr t tj.utj_val); RegularArity (Vars.subst_univs_level_constr usubst t) in let def = hcons_constr (Vars.subst_univs_level_constr usubst j.uj_val) in @@ -470,7 +465,7 @@ let constant_entry_of_side_effect cb u = match cb.const_universes with | Monomorphic_const ctx -> false, ctx | Polymorphic_const auctx -> - true, Univ.instantiate_univ_context auctx + true, Univ.AUContext.repr auctx in let pt = match cb.const_body, u with diff --git a/kernel/uGraph.ml b/kernel/uGraph.ml index 487257a77..9793dd881 100644 --- a/kernel/uGraph.ml +++ b/kernel/uGraph.ml @@ -830,6 +830,18 @@ let sort_universes g = in normalize_universes g +(** Subtyping of polymorphic contexts *) + +let check_subtype univs ctxT ctx = + if AUContext.size ctx == AUContext.size ctx then + let (inst, cst) = UContext.dest (AUContext.repr ctx) in + let cstT = UContext.constraints (AUContext.repr ctxT) in + let push accu v = add_universe v false accu in + let univs = Array.fold_left push univs (Instance.to_array inst) in + let univs = merge_constraints cstT univs in + check_constraints cst univs + else false + (** Instances *) let check_eq_instances g t1 t2 = diff --git a/kernel/uGraph.mli b/kernel/uGraph.mli index 935a3cab4..4de373eb4 100644 --- a/kernel/uGraph.mli +++ b/kernel/uGraph.mli @@ -53,6 +53,10 @@ val check_constraints : constraints -> universes -> bool val check_eq_instances : Instance.t check_function (** Check equality of instances w.r.t. a universe graph *) +val check_subtype : AUContext.t check_function +(** [check_subtype univ ctx1 ctx2] checks whether [ctx2] is an instance of + [ctx1]. *) + (** {6 Pretty-printing of universes. } *) val pr_universes : (Level.t -> Pp.std_ppcmds) -> universes -> Pp.std_ppcmds diff --git a/kernel/univ.ml b/kernel/univ.ml index 1c887e2a9..02b02db89 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -988,6 +988,31 @@ let enforce_eq_instances x y = (Pp.str " instances of different lengths.")); CArray.fold_right2 enforce_eq_level ax ay +let subst_instance_level s l = + match l.Level.data with + | Level.Var n -> s.(n) + | _ -> l + +let subst_instance_instance s i = + Array.smartmap (fun l -> subst_instance_level s l) i + +let subst_instance_universe s u = + let f x = Universe.Expr.map (fun u -> subst_instance_level s u) x in + let u' = Universe.smartmap f u in + if u == u' then u + else Universe.sort u' + +let subst_instance_constraint s (u,d,v as c) = + let u' = subst_instance_level s u in + let v' = subst_instance_level s v in + if u' == u && v' == v then c + else (u',d,v') + +let subst_instance_constraints s csts = + Constraint.fold + (fun c csts -> Constraint.add (subst_instance_constraint s c) csts) + csts Constraint.empty + type universe_instance = Instance.t type 'a puniverses = 'a * Instance.t @@ -1031,7 +1056,18 @@ end type universe_context = UContext.t let hcons_universe_context = UContext.hcons -module AUContext = UContext +module AUContext = +struct + include UContext + + let repr (inst, cst) = + (Array.mapi (fun i l -> Level.var i) inst, cst) + + let instantiate inst (u, cst) = + assert (Array.length u = Array.length inst); + subst_instance_constraints inst cst + +end type abstract_universe_context = AUContext.t let hcons_abstract_universe_context = AUContext.hcons @@ -1256,39 +1292,6 @@ let subst_univs_constraints subst csts = (fun c cstrs -> subst_univs_constraint subst c cstrs) csts Constraint.empty -let subst_instance_level s l = - match l.Level.data with - | Level.Var n -> s.(n) - | _ -> l - -let subst_instance_instance s i = - Array.smartmap (fun l -> subst_instance_level s l) i - -let subst_instance_universe s u = - let f x = Universe.Expr.map (fun u -> subst_instance_level s u) x in - let u' = Universe.smartmap f u in - if u == u' then u - else Universe.sort u' - -let subst_instance_constraint s (u,d,v as c) = - let u' = subst_instance_level s u in - let v' = subst_instance_level s v in - if u' == u && v' == v then c - else (u',d,v') - -let subst_instance_constraints s csts = - Constraint.fold - (fun c csts -> Constraint.add (subst_instance_constraint s c) csts) - csts Constraint.empty - -(** Substitute instance inst for ctx in csts *) -let instantiate_univ_context (ctx, csts) = - (ctx, subst_instance_constraints ctx csts) - -(** Substitute instance inst for ctx in universe constraints and subtyping constraints *) -let instantiate_cumulativity_info (univcst, subtpcst) = - (instantiate_univ_context univcst, instantiate_univ_context subtpcst) - let make_instance_subst i = let arr = Instance.to_array i in Array.fold_left_i (fun i acc l -> @@ -1378,19 +1381,3 @@ let explain_universe_inconsistency prl (o,u,v,p) = let compare_levels = Level.compare let eq_levels = Level.equal let equal_universes = Universe.equal - - -let subst_instance_constraints = - if Flags.profile then - let key = Profile.declare_profile "subst_instance_constraints" in - Profile.profile2 key subst_instance_constraints - else subst_instance_constraints - -let subst_instance_context = - let subst_instance_context_body inst (inner_inst, inner_constr) = - (inner_inst, subst_instance_constraints inst inner_constr) - in - if Flags.profile then - let key = Profile.declare_profile "subst_instance_constraints" in - Profile.profile2 key subst_instance_context_body - else subst_instance_context_body diff --git a/kernel/univ.mli b/kernel/univ.mli index d7ee3ecee..99092a543 100644 --- a/kernel/univ.mli +++ b/kernel/univ.mli @@ -319,15 +319,24 @@ module AUContext : sig type t + val repr : t -> UContext.t + (** [repr ctx] is [(Var(0), ... Var(n-1) |= cstr] where [n] is the length of + the context and [cstr] the abstracted constraints. *) + val empty : t + val is_empty : t -> bool + (** Don't use. *) val instance : t -> Instance.t - + val size : t -> int (** Keeps the order of the instances *) val union : t -> t -> t + val instantiate : Instance.t -> t -> Constraint.t + (** Generate the set of instantiated constraints **) + end type abstract_universe_context = AUContext.t @@ -442,7 +451,6 @@ val subst_univs_constraints : universe_subst_fn -> constraints -> constraints (** Substitution of instances *) val subst_instance_instance : universe_instance -> universe_instance -> universe_instance val subst_instance_universe : universe_instance -> universe -> universe -val subst_instance_context : universe_instance -> abstract_universe_context -> universe_context val make_instance_subst : universe_instance -> universe_level_subst val make_inverse_instance_subst : universe_instance -> universe_level_subst @@ -453,12 +461,6 @@ val abstract_cumulativity_info : cumulativity_info -> universe_level_subst * abs val make_abstract_instance : abstract_universe_context -> universe_instance -(** Get the instantiated graph. *) -val instantiate_univ_context : abstract_universe_context -> universe_context - -(** Get the instantiated graphs for both universe constraints and subtyping constraints. *) -val instantiate_cumulativity_info : abstract_cumulativity_info -> cumulativity_info - (** {6 Pretty-printing of universes. } *) val pr_constraint_type : constraint_type -> Pp.std_ppcmds diff --git a/lib/control.ml b/lib/control.ml index d9b91be3a..f5d7df204 100644 --- a/lib/control.ml +++ b/lib/control.ml @@ -48,7 +48,7 @@ let windows_timeout n f e = let exited = ref false in let thread init = while not !killed do - let cur = Unix.time () in + let cur = Unix.gettimeofday () in if float_of_int n <= cur -. init then begin interrupt := true; exited := true; @@ -57,12 +57,12 @@ let windows_timeout n f e = Thread.delay 0.5 done in - let init = Unix.time () in + let init = Unix.gettimeofday () in let _id = Thread.create thread init in try let res = f () in let () = killed := true in - let cur = Unix.time () in + let cur = Unix.gettimeofday () in (** The thread did not interrupt, but the computation took longer than expected. *) let () = if float_of_int n <= cur -. init then begin diff --git a/lib/coqProject_file.ml4 b/lib/coqProject_file.ml4 index bb3cbabbd..13de731f5 100644 --- a/lib/coqProject_file.ml4 +++ b/lib/coqProject_file.ml4 @@ -73,9 +73,6 @@ let rec post_canonize f = if dir = Filename.current_dir_name then f else post_canonize dir else f -(* Avoid Sys.is_directory raise an exception (if the file does not exists) *) -let is_directory f = Sys.file_exists f && Sys.is_directory f - (********************* parser *******************************************) exception Parsing_error of string @@ -106,6 +103,15 @@ let parse f = res ;; +(* Copy from minisys.ml, since we don't see that file here *) +let exists_dir dir = + let rec strip_trailing_slash dir = + let len = String.length dir in + if len > 0 && (dir.[len-1] = '/' || dir.[len-1] = '\\') + then strip_trailing_slash (String.sub dir 0 (len-1)) else dir in + try Sys.is_directory (strip_trailing_slash dir) with Sys_error _ -> false + + let process_cmd_line orig_dir proj args = let orig_dir = (* avoids turning foo.v in ./foo.v *) if orig_dir = "." then "" else orig_dir in @@ -173,7 +179,7 @@ let process_cmd_line orig_dir proj args = | f :: r -> let f = CUnix.correct_path f orig_dir in let proj = - if is_directory f then { proj with subdirs = proj.subdirs @ [f] } + if exists_dir f then { proj with subdirs = proj.subdirs @ [f] } else match CUnix.get_extension f with | ".v" -> { proj with v_files = proj.v_files @ [f] } | ".ml" -> { proj with ml_files = proj.ml_files @ [f] } diff --git a/lib/hashset.ml b/lib/hashset.ml index 23ac2fed0..7f96627a6 100644 --- a/lib/hashset.ml +++ b/lib/hashset.ml @@ -181,7 +181,7 @@ module Make (E : EqType) = let sz = Weak.length bucket in let rec loop i = if i >= sz then ifnotfound index - else if h = hashes.(i) then begin + else if Int.equal h hashes.(i) then begin match Weak.get bucket i with | Some v when E.eq v d -> v | _ -> loop (i + 1) diff --git a/lib/minisys.ml b/lib/minisys.ml index b4382a3fe..1ed017e48 100644 --- a/lib/minisys.ml +++ b/lib/minisys.ml @@ -44,7 +44,11 @@ let ok_dirname f = (* Check directory can be opened *) let exists_dir dir = - try Sys.is_directory dir with Sys_error _ -> false + let rec strip_trailing_slash dir = + let len = String.length dir in + if len > 0 && (dir.[len-1] = '/' || dir.[len-1] = '\\') + then strip_trailing_slash (String.sub dir 0 (len-1)) else dir in + try Sys.is_directory (strip_trailing_slash dir) with Sys_error _ -> false let apply_subdir f path name = (* we avoid all files and subdirs starting by '.' (e.g. .svn) *) @@ -153,7 +153,7 @@ let rec pr_com ft s = | None -> () (* pretty printing functions *) -let pp_with ft = +let pp_with ft pp = let cpp_open_box = function | Pp_hbox n -> Format.pp_open_hbox ft () | Pp_vbox n -> Format.pp_open_vbox ft n @@ -175,7 +175,7 @@ let pp_with ft = pp_cmd s; pp_close_tag ft () in - try pp_cmd + try pp_cmd pp with reraise -> let reraise = Backtrace.add_backtrace reraise in let () = Format.pp_print_flush ft () in @@ -220,23 +220,25 @@ let prlist pr l = Ppcmd_glue (List.map pr l) if a strict behavior is needed, use [prlist_strict] instead. evaluation is done from left to right. *) -let prlist_sep_lastsep no_empty sep lastsep elem = - let rec start = function - |[] -> mt () - |[e] -> elem e - |h::t -> let e = elem h in - if no_empty && ismt e then start t else - let rec aux = function - |[] -> mt () - |h::t -> - let e = elem h and r = aux t in - if no_empty && ismt e then r else - if ismt r - then let s = lastsep () in s ++ e - else let s = sep () in s ++ e ++ r - in let r = aux t in e ++ r - in start - +let prlist_sep_lastsep no_empty sep_thunk lastsep_thunk elem l = + let sep = sep_thunk () in + let lastsep = lastsep_thunk () in + let elems = List.map elem l in + let filtered_elems = + if no_empty then + List.filter (fun e -> not (ismt e)) elems + else + elems + in + let rec insert_seps es = + match es with + | [] -> mt () + | [e] -> e + | h::[e] -> h ++ lastsep ++ e + | h::t -> h ++ sep ++ insert_seps t + in + insert_seps filtered_elems + let prlist_strict pr l = prlist_sep_lastsep true mt mt pr l (* [prlist_with_sep sep pr [a ; ... ; c]] outputs [pr a ++ sep() ++ ... ++ sep() ++ pr c] *) diff --git a/lib/pp.mli b/lib/pp.mli index be255a74f..96656c8b6 100644 --- a/lib/pp.mli +++ b/lib/pp.mli @@ -145,7 +145,10 @@ val prlist_strict : ('a -> std_ppcmds) -> 'a list -> std_ppcmds val prlist_with_sep : (unit -> std_ppcmds) -> ('a -> std_ppcmds) -> 'a list -> std_ppcmds (** [prlist_with_sep sep pr [a ; ... ; c]] outputs - [pr a ++ sep() ++ ... ++ sep() ++ pr c]. *) + [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 (** As [prlist], but on arrays. *) diff --git a/lib/terminal.ml b/lib/terminal.ml index 3b6e34f0b..34efddfbc 100644 --- a/lib/terminal.ml +++ b/lib/terminal.ml @@ -35,6 +35,8 @@ type style = { italic : bool option; underline : bool option; negative : bool option; + prefix : string option; + suffix : string option; } let set o1 o2 = match o1 with @@ -51,9 +53,11 @@ let default = { italic = None; underline = None; negative = None; + prefix = None; + suffix = None; } -let make ?fg_color ?bg_color ?bold ?italic ?underline ?negative ?style () = +let make ?fg_color ?bg_color ?bold ?italic ?underline ?negative ?style ?prefix ?suffix () = let st = match style with | None -> default | Some st -> st @@ -65,6 +69,8 @@ let make ?fg_color ?bg_color ?bold ?italic ?underline ?negative ?style () = italic = set st.italic italic; underline = set st.underline underline; negative = set st.negative negative; + prefix = set st.prefix prefix; + suffix = set st.suffix suffix; } let merge s1 s2 = @@ -75,6 +81,8 @@ let merge s1 s2 = italic = set s1.italic s2.italic; underline = set s1.underline s2.underline; negative = set s1.negative s2.negative; + prefix = set s1.prefix s2.prefix; + suffix = set s1.suffix s2.suffix; } let base_color = function @@ -168,6 +176,8 @@ let reset_style = { italic = Some false; underline = Some false; negative = Some false; + prefix = None; + suffix = None; } let has_style t = diff --git a/lib/terminal.mli b/lib/terminal.mli index dbc418dd6..b1b76e6e2 100644 --- a/lib/terminal.mli +++ b/lib/terminal.mli @@ -35,11 +35,14 @@ type style = { italic : bool option; underline : bool option; negative : bool option; + prefix : string option; + suffix : string option; } val make : ?fg_color:color -> ?bg_color:color -> ?bold:bool -> ?italic:bool -> ?underline:bool -> - ?negative:bool -> ?style:style -> unit -> style + ?negative:bool -> ?style:style -> + ?prefix:string -> ?suffix:string -> unit -> style (** Create a style from the given flags. It is derived from the optional [style] argument if given. *) diff --git a/library/global.ml b/library/global.ml index dd7f23378..5b17855dc 100644 --- a/library/global.ml +++ b/library/global.ml @@ -122,12 +122,22 @@ let lookup_modtype kn = lookup_modtype kn (env()) let exists_objlabel id = Safe_typing.exists_objlabel id (safe_env ()) let opaque_tables () = Environ.opaque_tables (env ()) -let body_of_constant_body cb = Declareops.body_of_constant (opaque_tables ()) cb + +let instantiate cb c = + let open Declarations in + match cb.const_universes with + | Monomorphic_const _ -> c, Univ.AUContext.empty + | Polymorphic_const ctx -> c, ctx + +let body_of_constant_body cb = + let open Declarations in + let otab = opaque_tables () in + match cb.const_body with + | Undef _ -> None + | Def c -> Some (instantiate cb (Mod_subst.force_constr c)) + | OpaqueDef o -> Some (instantiate cb (Opaqueproof.force_proof otab o)) + let body_of_constant cst = body_of_constant_body (lookup_constant cst) -let constraints_of_constant_body cb = - Declareops.constraints_of_constant (opaque_tables ()) cb -let universes_of_constant_body cb = - Declareops.universes_of_constant (opaque_tables ()) cb (** Operations on kernel names *) @@ -163,54 +173,53 @@ open Globnames (** Build a fresh instance for a given context, its associated substitution and the instantiated constraints. *) -let type_of_global_unsafe r = - let env = env() in +let constr_of_global_in_context env r = + let open Constr in match r with - | VarRef id -> Environ.named_type id env - | ConstRef c -> - let cb = Environ.lookup_constant c env in - let univs = - Declareops.universes_of_polymorphic_constant - (Environ.opaque_tables env) cb in - let ty = Typeops.type_of_constant_type env cb.Declarations.const_type in - Vars.subst_instance_constr (Univ.UContext.instance univs) ty + | VarRef id -> mkVar id, Univ.AUContext.empty + | ConstRef c -> + let cb = Environ.lookup_constant c env in + let univs = Declareops.constant_polymorphic_context cb in + mkConstU (c, Univ.make_abstract_instance univs), univs | IndRef ind -> - let (mib, oib as specif) = Inductive.lookup_mind_specif env ind in - let inst = Declareops.inductive_polymorphic_instance mib in - Inductive.type_of_inductive env (specif, inst) + let (mib, oib as specif) = Inductive.lookup_mind_specif env ind in + let univs = Declareops.inductive_polymorphic_context mib in + mkIndU (ind, Univ.make_abstract_instance univs), univs | ConstructRef cstr -> - let (mib,oib as specif) = Inductive.lookup_mind_specif env (inductive_of_constructor cstr) in - let inst = Declareops.inductive_polymorphic_instance mib in - Inductive.type_of_constructor (cstr,inst) specif + let (mib,oib as specif) = + Inductive.lookup_mind_specif env (inductive_of_constructor cstr) + in + let univs = Declareops.inductive_polymorphic_context mib in + mkConstructU (cstr, Univ.make_abstract_instance univs), univs let type_of_global_in_context env r = match r with - | VarRef id -> Environ.named_type id env, Univ.UContext.empty + | VarRef id -> Environ.named_type id env, Univ.AUContext.empty | ConstRef c -> - let cb = Environ.lookup_constant c env in - let univs = - Declareops.universes_of_polymorphic_constant - (Environ.opaque_tables env) cb in - Typeops.type_of_constant_type env cb.Declarations.const_type, univs + 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 | IndRef ind -> - let (mib, oib as specif) = Inductive.lookup_mind_specif env ind in - let univs = Declareops.inductive_polymorphic_context mib in - Inductive.type_of_inductive env (specif, Univ.UContext.instance univs), univs + let (mib, oib as specif) = Inductive.lookup_mind_specif env ind in + let univs = Declareops.inductive_polymorphic_context mib in + let inst = Univ.make_abstract_instance univs in + let env = Environ.push_context ~strict:false (Univ.AUContext.repr univs) env in + Inductive.type_of_inductive env (specif, inst), univs | ConstructRef cstr -> let (mib,oib as specif) = Inductive.lookup_mind_specif env (inductive_of_constructor cstr) in let univs = Declareops.inductive_polymorphic_context mib in - let inst = Univ.UContext.instance univs in + let inst = Univ.make_abstract_instance univs in Inductive.type_of_constructor (cstr,inst) specif, univs let universes_of_global env r = match r with - | VarRef id -> Univ.UContext.empty + | VarRef id -> Univ.AUContext.empty | ConstRef c -> let cb = Environ.lookup_constant c env in - Declareops.universes_of_polymorphic_constant - (Environ.opaque_tables env) cb + Declareops.constant_polymorphic_context cb | IndRef ind -> let (mib, oib) = Inductive.lookup_mind_specif env ind in Declareops.inductive_polymorphic_context mib diff --git a/library/global.mli b/library/global.mli index c7ccabe1a..48bcfa989 100644 --- a/library/global.mli +++ b/library/global.mli @@ -89,12 +89,15 @@ val constant_of_delta_kn : kernel_name -> constant val mind_of_delta_kn : kernel_name -> mutual_inductive val opaque_tables : unit -> Opaqueproof.opaquetab -val body_of_constant : constant -> Term.constr option -val body_of_constant_body : Declarations.constant_body -> Term.constr option -val constraints_of_constant_body : - Declarations.constant_body -> Univ.constraints -val universes_of_constant_body : - Declarations.constant_body -> Univ.universe_context + +val body_of_constant : constant -> (Term.constr * Univ.AUContext.t) option +(** Returns the body of the constant if it has any, and the polymorphic context + it lives in. For monomorphic constant, the latter is empty, and for + polymorphic constants, the term contains De Bruijn universe variables that + need to be instantiated. *) + +val body_of_constant_body : Declarations.constant_body -> (Term.constr * Univ.AUContext.t) option +(** Same as {!body_of_constant} but on {!Declarations.constant_body}. *) (** Global universe name <-> level mapping *) type universe_names = @@ -126,26 +129,22 @@ val is_polymorphic : Globnames.global_reference -> bool val is_template_polymorphic : Globnames.global_reference -> bool val is_type_in_type : Globnames.global_reference -> bool -val type_of_global_in_context : Environ.env -> - Globnames.global_reference -> Constr.types Univ.in_universe_context -(** Returns the type of the constant in its global or local universe +val constr_of_global_in_context : Environ.env -> + Globnames.global_reference -> Constr.types * Univ.AUContext.t +(** Returns the type of the constant in its local universe context. The type should not be used without pushing it's universe context in the environmnent of usage. For non-universe-polymorphic constants, it does not matter. *) -val type_of_global_unsafe : Globnames.global_reference -> Constr.types -(** Returns the type of the constant, forgetting its universe context if - it is polymorphic, use with care: for polymorphic constants, the - type cannot be used to produce a term used by the kernel. For safe - handling of polymorphic global references, one should look at a - particular instantiation of the reference, in some particular - universe context (part of an [env] or [evar_map]), see - e.g. [type_of_constant_in]. If you want to create a fresh instance - of the reference and get its type look at [Evd.fresh_global] or - [Evarutil.new_global] and [Retyping.get_type_of]. *) +val type_of_global_in_context : Environ.env -> + Globnames.global_reference -> Constr.types * Univ.AUContext.t +(** Returns the type of the constant in its local universe + context. The type should not be used without pushing it's universe + context in the environmnent of usage. For non-universe-polymorphic + constants, it does not matter. *) (** Returns the universe context of the global reference (whatever its polymorphic status is). *) -val universes_of_global : Globnames.global_reference -> Univ.universe_context +val universes_of_global : Globnames.global_reference -> Univ.abstract_universe_context (** {6 Retroknowledge } *) diff --git a/library/heads.ml b/library/heads.ml index 0f420c0e6..c12fa9479 100644 --- a/library/heads.ml +++ b/library/heads.ml @@ -128,11 +128,11 @@ let compute_head = function let is_Def = function Declarations.Def _ -> true | _ -> false in let body = if cb.Declarations.const_proj = None && is_Def cb.Declarations.const_body - then Declareops.body_of_constant (Environ.opaque_tables env) cb else None + then Global.body_of_constant cst else None in (match body with | None -> RigidHead (RigidParameter cst) - | Some c -> kind_of_head env c) + | Some (c, _) -> kind_of_head env c) | EvalVarRef id -> (match Global.lookup_named id with | LocalDef (_,c,_) when not (Decls.variable_opacity id) -> diff --git a/library/lib.ml b/library/lib.ml index 009eb88fc..a24d20c68 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -465,9 +465,10 @@ let add_section_replacement f g poly hyps = let () = check_same_poly poly vars in let sechyps,ctx = extract_hyps (vars,hyps) in let ctx = Univ.ContextSet.to_context ctx in + let inst = Univ.UContext.instance ctx in let subst, ctx = Univ.abstract_universes ctx in let args = instance_from_variable_context (List.rev sechyps) in - sectab := (vars,f (Univ.AUContext.instance ctx,args) exps, + sectab := (vars,f (inst,args) exps, g (sechyps,subst,ctx) abs)::sl let add_section_kn poly kn = @@ -644,3 +645,16 @@ let discharge_con cst = let discharge_inductive (kn,i) = (discharge_kn kn,i) + +let discharge_abstract_universe_context (_, subst, abs_ctx) auctx = + let open Univ in + let len = LMap.cardinal subst in + let rec gen_subst i acc = + if i < 0 then acc + else + let acc = LMap.add (Level.var i) (Level.var (i + len)) acc in + gen_subst (pred i) acc + in + let subst = gen_subst (AUContext.size auctx - 1) subst in + let auctx = Univ.subst_univs_level_abstract_universe_context subst auctx in + subst, AUContext.union abs_ctx auctx diff --git a/library/lib.mli b/library/lib.mli index 38a29f76e..f1c9bfca2 100644 --- a/library/lib.mli +++ b/library/lib.mli @@ -183,3 +183,5 @@ val discharge_kn : Names.mutual_inductive -> Names.mutual_inductive val discharge_con : Names.constant -> Names.constant val discharge_global : Globnames.global_reference -> Globnames.global_reference val discharge_inductive : Names.inductive -> Names.inductive +val discharge_abstract_universe_context : + abstr_info -> Univ.AUContext.t -> Univ.universe_level_subst * Univ.AUContext.t diff --git a/library/libobject.mli b/library/libobject.mli index 1a21ece2b..6f935bffe 100644 --- a/library/libobject.mli +++ b/library/libobject.mli @@ -56,6 +56,9 @@ open Mod_subst rebuild the non volatile content of a section from the data collected by the discharge function + Any type defined as a persistent object must be pure (e.g. no references) and + marshallable by the OCaml Marshal module (e.g. no closures). + *) type 'a substitutivity = diff --git a/library/summary.mli b/library/summary.mli index a6ad49950..d093d95f2 100644 --- a/library/summary.mli +++ b/library/summary.mli @@ -14,6 +14,8 @@ type marshallable = | `No (* Full data will be store in memory, e.g. for Undo *) | `Shallow ] (* Only part of the data will be marshalled to a slave process *) +(** Types of global Coq states. The ['a] type should be pure and marshallable by + the standard OCaml marshalling function. *) type 'a summary_declaration = { (** freeze_function [true] is for marshalling to disk. * e.g. lazy must be forced *) diff --git a/library/univops.ml b/library/univops.ml index 669be2d45..3bafb824d 100644 --- a/library/univops.ml +++ b/library/univops.ml @@ -8,7 +8,6 @@ open Term open Univ -open Declarations let universes_of_constr c = let rec aux s c = @@ -21,44 +20,6 @@ let universes_of_constr c = | _ -> fold_constr aux s c in aux LSet.empty c -let universes_of_inductive mind = - let process auctx = - let u = Univ.AUContext.instance auctx in - let univ_of_one_ind oind = - let arity_univs = - Context.Rel.fold_outside - (fun decl unvs -> - Univ.LSet.union - (Context.Rel.Declaration.fold_constr - (fun cnstr unvs -> - let cnstr = Vars.subst_instance_constr u cnstr in - Univ.LSet.union - (universes_of_constr cnstr) unvs) - decl Univ.LSet.empty) unvs) - oind.mind_arity_ctxt ~init:Univ.LSet.empty - in - Array.fold_left (fun unvs cns -> - let cns = Vars.subst_instance_constr u cns in - Univ.LSet.union (universes_of_constr cns) unvs) arity_univs - oind.mind_nf_lc - in - let univs = - Array.fold_left - (fun unvs pk -> - Univ.LSet.union - (univ_of_one_ind pk) unvs - ) - Univ.LSet.empty mind.mind_packets - in - let mindcnt = Univ.UContext.constraints (Univ.instantiate_univ_context auctx) in - let univs = Univ.LSet.union univs (Univ.universes_of_constraints mindcnt) in - univs - in - match mind.mind_universes with - | Monomorphic_ind _ -> LSet.empty - | Polymorphic_ind auctx -> process auctx - | Cumulative_ind cumi -> process (Univ.ACumulativityInfo.univ_context cumi) - let restrict_universe_context (univs,csts) s = (* Universes that are not necessary to typecheck the term. E.g. univs introduced by tactics and not used in the proof term. *) diff --git a/library/univops.mli b/library/univops.mli index b5f7715b1..09147cb41 100644 --- a/library/univops.mli +++ b/library/univops.mli @@ -8,10 +8,8 @@ open Term open Univ -open Declarations (** Shrink a universe context to a restricted set of variables *) val universes_of_constr : constr -> universe_set -val universes_of_inductive : mutual_inductive_body -> universe_set val restrict_universe_context : universe_context_set -> universe_set -> universe_context_set diff --git a/plugins/.merlin b/plugins/.merlin new file mode 100644 index 000000000..dd6678ba0 --- /dev/null +++ b/plugins/.merlin @@ -0,0 +1,2 @@ +REC +FLG -open API diff --git a/plugins/btauto/refl_btauto.ml b/plugins/btauto/refl_btauto.ml index 00e80d041..6281b2675 100644 --- a/plugins/btauto/refl_btauto.ml +++ b/plugins/btauto/refl_btauto.ml @@ -1,5 +1,3 @@ -open API - let contrib_name = "btauto" let init_constant dir s = diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml index 3e4febf47..182821322 100644 --- a/plugins/cc/ccalgo.ml +++ b/plugins/cc/ccalgo.ml @@ -10,7 +10,6 @@ (* Downey,Sethi and Tarjan. *) (* Plus some e-matching and constructor handling by P. Corbineau *) -open API open CErrors open Util open Pp diff --git a/plugins/cc/ccalgo.mli b/plugins/cc/ccalgo.mli index 1441e13fb..e6abf1ccf 100644 --- a/plugins/cc/ccalgo.mli +++ b/plugins/cc/ccalgo.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open Util open Term open Names diff --git a/plugins/cc/ccproof.ml b/plugins/cc/ccproof.ml index 4c9ebcfc4..a43a167e8 100644 --- a/plugins/cc/ccproof.ml +++ b/plugins/cc/ccproof.ml @@ -9,7 +9,6 @@ (* This file uses the (non-compressed) union-find structure to generate *) (* proof-trees that will be transformed into proof-terms in cctac.ml4 *) -open API open CErrors open Term open Ccalgo diff --git a/plugins/cc/ccproof.mli b/plugins/cc/ccproof.mli index 0488a5db7..9f53123db 100644 --- a/plugins/cc/ccproof.mli +++ b/plugins/cc/ccproof.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open Ccalgo open Term diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 4c5d85a5f..4934b0750 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -8,7 +8,6 @@ (* This file is the interface between the c-c algorithm and Coq *) -open API open Evd open Names open Inductiveops diff --git a/plugins/cc/cctac.mli b/plugins/cc/cctac.mli index ef32d2b83..b4bb62be8 100644 --- a/plugins/cc/cctac.mli +++ b/plugins/cc/cctac.mli @@ -7,7 +7,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open EConstr val proof_tac: Ccproof.proof -> unit Proofview.tactic diff --git a/plugins/cc/g_congruence.ml4 b/plugins/cc/g_congruence.ml4 index add3f90b1..6ed4672ce 100644 --- a/plugins/cc/g_congruence.ml4 +++ b/plugins/cc/g_congruence.ml4 @@ -8,7 +8,6 @@ (*i camlp4deps: "grammar/grammar.cma" i*) -open API open Ltac_plugin open Cctac open Stdarg diff --git a/plugins/derive/derive.ml b/plugins/derive/derive.ml index 19d23c0e4..1524079f4 100644 --- a/plugins/derive/derive.ml +++ b/plugins/derive/derive.ml @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open Context.Named.Declaration let map_const_entry_body (f:Term.constr->Term.constr) (x:Safe_typing.private_constants Entries.const_entry_body) diff --git a/plugins/derive/derive.mli b/plugins/derive/derive.mli index 7ea64a528..690a7c508 100644 --- a/plugins/derive/derive.mli +++ b/plugins/derive/derive.mli @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API - (** [start_deriving f suchthat lemma] starts a proof of [suchthat] (which can contain references to [f]) in the context extended by [f:=?x]. When the proof ends, [f] is defined as the value of [?x] diff --git a/plugins/derive/g_derive.ml4 b/plugins/derive/g_derive.ml4 index ce9129bcf..df701ed80 100644 --- a/plugins/derive/g_derive.ml4 +++ b/plugins/derive/g_derive.ml4 @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open Stdarg (*i camlp4deps: "grammar/grammar.cma" i*) diff --git a/plugins/extraction/common.ml b/plugins/extraction/common.ml index 19ba31fbb..9772ebd64 100644 --- a/plugins/extraction/common.ml +++ b/plugins/extraction/common.ml @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open Pp open Util open Names diff --git a/plugins/extraction/common.mli b/plugins/extraction/common.mli index 28a7c4d45..d6342b59c 100644 --- a/plugins/extraction/common.mli +++ b/plugins/extraction/common.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open Names open Globnames open Miniml diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index 45f8d32a3..f5aa5e6c3 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open Miniml open Term open Declarations diff --git a/plugins/extraction/extract_env.mli b/plugins/extraction/extract_env.mli index 276c4099d..e10dcd48b 100644 --- a/plugins/extraction/extract_env.mli +++ b/plugins/extraction/extract_env.mli @@ -8,7 +8,6 @@ (*s This module declares the extraction commands. *) -open API open Names open Libnames open Globnames diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index d638c232b..3661faada 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -7,7 +7,6 @@ (************************************************************************) (*i*) -open API open Util open Names open Term diff --git a/plugins/extraction/extraction.mli b/plugins/extraction/extraction.mli index 5ee34103c..e1d43f340 100644 --- a/plugins/extraction/extraction.mli +++ b/plugins/extraction/extraction.mli @@ -8,7 +8,6 @@ (*s Extraction from Coq terms to Miniml. *) -open API open Names open Term open Declarations diff --git a/plugins/extraction/g_extraction.ml4 b/plugins/extraction/g_extraction.ml4 index f4b110253..dba1e3444 100644 --- a/plugins/extraction/g_extraction.ml4 +++ b/plugins/extraction/g_extraction.ml4 @@ -8,7 +8,6 @@ (*i camlp4deps: "grammar/grammar.cma" i*) -open API open Grammar_API.Pcoq.Prim DECLARE PLUGIN "extraction_plugin" diff --git a/plugins/extraction/haskell.ml b/plugins/extraction/haskell.ml index 6146f32bb..0f537abec 100644 --- a/plugins/extraction/haskell.ml +++ b/plugins/extraction/haskell.ml @@ -8,7 +8,6 @@ (*s Production of Haskell syntax. *) -open API open Pp open CErrors open Util diff --git a/plugins/extraction/json.ml b/plugins/extraction/json.ml index 1bf19f186..e43c47d05 100644 --- a/plugins/extraction/json.ml +++ b/plugins/extraction/json.ml @@ -1,4 +1,3 @@ -open API open Pp open Util open Names diff --git a/plugins/extraction/miniml.mli b/plugins/extraction/miniml.mli index ea966baee..be8282da0 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 API open Pp open Names open Globnames diff --git a/plugins/extraction/mlutil.ml b/plugins/extraction/mlutil.ml index f8c846725..f1bcde2f3 100644 --- a/plugins/extraction/mlutil.ml +++ b/plugins/extraction/mlutil.ml @@ -7,7 +7,6 @@ (************************************************************************) (*i*) -open API open Util open Names open Libnames diff --git a/plugins/extraction/mlutil.mli b/plugins/extraction/mlutil.mli index 1db96413a..42d22a7b4 100644 --- a/plugins/extraction/mlutil.mli +++ b/plugins/extraction/mlutil.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open Names open Globnames open Miniml diff --git a/plugins/extraction/modutil.ml b/plugins/extraction/modutil.ml index 365dc191a..a896a8d03 100644 --- a/plugins/extraction/modutil.ml +++ b/plugins/extraction/modutil.ml @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open Names open ModPath open Globnames diff --git a/plugins/extraction/modutil.mli b/plugins/extraction/modutil.mli index 1d9db3a5f..ad60b58d5 100644 --- a/plugins/extraction/modutil.mli +++ b/plugins/extraction/modutil.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open Names open Globnames open Miniml diff --git a/plugins/extraction/ocaml.ml b/plugins/extraction/ocaml.ml index 2ac411d06..9cbc3fd71 100644 --- a/plugins/extraction/ocaml.ml +++ b/plugins/extraction/ocaml.ml @@ -8,7 +8,6 @@ (*s Production of Ocaml syntax. *) -open API open Pp open CErrors open Util diff --git a/plugins/extraction/scheme.ml b/plugins/extraction/scheme.ml index bb96489ab..1ccc27370 100644 --- a/plugins/extraction/scheme.ml +++ b/plugins/extraction/scheme.ml @@ -8,7 +8,6 @@ (*s Production of Scheme syntax. *) -open API open Pp open CErrors open Util diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml index 2642aeefa..ca98f07e8 100644 --- a/plugins/extraction/table.ml +++ b/plugins/extraction/table.ml @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open Names open ModPath open Term @@ -445,9 +444,10 @@ let error_MPfile_as_mod mp b = "Please "^s2^"use (Recursive) Extraction Library instead.\n")) let argnames_of_global r = - let typ = Global.type_of_global_unsafe r in + let env = Global.env () in + let typ, _ = Global.type_of_global_in_context env r in let rels,_ = - decompose_prod (Reduction.whd_all (Global.env ()) typ) in + decompose_prod (Reduction.whd_all env typ) in List.rev_map fst rels let msg_of_implicit = function @@ -878,7 +878,7 @@ let extract_constant_inline inline r ids s = match g with | ConstRef kn -> let env = Global.env () in - let typ = Global.type_of_global_unsafe (ConstRef kn) in + let typ, _ = Global.type_of_global_in_context env (ConstRef kn) in let typ = Reduction.whd_all env typ in if Reduction.is_arity env typ then begin diff --git a/plugins/extraction/table.mli b/plugins/extraction/table.mli index 0215aa8e4..2b3007f02 100644 --- a/plugins/extraction/table.mli +++ b/plugins/extraction/table.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open Names open Libnames open Globnames diff --git a/plugins/firstorder/formula.ml b/plugins/firstorder/formula.ml index 4319fa71c..db1a46a03 100644 --- a/plugins/firstorder/formula.ml +++ b/plugins/firstorder/formula.ml @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open Hipattern open Names open Term diff --git a/plugins/firstorder/formula.mli b/plugins/firstorder/formula.mli index 535d75735..106c469c6 100644 --- a/plugins/firstorder/formula.mli +++ b/plugins/firstorder/formula.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open Term open EConstr open Globnames diff --git a/plugins/firstorder/g_ground.ml4 b/plugins/firstorder/g_ground.ml4 index 81d714aa2..c001ee382 100644 --- a/plugins/firstorder/g_ground.ml4 +++ b/plugins/firstorder/g_ground.ml4 @@ -8,7 +8,6 @@ (*i camlp4deps: "grammar/grammar.cma" i*) -open API open Grammar_API open Ltac_plugin open Formula diff --git a/plugins/firstorder/ground.ml b/plugins/firstorder/ground.ml index bd420546f..f660ba734 100644 --- a/plugins/firstorder/ground.ml +++ b/plugins/firstorder/ground.ml @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open Ltac_plugin open Formula open Sequent diff --git a/plugins/firstorder/ground.mli b/plugins/firstorder/ground.mli index e15af1f23..d763fe635 100644 --- a/plugins/firstorder/ground.mli +++ b/plugins/firstorder/ground.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API val ground_tac: unit Proofview.tactic -> ((Sequent.t -> unit Proofview.tactic) -> unit Proofview.tactic) -> unit Proofview.tactic diff --git a/plugins/firstorder/instances.ml b/plugins/firstorder/instances.ml index 4c8b96be1..169073630 100644 --- a/plugins/firstorder/instances.ml +++ b/plugins/firstorder/instances.ml @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open Unify open Rules open CErrors diff --git a/plugins/firstorder/instances.mli b/plugins/firstorder/instances.mli index c2eb1d68c..ec2a056e3 100644 --- a/plugins/firstorder/instances.mli +++ b/plugins/firstorder/instances.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open Globnames open Rules diff --git a/plugins/firstorder/rules.ml b/plugins/firstorder/rules.ml index b0fcd98cc..d6309b057 100644 --- a/plugins/firstorder/rules.ml +++ b/plugins/firstorder/rules.ml @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open CErrors open Util open Names diff --git a/plugins/firstorder/rules.mli b/plugins/firstorder/rules.mli index 05f60eccc..d8d4c1a38 100644 --- a/plugins/firstorder/rules.mli +++ b/plugins/firstorder/rules.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open Term open EConstr open Names diff --git a/plugins/firstorder/sequent.ml b/plugins/firstorder/sequent.ml index 6fddaafa3..5ba98fb58 100644 --- a/plugins/firstorder/sequent.ml +++ b/plugins/firstorder/sequent.ml @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open EConstr open CErrors open Util diff --git a/plugins/firstorder/sequent.mli b/plugins/firstorder/sequent.mli index 2488ffded..0a2e84bb8 100644 --- a/plugins/firstorder/sequent.mli +++ b/plugins/firstorder/sequent.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open EConstr open Formula open Globnames diff --git a/plugins/firstorder/unify.ml b/plugins/firstorder/unify.ml index 2da3dc768..a1409edd0 100644 --- a/plugins/firstorder/unify.ml +++ b/plugins/firstorder/unify.ml @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open Util open Term open EConstr diff --git a/plugins/firstorder/unify.mli b/plugins/firstorder/unify.mli index cf2ef8ba6..d3e8aeee8 100644 --- a/plugins/firstorder/unify.mli +++ b/plugins/firstorder/unify.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open Term open EConstr diff --git a/plugins/fourier/fourierR.ml b/plugins/fourier/fourierR.ml index a6299c3c4..68af1b3b6 100644 --- a/plugins/fourier/fourierR.ml +++ b/plugins/fourier/fourierR.ml @@ -12,7 +12,6 @@ des inéquations et équations sont entiers. En attendant la tactique Field. *) -open API open Term open Tactics open Names diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index ba46f78aa..15ab396e3 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -1,4 +1,3 @@ -open API open Printer open CErrors open Util @@ -957,7 +956,7 @@ let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num (* observe (str "rec_args_num := " ++ str (string_of_int (rec_args_num + 1) )); *) let f_def = Global.lookup_constant (fst (destConst evd f)) in let eq_lhs = mkApp(f,Array.init (nb_params + nb_args) (fun i -> mkRel(nb_params + nb_args - i))) in - let f_body = Option.get (Global.body_of_constant_body f_def) in + let (f_body, _) = Option.get (Global.body_of_constant_body f_def) in let f_body = EConstr.of_constr f_body in let params,f_body_with_params = decompose_lam_n evd nb_params f_body in let (_,num),(_,_,bodies) = destFix evd f_body_with_params in @@ -1091,7 +1090,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam in let get_body const = match Global.body_of_constant const with - | Some body -> + | Some (body, _) -> Tacred.cbv_norm_flags (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) (Global.env ()) @@ -1382,7 +1381,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam (* Proof of principles of general functions *) -(* let hrec_id = +(* let hrec_id = Recdef.hrec_id *) (* and acc_inv_id = Recdef.acc_inv_id *) (* and ltof_ref = Recdef.ltof_ref *) (* and acc_rel = Recdef.acc_rel *) diff --git a/plugins/funind/functional_principles_proofs.mli b/plugins/funind/functional_principles_proofs.mli index d03fc475e..64fbfaeed 100644 --- a/plugins/funind/functional_principles_proofs.mli +++ b/plugins/funind/functional_principles_proofs.mli @@ -1,4 +1,3 @@ -open API open Names val prove_princ_for_struct : diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index 8ffd15f9f..513fce248 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -1,4 +1,3 @@ -open API open Printer open CErrors open Util @@ -407,7 +406,7 @@ let get_funs_constant mp dp = function const -> let find_constant_body const = match Global.body_of_constant const with - | Some body -> + | Some (body, _) -> let body = Tacred.cbv_norm_flags (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) (Global.env ()) @@ -651,7 +650,7 @@ let build_case_scheme fa = (* in *) let funs = let (_,f,_) = fa in - try fst (Universes.unsafe_constr_of_global (Smartlocate.global_with_alias f)) + try fst (Global.constr_of_global_in_context (Global.env ()) (Smartlocate.global_with_alias f)) with Not_found -> user_err ~hdr:"FunInd.build_case_scheme" (str "Cannot find " ++ Libnames.pr_reference f) in diff --git a/plugins/funind/functional_principles_types.mli b/plugins/funind/functional_principles_types.mli index d6ad7ef0d..5a7ffe059 100644 --- a/plugins/funind/functional_principles_types.mli +++ b/plugins/funind/functional_principles_types.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open Names open Term open Misctypes diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4 index 56048f92e..c495703ee 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 API open Grammar_API open Ltac_plugin open Util diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index db2af2be5..379c83b24 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -1,4 +1,3 @@ -open API open Printer open Pp open Names diff --git a/plugins/funind/glob_term_to_relation.mli b/plugins/funind/glob_term_to_relation.mli index 7ad7de079..0cab5a6d3 100644 --- a/plugins/funind/glob_term_to_relation.mli +++ b/plugins/funind/glob_term_to_relation.mli @@ -1,4 +1,3 @@ -open API open Names (* diff --git a/plugins/funind/glob_termops.ml b/plugins/funind/glob_termops.ml index 726a8203d..7cb35838c 100644 --- a/plugins/funind/glob_termops.ml +++ b/plugins/funind/glob_termops.ml @@ -1,4 +1,3 @@ -open API open Pp open Glob_term open CErrors diff --git a/plugins/funind/glob_termops.mli b/plugins/funind/glob_termops.mli index b6d2c4543..99a258de9 100644 --- a/plugins/funind/glob_termops.mli +++ b/plugins/funind/glob_termops.mli @@ -1,4 +1,3 @@ -open API open Names open Glob_term open Misctypes diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 2c5dae1cd..863c9dc8d 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -1,4 +1,3 @@ -open API open CErrors open Util open Names @@ -851,7 +850,7 @@ let make_graph (f_ref:global_reference) = in (match Global.body_of_constant_body c_body with | None -> error "Cannot build a graph over an axiom!" - | Some body -> + | Some (body, _) -> let env = Global.env () in let sigma = Evd.from_env env in let extern_body,extern_type = diff --git a/plugins/funind/indfun.mli b/plugins/funind/indfun.mli index fc7da6a33..7a60da44f 100644 --- a/plugins/funind/indfun.mli +++ b/plugins/funind/indfun.mli @@ -1,4 +1,3 @@ -open API open Misctypes val warn_cannot_define_graph : ?loc:Loc.t -> Pp.std_ppcmds * Pp.std_ppcmds -> unit diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index 6fe6888f3..f4f9ba2bb 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -1,4 +1,3 @@ -open API open Names open Pp open Libnames @@ -342,7 +341,7 @@ let pr_info f_info = str "function_constant_type := " ++ (try Printer.pr_lconstr - (Global.type_of_global_unsafe (ConstRef f_info.function_constant)) + (fst (Global.type_of_global_in_context (Global.env ()) (ConstRef f_info.function_constant))) with e when CErrors.noncritical e -> mt ()) ++ fnl () ++ str "equation_lemma := " ++ pr_ocst f_info.equation_lemma ++ fnl () ++ str "completeness_lemma :=" ++ pr_ocst f_info.completeness_lemma ++ fnl () ++ diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli index f7a9cedd7..5e425cd18 100644 --- a/plugins/funind/indfun_common.mli +++ b/plugins/funind/indfun_common.mli @@ -1,4 +1,3 @@ -open API open Names open Pp diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index e6f10a880..8dea6c90f 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open Ltac_plugin open Declarations open CErrors diff --git a/plugins/funind/merge.ml b/plugins/funind/merge.ml index 63662a443..52a82b0e5 100644 --- a/plugins/funind/merge.ml +++ b/plugins/funind/merge.ml @@ -8,7 +8,6 @@ (* Merging of induction principles. *) -open API open Globnames open Tactics open Indfun_common diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 1705cac78..d3eccb58d 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API module CVars = Vars @@ -90,7 +89,7 @@ let type_of_const sigma t = |_ -> assert false let constr_of_global x = - fst (Universes.unsafe_constr_of_global x) + fst (Global.constr_of_global_in_context (Global.env ()) x) let constant sl s = constr_of_global (find_reference sl s) diff --git a/plugins/funind/recdef.mli b/plugins/funind/recdef.mli index f3d5e7332..63bbdbe7e 100644 --- a/plugins/funind/recdef.mli +++ b/plugins/funind/recdef.mli @@ -1,4 +1,3 @@ -open API (* val evaluable_of_global_reference : Libnames.global_reference -> Names.evaluable_global_reference *) val tclUSER_if_not_mes : diff --git a/plugins/ltac/coretactics.ml4 b/plugins/ltac/coretactics.ml4 index 47fd324f9..2769802cf 100644 --- a/plugins/ltac/coretactics.ml4 +++ b/plugins/ltac/coretactics.ml4 @@ -8,7 +8,6 @@ (*i camlp4deps: "grammar/grammar.cma" i*) -open API open Util open Locus open Misctypes diff --git a/plugins/ltac/evar_tactics.ml b/plugins/ltac/evar_tactics.ml index 4342f5b5e..4cab6ef33 100644 --- a/plugins/ltac/evar_tactics.ml +++ b/plugins/ltac/evar_tactics.ml @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open Util open Names open Term diff --git a/plugins/ltac/evar_tactics.mli b/plugins/ltac/evar_tactics.mli index 0658008c0..122aecd75 100644 --- a/plugins/ltac/evar_tactics.mli +++ b/plugins/ltac/evar_tactics.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open Names open Tacexpr open Locus diff --git a/plugins/ltac/extraargs.ml4 b/plugins/ltac/extraargs.ml4 index af1d349db..72c6f9090 100644 --- a/plugins/ltac/extraargs.ml4 +++ b/plugins/ltac/extraargs.ml4 @@ -8,7 +8,6 @@ (*i camlp4deps: "grammar/grammar.cma" i*) -open API open Grammar_API open Pp open Genarg diff --git a/plugins/ltac/extraargs.mli b/plugins/ltac/extraargs.mli index e5a2d003a..419c5e8c4 100644 --- a/plugins/ltac/extraargs.mli +++ b/plugins/ltac/extraargs.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open Grammar_API open Tacexpr open Names diff --git a/plugins/ltac/extratactics.ml4 b/plugins/ltac/extratactics.ml4 index e56b510be..6d80ab549 100644 --- a/plugins/ltac/extratactics.ml4 +++ b/plugins/ltac/extratactics.ml4 @@ -8,7 +8,6 @@ (*i camlp4deps: "grammar/grammar.cma" i*) -open API open Grammar_API open Pp open Genarg diff --git a/plugins/ltac/extratactics.mli b/plugins/ltac/extratactics.mli index fe90f633f..c423585e5 100644 --- a/plugins/ltac/extratactics.mli +++ b/plugins/ltac/extratactics.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API val discrHyp : Names.Id.t -> unit Proofview.tactic val injHyp : Names.Id.t -> unit Proofview.tactic diff --git a/plugins/ltac/g_auto.ml4 b/plugins/ltac/g_auto.ml4 index 6145e373b..4d13d89a4 100644 --- a/plugins/ltac/g_auto.ml4 +++ b/plugins/ltac/g_auto.ml4 @@ -8,7 +8,6 @@ (*i camlp4deps: "grammar/grammar.cma" i*) -open API open Grammar_API open Pp open Genarg diff --git a/plugins/ltac/g_class.ml4 b/plugins/ltac/g_class.ml4 index 946b99f6c..dd24aa3db 100644 --- a/plugins/ltac/g_class.ml4 +++ b/plugins/ltac/g_class.ml4 @@ -8,7 +8,6 @@ (*i camlp4deps: "grammar/grammar.cma" i*) -open API open Class_tactics open Stdarg open Tacarg diff --git a/plugins/ltac/g_eqdecide.ml4 b/plugins/ltac/g_eqdecide.ml4 index a7c05664f..549436902 100644 --- a/plugins/ltac/g_eqdecide.ml4 +++ b/plugins/ltac/g_eqdecide.ml4 @@ -14,7 +14,6 @@ (*i camlp4deps: "grammar/grammar.cma" i*) -open API open Eqdecide DECLARE PLUGIN "ltac_plugin" diff --git a/plugins/ltac/g_ltac.ml4 b/plugins/ltac/g_ltac.ml4 index cf6bd98b3..cc052c8a2 100644 --- a/plugins/ltac/g_ltac.ml4 +++ b/plugins/ltac/g_ltac.ml4 @@ -8,7 +8,6 @@ (*i camlp4deps: "grammar/grammar.cma" i*) -open API open Grammar_API DECLARE PLUGIN "ltac_plugin" @@ -433,7 +432,7 @@ let is_explicit_terminator = function TacSolve _ -> true | _ -> false VERNAC tactic_mode EXTEND VernacSolve | [ - ltac_selector_opt(g) ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => [ classify_as_proofstep ] -> [ - let g = Option.default (Proof_global.get_default_goal_selector ()) g in + let g = Option.default (Proof_bullet.get_default_goal_selector ()) g in vernac_solve g n t def ] | [ - "par" ":" ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => diff --git a/plugins/ltac/g_obligations.ml4 b/plugins/ltac/g_obligations.ml4 index a2e8fc270..1935d560a 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 API open Grammar_API open Libnames open Constrexpr diff --git a/plugins/ltac/g_rewrite.ml4 b/plugins/ltac/g_rewrite.ml4 index 8956e21b9..3c27b2747 100644 --- a/plugins/ltac/g_rewrite.ml4 +++ b/plugins/ltac/g_rewrite.ml4 @@ -10,7 +10,6 @@ (* Syntax for rewriting with strategies *) -open API open Grammar_API open Names open Misctypes diff --git a/plugins/ltac/g_tactic.ml4 b/plugins/ltac/g_tactic.ml4 index 49af905d8..e539b5867 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 API open Grammar_API open Pp open CErrors diff --git a/plugins/ltac/pltac.ml b/plugins/ltac/pltac.ml index 898c1d1c3..2adcf02e6 100644 --- a/plugins/ltac/pltac.ml +++ b/plugins/ltac/pltac.ml @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open Grammar_API open Pcoq diff --git a/plugins/ltac/pltac.mli b/plugins/ltac/pltac.mli index 782d13a38..794cb527f 100644 --- a/plugins/ltac/pltac.mli +++ b/plugins/ltac/pltac.mli @@ -8,7 +8,6 @@ (** Ltac parsing entries *) -open API open Grammar_API open Loc open Names diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index 8d8e82c7c..327b347ec 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open Pp open Names open Namegen diff --git a/plugins/ltac/pptactic.mli b/plugins/ltac/pptactic.mli index c15225ebf..1127c9831 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 API open Pp open Genarg open Geninterp diff --git a/plugins/ltac/profile_ltac.ml b/plugins/ltac/profile_ltac.ml index e25f1926d..32494a879 100644 --- a/plugins/ltac/profile_ltac.ml +++ b/plugins/ltac/profile_ltac.ml @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open Unicode open Pp open Printer diff --git a/plugins/ltac/profile_ltac.mli b/plugins/ltac/profile_ltac.mli index eb4146cfc..52827cb36 100644 --- a/plugins/ltac/profile_ltac.mli +++ b/plugins/ltac/profile_ltac.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API (** Ltac profiling primitives *) diff --git a/plugins/ltac/profile_ltac_tactics.ml4 b/plugins/ltac/profile_ltac_tactics.ml4 index 9f171cee6..2b1106ee2 100644 --- a/plugins/ltac/profile_ltac_tactics.ml4 +++ b/plugins/ltac/profile_ltac_tactics.ml4 @@ -10,7 +10,6 @@ (** Ltac profiling entrypoints *) -open API open Profile_ltac open Stdarg diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 3a77f34a1..bbd7834d5 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open Names open Pp open CErrors diff --git a/plugins/ltac/rewrite.mli b/plugins/ltac/rewrite.mli index 73e309cc2..35205ac58 100644 --- a/plugins/ltac/rewrite.mli +++ b/plugins/ltac/rewrite.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open Names open Environ open EConstr diff --git a/plugins/ltac/tacarg.ml b/plugins/ltac/tacarg.ml index 610a722fb..1bf9ea4c1 100644 --- a/plugins/ltac/tacarg.ml +++ b/plugins/ltac/tacarg.ml @@ -8,7 +8,6 @@ (** Generic arguments based on Ltac. *) -open API open Genarg open Geninterp open Tacexpr diff --git a/plugins/ltac/tacarg.mli b/plugins/ltac/tacarg.mli index 4c3687ec7..6c4f3dd87 100644 --- a/plugins/ltac/tacarg.mli +++ b/plugins/ltac/tacarg.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open Genarg open Tacexpr open Constrexpr diff --git a/plugins/ltac/taccoerce.ml b/plugins/ltac/taccoerce.ml index bdfa6d989..9e3a54cc8 100644 --- a/plugins/ltac/taccoerce.ml +++ b/plugins/ltac/taccoerce.ml @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open Util open Names open Term diff --git a/plugins/ltac/taccoerce.mli b/plugins/ltac/taccoerce.mli index ab46455c8..1a67f6f88 100644 --- a/plugins/ltac/taccoerce.mli +++ b/plugins/ltac/taccoerce.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open Util open Names open EConstr diff --git a/plugins/ltac/tacentries.ml b/plugins/ltac/tacentries.ml index c6b4feba1..791b7f48d 100644 --- a/plugins/ltac/tacentries.ml +++ b/plugins/ltac/tacentries.ml @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open Grammar_API open Pp open CErrors diff --git a/plugins/ltac/tacentries.mli b/plugins/ltac/tacentries.mli index 9980e0961..ccd44b914 100644 --- a/plugins/ltac/tacentries.mli +++ b/plugins/ltac/tacentries.mli @@ -8,7 +8,6 @@ (** Ltac toplevel command entries. *) -open API open Grammar_API open Vernacexpr open Tacexpr diff --git a/plugins/ltac/tacenv.ml b/plugins/ltac/tacenv.ml index 58d1766ff..13b44f0e2 100644 --- a/plugins/ltac/tacenv.ml +++ b/plugins/ltac/tacenv.ml @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open Util open Pp open Names diff --git a/plugins/ltac/tacenv.mli b/plugins/ltac/tacenv.mli index 23e12bfc0..958109e5a 100644 --- a/plugins/ltac/tacenv.mli +++ b/plugins/ltac/tacenv.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open Names open Tacexpr open Geninterp diff --git a/plugins/ltac/tacexpr.mli b/plugins/ltac/tacexpr.mli index 471320684..64da097de 100644 --- a/plugins/ltac/tacexpr.mli +++ b/plugins/ltac/tacexpr.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open Loc open Names open Constrexpr diff --git a/plugins/ltac/tacintern.ml b/plugins/ltac/tacintern.ml index c3e39ec11..df03c7b47 100644 --- a/plugins/ltac/tacintern.ml +++ b/plugins/ltac/tacintern.ml @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open Grammar_API open Pattern open Pp diff --git a/plugins/ltac/tacintern.mli b/plugins/ltac/tacintern.mli index 4749017e1..ad2e70908 100644 --- a/plugins/ltac/tacintern.mli +++ b/plugins/ltac/tacintern.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open Grammar_API open Pp open Names diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index bad3e774d..7b054947b 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open Grammar_API open Constrintern open Patternops diff --git a/plugins/ltac/tacinterp.mli b/plugins/ltac/tacinterp.mli index ab94e21f0..73e4f3d6a 100644 --- a/plugins/ltac/tacinterp.mli +++ b/plugins/ltac/tacinterp.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open Names open Tactic_debug open EConstr diff --git a/plugins/ltac/tacsubst.ml b/plugins/ltac/tacsubst.ml index 750843c9d..c1ca85433 100644 --- a/plugins/ltac/tacsubst.ml +++ b/plugins/ltac/tacsubst.ml @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open Grammar_API open Util open Tacexpr diff --git a/plugins/ltac/tacsubst.mli b/plugins/ltac/tacsubst.mli index c401e67f1..5ac377567 100644 --- a/plugins/ltac/tacsubst.mli +++ b/plugins/ltac/tacsubst.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open Tacexpr open Mod_subst open Genarg diff --git a/plugins/ltac/tactic_debug.ml b/plugins/ltac/tactic_debug.ml index 9113b620f..5394b1e11 100644 --- a/plugins/ltac/tactic_debug.ml +++ b/plugins/ltac/tactic_debug.ml @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open Util open Names open Pp diff --git a/plugins/ltac/tactic_debug.mli b/plugins/ltac/tactic_debug.mli index 469c6bdbc..ef6362270 100644 --- a/plugins/ltac/tactic_debug.mli +++ b/plugins/ltac/tactic_debug.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open Environ open Pattern open Names diff --git a/plugins/ltac/tactic_matching.ml b/plugins/ltac/tactic_matching.ml index 3e9668072..63b8cc482 100644 --- a/plugins/ltac/tactic_matching.ml +++ b/plugins/ltac/tactic_matching.ml @@ -9,7 +9,6 @@ (** This file extends Matching with the main logic for Ltac's (lazy)match and (lazy)match goal. *) -open API open Names open Tacexpr open Context.Named.Declaration diff --git a/plugins/ltac/tactic_matching.mli b/plugins/ltac/tactic_matching.mli index 304eec463..01334d36c 100644 --- a/plugins/ltac/tactic_matching.mli +++ b/plugins/ltac/tactic_matching.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API (** This file extends Matching with the main logic for Ltac's (lazy)match and (lazy)match goal. *) diff --git a/plugins/ltac/tactic_option.ml b/plugins/ltac/tactic_option.ml index 5b95e9c77..fdeab8dc4 100644 --- a/plugins/ltac/tactic_option.ml +++ b/plugins/ltac/tactic_option.ml @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open Libobject open Pp diff --git a/plugins/ltac/tactic_option.mli b/plugins/ltac/tactic_option.mli index dc3bbf7d6..dd91944d4 100644 --- a/plugins/ltac/tactic_option.mli +++ b/plugins/ltac/tactic_option.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open Tacexpr open Vernacexpr diff --git a/plugins/ltac/tauto.ml b/plugins/ltac/tauto.ml index e809d87dc..01d3f79c7 100644 --- a/plugins/ltac/tauto.ml +++ b/plugins/ltac/tauto.ml @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open Term open EConstr open Hipattern diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index a662f8bad..a4103634e 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -16,7 +16,6 @@ (* *) (************************************************************************) -open API open Pp open Mutils open Goptions diff --git a/plugins/micromega/g_micromega.ml4 b/plugins/micromega/g_micromega.ml4 index 37a21cd59..b15dd7ae6 100644 --- a/plugins/micromega/g_micromega.ml4 +++ b/plugins/micromega/g_micromega.ml4 @@ -16,7 +16,6 @@ (*i camlp4deps: "grammar/grammar.cma" i*) -open API open Ltac_plugin open Stdarg open Tacarg diff --git a/plugins/nsatz/g_nsatz.ml4 b/plugins/nsatz/g_nsatz.ml4 index 261f3dab4..01c3d7940 100644 --- a/plugins/nsatz/g_nsatz.ml4 +++ b/plugins/nsatz/g_nsatz.ml4 @@ -8,7 +8,6 @@ (*i camlp4deps: "grammar/grammar.cma" i*) -open API open Ltac_plugin DECLARE PLUGIN "nsatz_plugin" diff --git a/plugins/nsatz/nsatz.ml b/plugins/nsatz/nsatz.ml index 7e63b916d..72934a15d 100644 --- a/plugins/nsatz/nsatz.ml +++ b/plugins/nsatz/nsatz.ml @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open CErrors open Util open Term diff --git a/plugins/nsatz/nsatz.mli b/plugins/nsatz/nsatz.mli index b692522f2..d6e3071aa 100644 --- a/plugins/nsatz/nsatz.mli +++ b/plugins/nsatz/nsatz.mli @@ -6,5 +6,4 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API val nsatz_compute : Term.constr -> unit Proofview.tactic diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index 3badb92f5..d07b2e0b4 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -13,7 +13,6 @@ (* *) (**************************************************************************) -open API open CErrors open Util open Names diff --git a/plugins/omega/g_omega.ml4 b/plugins/omega/g_omega.ml4 index 8d24027d8..735af6bab 100644 --- a/plugins/omega/g_omega.ml4 +++ b/plugins/omega/g_omega.ml4 @@ -15,7 +15,6 @@ (*i camlp4deps: "grammar/grammar.cma" i*) -open API DECLARE PLUGIN "omega_plugin" diff --git a/plugins/quote/g_quote.ml4 b/plugins/quote/g_quote.ml4 index 88076dca9..f7ebd3204 100644 --- a/plugins/quote/g_quote.ml4 +++ b/plugins/quote/g_quote.ml4 @@ -8,7 +8,6 @@ (*i camlp4deps: "grammar/grammar.cma" i*) -open API open Ltac_plugin open Names open Misctypes diff --git a/plugins/quote/quote.ml b/plugins/quote/quote.ml index 8ee5ce8b1..e1e73b1c3 100644 --- a/plugins/quote/quote.ml +++ b/plugins/quote/quote.ml @@ -101,7 +101,6 @@ (*i*) -open API open CErrors open Util open Names diff --git a/plugins/romega/const_omega.ml b/plugins/romega/const_omega.ml index 06c80a825..4ffbd5aa8 100644 --- a/plugins/romega/const_omega.ml +++ b/plugins/romega/const_omega.ml @@ -6,7 +6,6 @@ *************************************************************************) -open API open Names let module_refl_name = "ReflOmegaCore" diff --git a/plugins/romega/const_omega.mli b/plugins/romega/const_omega.mli index 6dc5d9f7e..a452b1a91 100644 --- a/plugins/romega/const_omega.mli +++ b/plugins/romega/const_omega.mli @@ -6,7 +6,6 @@ *************************************************************************) -open API (** Coq objects used in romega *) diff --git a/plugins/romega/g_romega.ml4 b/plugins/romega/g_romega.ml4 index 53f6f42c8..5fd9c9419 100644 --- a/plugins/romega/g_romega.ml4 +++ b/plugins/romega/g_romega.ml4 @@ -8,7 +8,6 @@ (*i camlp4deps: "grammar/grammar.cma" i*) -open API DECLARE PLUGIN "romega_plugin" diff --git a/plugins/romega/refl_omega.ml b/plugins/romega/refl_omega.ml index 60e6e7de7..517df41d9 100644 --- a/plugins/romega/refl_omega.ml +++ b/plugins/romega/refl_omega.ml @@ -6,7 +6,6 @@ *************************************************************************) -open API open Pp open Util open Const_omega diff --git a/plugins/rtauto/g_rtauto.ml4 b/plugins/rtauto/g_rtauto.ml4 index 69a2043f6..bfa1e5f39 100644 --- a/plugins/rtauto/g_rtauto.ml4 +++ b/plugins/rtauto/g_rtauto.ml4 @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API (*i camlp4deps: "grammar/grammar.cma" i*) diff --git a/plugins/rtauto/proof_search.ml b/plugins/rtauto/proof_search.ml index 1158817d6..43a4107ad 100644 --- a/plugins/rtauto/proof_search.ml +++ b/plugins/rtauto/proof_search.ml @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open CErrors open Util open Goptions diff --git a/plugins/rtauto/refl_tauto.ml b/plugins/rtauto/refl_tauto.ml index 944e0ac5e..9f02388c3 100644 --- a/plugins/rtauto/refl_tauto.ml +++ b/plugins/rtauto/refl_tauto.ml @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API module Search = Explore.Make(Proof_search) diff --git a/plugins/rtauto/refl_tauto.mli b/plugins/rtauto/refl_tauto.mli index 080dcdac2..bec18f6df 100644 --- a/plugins/rtauto/refl_tauto.mli +++ b/plugins/rtauto/refl_tauto.mli @@ -7,7 +7,6 @@ (************************************************************************) (* raises Not_found if no proof is found *) -open API type atom_env= {mutable next:int; diff --git a/plugins/setoid_ring/g_newring.ml4 b/plugins/setoid_ring/g_newring.ml4 index ada41274f..6c82346bc 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 API open Grammar_API open Ltac_plugin open Pp diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index 955cc767c..0f996c65a 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open Ltac_plugin open Pp open Util diff --git a/plugins/setoid_ring/newring.mli b/plugins/setoid_ring/newring.mli index 7f685063c..d9d32c681 100644 --- a/plugins/setoid_ring/newring.mli +++ b/plugins/setoid_ring/newring.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open Names open EConstr open Libnames diff --git a/plugins/setoid_ring/newring_ast.mli b/plugins/setoid_ring/newring_ast.mli index b7afd2eff..d37582bd7 100644 --- a/plugins/setoid_ring/newring_ast.mli +++ b/plugins/setoid_ring/newring_ast.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open Term open Libnames open Constrexpr diff --git a/plugins/ssr/ssrast.mli b/plugins/ssr/ssrast.mli index 94eaa1d6a..cdd4ee645 100644 --- a/plugins/ssr/ssrast.mli +++ b/plugins/ssr/ssrast.mli @@ -8,7 +8,6 @@ (* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) -open API open Names open Ltac_plugin diff --git a/plugins/ssr/ssrbwd.ml b/plugins/ssr/ssrbwd.ml index 3988f00ba..cc0e86684 100644 --- a/plugins/ssr/ssrbwd.ml +++ b/plugins/ssr/ssrbwd.ml @@ -8,7 +8,6 @@ (* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) -open API open Printer open Pretyping open Globnames diff --git a/plugins/ssr/ssrbwd.mli b/plugins/ssr/ssrbwd.mli index 20a1263d2..af9f7491a 100644 --- a/plugins/ssr/ssrbwd.mli +++ b/plugins/ssr/ssrbwd.mli @@ -8,7 +8,6 @@ (* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) -open API val apply_top_tac : Goal.goal Evd.sigma -> Goal.goal list Evd.sigma diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index 411ce6853..608b778e4 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 API open Grammar_API open Util open Names diff --git a/plugins/ssr/ssrcommon.mli b/plugins/ssr/ssrcommon.mli index f61168576..4b045e989 100644 --- a/plugins/ssr/ssrcommon.mli +++ b/plugins/ssr/ssrcommon.mli @@ -8,7 +8,6 @@ (* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) -open API open Tacmach open Names open Environ diff --git a/plugins/ssr/ssrelim.ml b/plugins/ssr/ssrelim.ml index bd9a05891..832044909 100644 --- a/plugins/ssr/ssrelim.ml +++ b/plugins/ssr/ssrelim.ml @@ -8,7 +8,6 @@ (* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) -open API open Util open Names open Printer diff --git a/plugins/ssr/ssrelim.mli b/plugins/ssr/ssrelim.mli index 825b4758e..66e202b48 100644 --- a/plugins/ssr/ssrelim.mli +++ b/plugins/ssr/ssrelim.mli @@ -8,7 +8,6 @@ (* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) -open API open Ssrmatching_plugin val ssrelim : diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml index b0fe89897..ab6a60f4e 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -8,7 +8,6 @@ (* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) -open API open Ltac_plugin open Util open Names diff --git a/plugins/ssr/ssrequality.mli b/plugins/ssr/ssrequality.mli index f9ab5d74f..a3366887f 100644 --- a/plugins/ssr/ssrequality.mli +++ b/plugins/ssr/ssrequality.mli @@ -8,7 +8,6 @@ (* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) -open API open Ssrmatching_plugin open Ssrast diff --git a/plugins/ssr/ssrfwd.ml b/plugins/ssr/ssrfwd.ml index 660c2e776..8e6329a15 100644 --- a/plugins/ssr/ssrfwd.ml +++ b/plugins/ssr/ssrfwd.ml @@ -8,7 +8,6 @@ (* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) -open API open Names open Tacmach diff --git a/plugins/ssr/ssrfwd.mli b/plugins/ssr/ssrfwd.mli index 7f254074c..e5b5b58ff 100644 --- a/plugins/ssr/ssrfwd.mli +++ b/plugins/ssr/ssrfwd.mli @@ -8,7 +8,6 @@ (* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) -open API open Names open Ltac_plugin diff --git a/plugins/ssr/ssripats.ml b/plugins/ssr/ssripats.ml index 06bbd749e..023778fdb 100644 --- a/plugins/ssr/ssripats.ml +++ b/plugins/ssr/ssripats.ml @@ -8,7 +8,6 @@ (* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) -open API open Names open Pp open Term diff --git a/plugins/ssr/ssripats.mli b/plugins/ssr/ssripats.mli index aefdc8e11..6c36e67e8 100644 --- a/plugins/ssr/ssripats.mli +++ b/plugins/ssr/ssripats.mli @@ -8,7 +8,6 @@ (* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) -open API open Ssrmatching_plugin open Ssrast open Ssrcommon diff --git a/plugins/ssr/ssrparser.ml4 b/plugins/ssr/ssrparser.ml4 index 09917339a..228444b82 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 API open Grammar_API open Names open Pp diff --git a/plugins/ssr/ssrparser.mli b/plugins/ssr/ssrparser.mli index 154820666..c93e10405 100644 --- a/plugins/ssr/ssrparser.mli +++ b/plugins/ssr/ssrparser.mli @@ -8,7 +8,6 @@ (* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) -open API open Grammar_API val ssrtacarg : Tacexpr.raw_tactic_expr Pcoq.Gram.entry diff --git a/plugins/ssr/ssrprinters.ml b/plugins/ssr/ssrprinters.ml index 427109c1b..e865ef706 100644 --- a/plugins/ssr/ssrprinters.ml +++ b/plugins/ssr/ssrprinters.ml @@ -8,7 +8,6 @@ (* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) -open API open Pp open Names open Printer diff --git a/plugins/ssr/ssrprinters.mli b/plugins/ssr/ssrprinters.mli index 8da9bc72b..5c68872b7 100644 --- a/plugins/ssr/ssrprinters.mli +++ b/plugins/ssr/ssrprinters.mli @@ -8,7 +8,6 @@ (* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) -open API open Ssrast val pp_term : diff --git a/plugins/ssr/ssrtacticals.ml b/plugins/ssr/ssrtacticals.ml index b586d05e1..5e43c8374 100644 --- a/plugins/ssr/ssrtacticals.ml +++ b/plugins/ssr/ssrtacticals.ml @@ -8,7 +8,6 @@ (* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) -open API open Names open Termops open Tacmach diff --git a/plugins/ssr/ssrtacticals.mli b/plugins/ssr/ssrtacticals.mli index 297cfdfdc..c1f65a31e 100644 --- a/plugins/ssr/ssrtacticals.mli +++ b/plugins/ssr/ssrtacticals.mli @@ -8,7 +8,6 @@ (* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) -open API val tclSEQAT : Ltac_plugin.Tacinterp.interp_sign -> diff --git a/plugins/ssr/ssrvernac.ml4 b/plugins/ssr/ssrvernac.ml4 index 4c8827bf8..fbe3cd2b9 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 API open Grammar_API open Names open Term @@ -337,7 +336,8 @@ let coerce_search_pattern_to_sort hpat = Pattern.PApp (fp, args') in let hr, na = splay_search_pattern 0 hpat in let dc, ht = - Reductionops.splay_prod env sigma (EConstr.of_constr (Universes.unsafe_type_of_global hr)) in + let hr, _ = Global.type_of_global_in_context (Global.env ()) hr (** FIXME *) in + Reductionops.splay_prod env sigma (EConstr.of_constr hr) in let np = List.length dc in if np < na then CErrors.user_err (Pp.str "too many arguments in head search pattern") else let hpat' = if np = na then hpat else mkPApp hpat (np - na) [||] in diff --git a/plugins/ssr/ssrview.ml b/plugins/ssr/ssrview.ml index cc142e091..338ecccc2 100644 --- a/plugins/ssr/ssrview.ml +++ b/plugins/ssr/ssrview.ml @@ -8,7 +8,6 @@ (* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) -open API open Util open Names open Term diff --git a/plugins/ssr/ssrview.mli b/plugins/ssr/ssrview.mli index 8a7bd5d6e..6fd906ff4 100644 --- a/plugins/ssr/ssrview.mli +++ b/plugins/ssr/ssrview.mli @@ -8,7 +8,6 @@ (* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) -open API open Ssrast open Ssrcommon diff --git a/plugins/ssrmatching/ssrmatching.ml4 b/plugins/ssrmatching/ssrmatching.ml4 index 7674a8dde..74519f6c5 100644 --- a/plugins/ssrmatching/ssrmatching.ml4 +++ b/plugins/ssrmatching/ssrmatching.ml4 @@ -8,7 +8,6 @@ (* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) -open API open Grammar_API (* Defining grammar rules with "xx" in it automatically declares keywords too, diff --git a/plugins/ssrmatching/ssrmatching.mli b/plugins/ssrmatching/ssrmatching.mli index 1853bc35d..0c09d7bfb 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 API open Grammar_API open Goal open Genarg diff --git a/plugins/syntax/ascii_syntax.ml b/plugins/syntax/ascii_syntax.ml index 6bf5b8cfc..c41ec39cb 100644 --- a/plugins/syntax/ascii_syntax.ml +++ b/plugins/syntax/ascii_syntax.ml @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -open API (* Poor's man DECLARE PLUGIN *) let __coq_plugin_name = "ascii_syntax_plugin" diff --git a/plugins/syntax/int31_syntax.ml b/plugins/syntax/int31_syntax.ml index fe1eef866..af64b1479 100644 --- a/plugins/syntax/int31_syntax.ml +++ b/plugins/syntax/int31_syntax.ml @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API (* Poor's man DECLARE PLUGIN *) let __coq_plugin_name = "int31_syntax_plugin" diff --git a/plugins/syntax/nat_syntax.ml b/plugins/syntax/nat_syntax.ml index c6ee899ed..524a5c522 100644 --- a/plugins/syntax/nat_syntax.ml +++ b/plugins/syntax/nat_syntax.ml @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API (* Poor's man DECLARE PLUGIN *) let __coq_plugin_name = "nat_syntax_plugin" diff --git a/plugins/syntax/r_syntax.ml b/plugins/syntax/r_syntax.ml index 9cfa50071..06117de79 100644 --- a/plugins/syntax/r_syntax.ml +++ b/plugins/syntax/r_syntax.ml @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open Util open Names open Globnames diff --git a/plugins/syntax/string_syntax.ml b/plugins/syntax/string_syntax.ml index a4335a508..b7f13b040 100644 --- a/plugins/syntax/string_syntax.ml +++ b/plugins/syntax/string_syntax.ml @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -open API open Globnames open Ascii_syntax_plugin.Ascii_syntax open Glob_term diff --git a/plugins/syntax/z_syntax.ml b/plugins/syntax/z_syntax.ml index 719d8b1cc..af3df2889 100644 --- a/plugins/syntax/z_syntax.ml +++ b/plugins/syntax/z_syntax.ml @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open API open Pp open CErrors open Util diff --git a/pretyping/classops.ml b/pretyping/classops.ml index 948aa26ca..078990a8c 100644 --- a/pretyping/classops.ml +++ b/pretyping/classops.ml @@ -403,7 +403,7 @@ type coercion = { (* Computation of the class arity *) let reference_arity_length ref = - let t = Universes.unsafe_type_of_global ref in + let t, _ = Global.type_of_global_in_context (Global.env ()) ref in List.length (fst (Reductionops.splay_arity (Global.env()) Evd.empty (EConstr.of_constr t))) (** FIXME *) let projection_arity_length p = diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index b5d195873..cb76df4e8 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -205,7 +205,8 @@ let check_conv_record env sigma (t1,sk1) (t2,sk2) = else match (Stack.strip_n_app (l_us-1) sk2_effective) with | None -> raise Not_found | Some (l',el,s') -> (l'@Stack.append_app [|el|] Stack.empty,s') in - let subst, ctx' = Universes.fresh_universe_context_set_instance ctx in + let u, ctx' = Universes.fresh_instance_from ctx None in + let subst = Univ.make_inverse_instance_subst u in let c = EConstr.of_constr c in let c' = subst_univs_level_constr subst c in let t' = EConstr.of_constr t' in @@ -353,9 +354,8 @@ let exact_ise_stack2 env evd f sk1 sk2 = let check_leq_inductives evd cumi u u' = let u = EConstr.EInstance.kind evd u in let u' = EConstr.EInstance.kind evd u' in - let length_ind_instance = - Univ.Instance.length - (Univ.AUContext.instance (Univ.ACumulativityInfo.univ_context cumi)) + let length_ind_instance = + Univ.AUContext.size (Univ.ACumulativityInfo.univ_context cumi) in let ind_sbcst = Univ.ACumulativityInfo.subtyp_context cumi in if not ((length_ind_instance = Univ.Instance.length u) && @@ -364,9 +364,7 @@ let check_leq_inductives evd cumi u u' = else begin let comp_subst = (Univ.Instance.append u u') in - let comp_cst = - Univ.UContext.constraints (Univ.subst_instance_context comp_subst ind_sbcst) - in + let comp_cst = Univ.AUContext.instantiate comp_subst ind_sbcst in Evd.add_constraints evd comp_cst end diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index e166e0e9d..bfc6bf5cf 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -511,8 +511,8 @@ let pretype_global ?loc rigid env evd gr us = match us with | None -> evd, None | Some l -> - let _, ctx = Universes.unsafe_constr_of_global gr in - let len = Univ.UContext.size ctx in + let _, ctx = Global.constr_of_global_in_context env.ExtraEnv.env gr in + let len = Univ.AUContext.size ctx in interp_instance ?loc evd ~len l in let (sigma, c) = Evd.fresh_global ?loc ~rigid ?names:instance env.ExtraEnv.env evd gr in diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index 1cb694da6..a23579609 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -134,7 +134,7 @@ let find_projection = function type obj_typ = { o_DEF : constr; - o_CTX : Univ.ContextSet.t; + o_CTX : Univ.AUContext.t; o_INJ : int option; (* position of trivial argument if any *) o_TABS : constr list; (* ordered *) o_TPARAMS : constr list; (* ordered *) @@ -189,22 +189,26 @@ let cs_pattern_of_constr t = let warn_projection_no_head_constant = CWarnings.create ~name:"projection-no-head-constant" ~category:"typechecker" - (fun (t,con_pp,proji_sp_pp) -> + (fun (sign,env,t,con,proji_sp) -> + let sign = List.map (on_snd EConstr.Unsafe.to_constr) sign in + let env = Termops.push_rels_assum sign env in + let con_pp = Nametab.pr_global_env Id.Set.empty (ConstRef con) in + let proji_sp_pp = Nametab.pr_global_env Id.Set.empty (ConstRef proji_sp) in + let term_pp = Termops.print_constr_env env Evd.empty (EConstr.of_constr t) in strbrk "Projection value has no head constant: " - ++ Termops.print_constr (EConstr.of_constr t) ++ strbrk " in canonical instance " + ++ term_pp ++ strbrk " in canonical instance " ++ con_pp ++ str " of " ++ proji_sp_pp ++ strbrk ", ignoring it.") (* Intended to always succeed *) let compute_canonical_projections warn (con,ind) = let env = Global.env () in let ctx = Environ.constant_context env con in - let u = Univ.UContext.instance ctx in + let u = Univ.make_abstract_instance ctx in let v = (mkConstU (con,u)) in - let ctx = Univ.ContextSet.of_context ctx in let c = Environ.constant_value_in env (con,u) in - let lt,t = Reductionops.splay_lam env Evd.empty (EConstr.of_constr c) in + let sign,t = Reductionops.splay_lam env Evd.empty (EConstr.of_constr c) in let t = EConstr.Unsafe.to_constr t in - let lt = List.rev_map (snd %> EConstr.Unsafe.to_constr) lt in + let lt = List.rev_map (snd %> EConstr.Unsafe.to_constr) sign in let args = snd (decompose_app t) in let { s_EXPECTEDPARAM = p; s_PROJ = lpj; s_PROJKIND = kl } = lookup_structure ind in @@ -221,9 +225,7 @@ let compute_canonical_projections warn (con,ind) = let patt, n , args = cs_pattern_of_constr t in ((ConstRef proji_sp, patt, t, n, args) :: l) with Not_found -> - let con_pp = Nametab.pr_global_env Id.Set.empty (ConstRef con) - and proji_sp_pp = Nametab.pr_global_env Id.Set.empty (ConstRef proji_sp) in - if warn then warn_projection_no_head_constant (t,con_pp,proji_sp_pp); + if warn then warn_projection_no_head_constant (sign,env,t,con,proji_sp); l end | _ -> l) @@ -298,7 +300,7 @@ let error_not_structure ref = let check_and_decompose_canonical_structure ref = let sp = match ref with ConstRef sp -> sp | _ -> error_not_structure ref in let env = Global.env () in - let u = Environ.constant_instance env sp in + let u = Univ.make_abstract_instance (Environ.constant_context env sp) in let vc = match Environ.constant_opt_value_in env (sp, u) with | Some vc -> vc | None -> error_not_structure ref in diff --git a/pretyping/recordops.mli b/pretyping/recordops.mli index 27d1650af..de09edcdc 100644 --- a/pretyping/recordops.mli +++ b/pretyping/recordops.mli @@ -57,7 +57,7 @@ type cs_pattern = type obj_typ = { o_DEF : constr; - o_CTX : Univ.ContextSet.t; + o_CTX : Univ.AUContext.t; o_INJ : int option; (** position of trivial argument *) o_TABS : constr list; (** ordered *) o_TPARAMS : constr list; (** ordered *) diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index cc1709f1c..1d75fecb1 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -29,7 +29,7 @@ exception Elimconst let refolding_in_reduction = ref false let _ = Goptions.declare_bool_option { - Goptions.optdepr = false; + Goptions.optdepr = true; (* remove in 8.8 *) Goptions.optname = "Perform refolding of fixpoints/constants like cbn during reductions"; Goptions.optkey = ["Refolding";"Reduction"]; @@ -1362,25 +1362,23 @@ let sigma_compare_instances ~flex i0 i1 sigma = raise Reduction.NotConvertible let sigma_check_inductive_instances cv_pb uinfind u u' sigma = - let ind_instance = - Univ.AUContext.instance (Univ.ACumulativityInfo.univ_context uinfind) + let len_instance = + Univ.AUContext.size (Univ.ACumulativityInfo.univ_context uinfind) in let ind_sbctx = Univ.ACumulativityInfo.subtyp_context uinfind in - if not ((Univ.Instance.length ind_instance = Univ.Instance.length u) && - (Univ.Instance.length ind_instance = Univ.Instance.length u')) then + if not ((len_instance = Univ.Instance.length u) && + (len_instance = Univ.Instance.length u')) then anomaly (Pp.str "Invalid inductive subtyping encountered!") else let comp_cst = let comp_subst = (Univ.Instance.append u u') in - Univ.UContext.constraints (Univ.subst_instance_context comp_subst ind_sbctx) + Univ.AUContext.instantiate comp_subst ind_sbctx in let comp_cst = match cv_pb with Reduction.CONV -> let comp_subst = (Univ.Instance.append u' u) in - let comp_cst' = - Univ.UContext.constraints(Univ.subst_instance_context comp_subst ind_sbctx) - in + let comp_cst' = Univ.AUContext.instantiate comp_subst ind_sbctx in Univ.Constraint.union comp_cst comp_cst' | Reduction.CUMUL -> comp_cst in diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index 201f79c39..d4fa266c0 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -57,6 +57,9 @@ type direction = Forward | Backward (* This module defines type-classes *) type typeclass = { + (* Universe quantification *) + cl_univs : Univ.AUContext.t; + (* The class implementation *) cl_impl : global_reference; @@ -111,23 +114,11 @@ let new_instance cl info glob poly impl = let classes : typeclasses ref = Summary.ref Refmap.empty ~name:"classes" let instances : instances ref = Summary.ref Refmap.empty ~name:"instances" -let typeclass_univ_instance (cl,u') = - let subst = - let u = - match cl.cl_impl with - | ConstRef c -> - let cb = Global.lookup_constant c in - Declareops.constant_polymorphic_instance cb - | IndRef c -> - let mib,oib = Global.lookup_inductive c in - Declareops.inductive_polymorphic_instance mib - | _ -> Univ.Instance.empty - in Array.fold_left2 (fun subst u u' -> Univ.LMap.add u u' subst) - Univ.LMap.empty (Univ.Instance.to_array u) (Univ.Instance.to_array u') - in - let subst_ctx = Context.Rel.map (subst_univs_level_constr subst) in - { cl with cl_context = fst cl.cl_context, subst_ctx (snd cl.cl_context); - cl_props = subst_ctx cl.cl_props}, u' +let typeclass_univ_instance (cl, u) = + assert (Univ.AUContext.size cl.cl_univs == Univ.Instance.length u); + let subst_ctx c = Context.Rel.map (subst_instance_constr u) c in + { cl with cl_context = on_snd subst_ctx cl.cl_context; + cl_props = subst_ctx cl.cl_props} let class_info c = try Refmap.find c !classes @@ -185,7 +176,8 @@ let subst_class (subst,cl) = do_subst_ctx ctx in let do_subst_projs projs = List.smartmap (fun (x, y, z) -> (x, y, Option.smartmap do_subst_con z)) projs in - { cl_impl = do_subst_gr cl.cl_impl; + { cl_univs = cl.cl_univs; + cl_impl = do_subst_gr cl.cl_impl; cl_context = do_subst_context cl.cl_context; cl_props = do_subst_ctx cl.cl_props; cl_projs = do_subst_projs cl.cl_projs; @@ -199,15 +191,14 @@ let discharge_class (_,cl) = let decl' = decl |> NamedDecl.map_constr (substn_vars 1 subst) |> NamedDecl.to_rel_decl in (decl' :: ctx', NamedDecl.get_id decl :: subst) ) ctx ([], []) in - let discharge_rel_context subst n rel = + let discharge_rel_context (subst, usubst) n rel = let rel = Context.Rel.map (Cooking.expmod_constr repl) rel in - let ctx, _ = - List.fold_right - (fun decl (ctx, k) -> - RelDecl.map_constr (substn_vars k subst) decl :: ctx, succ k - ) - rel ([], n) - in ctx + let fold decl (ctx, k) = + let map c = subst_univs_level_constr usubst (substn_vars k subst c) in + RelDecl.map_constr map decl :: ctx, succ k + in + let ctx, _ = List.fold_right fold rel ([], n) in + ctx in let abs_context cl = match cl.cl_impl with @@ -227,12 +218,14 @@ let discharge_class (_,cl) = in grs', discharge_rel_context subst 1 ctx @ ctx' in let cl_impl' = Lib.discharge_global cl.cl_impl in if cl_impl' == cl.cl_impl then cl else - let ctx, usubst, uctx = abs_context cl in + let ctx, _, _ as info = abs_context cl in let ctx, subst = rel_of_variable_context ctx in - let context = discharge_context ctx subst cl.cl_context in - let props = discharge_rel_context subst (succ (List.length (fst cl.cl_context))) cl.cl_props in + let usubst, cl_univs' = Lib.discharge_abstract_universe_context info cl.cl_univs in + let context = discharge_context ctx (subst, usubst) cl.cl_context in + let props = discharge_rel_context (subst, usubst) (succ (List.length (fst cl.cl_context))) cl.cl_props in let discharge_proj (x, y, z) = x, y, Option.smartmap Lib.discharge_con z in - { cl_impl = cl_impl'; + { cl_univs = cl_univs'; + cl_impl = cl_impl'; cl_context = context; cl_props = props; cl_projs = List.smartmap discharge_proj cl.cl_projs; @@ -279,8 +272,10 @@ let build_subclasses ~check env sigma glob { hint_priority = pri } = Nameops.add_suffix _id ("_subinstance_" ^ string_of_int !i)) in let ty, ctx = Global.type_of_global_in_context env glob in + let inst, ctx = Universes.fresh_instance_from ctx None in + let ty = Vars.subst_instance_constr inst ty in let ty = EConstr.of_constr ty in - let sigma = Evd.merge_context_set Evd.univ_rigid sigma (Univ.ContextSet.of_context ctx) in + let sigma = Evd.merge_context_set Evd.univ_rigid sigma ctx in let rec aux pri c ty path = match class_of_constr sigma ty with | None -> [] @@ -317,7 +312,7 @@ let build_subclasses ~check env sigma glob { hint_priority = pri } = hints @ (path', info, body) :: rest in List.fold_left declare_proj [] projs in - let term = Universes.constr_of_global_univ (glob,Univ.UContext.instance ctx) in + let term = Universes.constr_of_global_univ (glob, inst) in (*FIXME subclasses should now get substituted for each particular instance of the polymorphic superclass *) aux pri term ty [glob] @@ -405,7 +400,7 @@ let remove_instance i = remove_instance_hint i.is_impl let declare_instance info local glob = - let ty = Global.type_of_global_unsafe glob in + let ty, _ = Global.type_of_global_in_context (Global.env ()) glob in let info = Option.default {hint_priority = None; hint_pattern = None} info in match class_of_constr Evd.empty (EConstr.of_constr ty) with | Some (rels, ((tc,_), args) as _cl) -> diff --git a/pretyping/typeclasses.mli b/pretyping/typeclasses.mli index a8e90ca17..99cdbd3a3 100644 --- a/pretyping/typeclasses.mli +++ b/pretyping/typeclasses.mli @@ -16,6 +16,10 @@ type direction = Forward | Backward (** This module defines type-classes *) type typeclass = { + (** The toplevel universe quantification in which the typeclass lives. In + particular, [cl_props] and [cl_context] are quantified over it. *) + cl_univs : Univ.AUContext.t; + (** The class implementation: a record parameterized by the context with defs in it or a definition if the class is a singleton. This acts as the class' global identifier. *) cl_impl : global_reference; @@ -64,7 +68,7 @@ val class_info : global_reference -> typeclass (** raises a UserError if not a c val dest_class_app : env -> evar_map -> EConstr.constr -> (typeclass * EConstr.EInstance.t) * constr list (** Get the instantiated typeclass structure for a given universe instance. *) -val typeclass_univ_instance : typeclass puniverses -> typeclass puniverses +val typeclass_univ_instance : typeclass puniverses -> typeclass (** Just return None if not a class *) val class_of_constr : evar_map -> EConstr.constr -> (EConstr.rel_context * ((typeclass * EConstr.EInstance.t) * constr list)) option diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index b3eaa3cb9..66cc42cb6 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -174,7 +174,7 @@ and nf_whd env sigma whd typ = | Vatom_stk(Aind ((mi,i) as ind), stk) -> let mib = Environ.lookup_mind mi env in let nb_univs = - Univ.Instance.length (Declareops.inductive_polymorphic_instance mib) + Univ.AUContext.size (Declareops.inductive_polymorphic_context mib) in let mk u = let pind = (ind, u) in (mkIndU pind, type_of_ind env pind) @@ -203,7 +203,7 @@ and constr_type_of_idkey env sigma (idkey : Vars.id_key) stk = | ConstKey cst -> let cbody = Environ.lookup_constant cst env in let nb_univs = - Univ.Instance.length (Declareops.constant_polymorphic_instance cbody) + Univ.AUContext.size (Declareops.constant_polymorphic_context cbody) in let mk u = let pcst = (cst, u) in (mkConstU pcst, Typeops.type_of_constant_in env pcst) diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml index a15cadfa0..a68b569cb 100644 --- a/printing/ppvernac.ml +++ b/printing/ppvernac.ml @@ -105,7 +105,7 @@ open Decl_kinds | SearchString (s,sc) -> qs s ++ pr_opt (fun sc -> str "%" ++ str sc) sc let pr_search a gopt b pr_p = - pr_opt (fun g -> Proof_global.pr_goal_selector g ++ str ":"++ spc()) gopt + pr_opt (fun g -> Proof_bullet.pr_goal_selector g ++ str ":"++ spc()) gopt ++ match a with | SearchHead c -> keyword "SearchHead" ++ spc() ++ pr_p c ++ pr_in_out_modules b @@ -490,7 +490,7 @@ open Decl_kinds | PrintVisibility s -> keyword "Print Visibility" ++ pr_opt str s | PrintAbout (qid,gopt) -> - pr_opt (fun g -> Proof_global.pr_goal_selector g ++ str ":"++ spc()) gopt + pr_opt (fun g -> Proof_bullet.pr_goal_selector g ++ str ":"++ spc()) gopt ++ keyword "About" ++ spc() ++ pr_smart_global qid | PrintImplicit qid -> keyword "Print Implicit" ++ spc() ++ pr_smart_global qid @@ -1132,7 +1132,7 @@ open Decl_kinds | None -> hov 2 (keyword "Check" ++ spc() ++ pr_lconstr c) in let pr_i = match io with None -> mt () - | Some i -> Proof_global.pr_goal_selector i ++ str ": " in + | Some i -> Proof_bullet.pr_goal_selector i ++ str ": " in return (pr_i ++ pr_mayeval r c) | VernacGlobalCheck c -> return (hov 2 (keyword "Type" ++ pr_constrarg c)) diff --git a/printing/prettyp.ml b/printing/prettyp.ml index faa69f41e..827c0e458 100644 --- a/printing/prettyp.ml +++ b/printing/prettyp.ml @@ -70,7 +70,8 @@ let int_or_no n = if Int.equal n 0 then str "no" else int n let print_basename sp = pr_global (ConstRef sp) let print_ref reduce ref = - let typ = Global.type_of_global_unsafe ref in + let typ, ctx = Global.type_of_global_in_context (Global.env ()) ref in + let typ = Vars.subst_instance_constr (Univ.AUContext.instance ctx) typ in let typ = EConstr.of_constr typ in let typ = if reduce then @@ -78,6 +79,8 @@ let print_ref reduce ref = in EConstr.it_mkProd_or_LetIn ccl ctx else typ in let univs = Global.universes_of_global ref in + let inst = Univ.AUContext.instance univs in + let univs = Univ.UContext.make (inst, Univ.AUContext.instantiate inst univs) in let env = Global.env () in let bl = Universes.universe_binders_of_global ref in let sigma = Evd.from_ctx (Evd.evar_universe_context_of_binders bl) in @@ -135,7 +138,7 @@ let print_renames_list prefix l = hv 2 (prlist_with_sep pr_comma (fun x -> x) (List.map Name.print l))] let need_expansion impl ref = - let typ = Global.type_of_global_unsafe ref in + let typ, _ = Global.type_of_global_in_context (Global.env ()) ref in let ctx = prod_assum typ in let nprods = List.count is_local_assum ctx in not (List.is_empty impl) && List.length impl >= nprods && @@ -503,15 +506,48 @@ let ungeneralized_type_of_constant_type t = let print_instance sigma cb = if Declareops.constant_is_polymorphic cb then - pr_universe_instance sigma (Declareops.constant_polymorphic_context cb) + let univs = Declareops.constant_polymorphic_context cb in + let inst = Univ.AUContext.instance univs in + let univs = Univ.UContext.make (inst, Univ.AUContext.instantiate inst univs) in + pr_universe_instance sigma univs else mt() 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 = Declareops.type_of_constant cb in + let typ = match cb.const_type with + | RegularArity t as x -> + begin match cb.const_universes with + | Monomorphic_const _ -> x + | Polymorphic_const univs -> + let inst = Univ.AUContext.instance univs in + RegularArity (Vars.subst_instance_constr inst t) + end + | TemplateArity _ as x -> x + in let typ = ungeneralized_type_of_constant_type typ in - let univs = Global.universes_of_constant_body cb in + let univs = + let otab = Global.opaque_tables () in + match cb.const_body with + | Undef _ | Def _ -> + begin + match cb.const_universes with + | Monomorphic_const ctx -> ctx + | Polymorphic_const ctx -> + let inst = Univ.AUContext.instance ctx in + Univ.UContext.make (inst, Univ.AUContext.instantiate inst ctx) + end + | OpaqueDef o -> + let body_uctxs = Opaqueproof.force_constraints otab o in + match cb.const_universes with + | Monomorphic_const ctx -> + let uctxs = Univ.ContextSet.of_context ctx in + Univ.ContextSet.to_context (Univ.ContextSet.union body_uctxs uctxs) + | Polymorphic_const ctx -> + assert(Univ.ContextSet.is_empty body_uctxs); + let inst = Univ.AUContext.instance ctx in + Univ.UContext.make (inst, Univ.AUContext.instantiate inst ctx) + in let ctx = Evd.evar_universe_context_of_binders (Universes.universe_binders_of_global (ConstRef sp)) @@ -525,9 +561,10 @@ let print_constant with_values sep sp = print_basename sp ++ print_instance sigma cb ++ str " : " ++ cut () ++ pr_ltype typ ++ str" ]" ++ Printer.pr_universe_ctx sigma univs - | _ -> + | Some (c, ctx) -> + let c = Vars.subst_instance_constr (Univ.AUContext.instance ctx) c in print_basename sp ++ print_instance sigma cb ++ str sep ++ cut () ++ - (if with_values then print_typed_body env sigma (val_0,typ) else pr_ltype typ)++ + (if with_values then print_typed_body env sigma (Some c,typ) else pr_ltype typ)++ Printer.pr_universe_ctx sigma univs) let gallina_print_constant_with_infos sp = @@ -765,9 +802,11 @@ let print_opaque_name qid = | IndRef (sp,_) -> print_inductive sp | ConstructRef cstr as gr -> - let open EConstr in - let ty = Universes.unsafe_type_of_global gr in + let ty, ctx = Global.type_of_global_in_context env gr in + let inst = Univ.AUContext.instance ctx in + let ty = Vars.subst_instance_constr inst ty in let ty = EConstr.of_constr ty in + let open EConstr in print_typed_value (mkConstruct cstr, ty) | VarRef id -> env |> lookup_named id |> NamedDecl.set_id id |> print_named_decl diff --git a/printing/printer.ml b/printing/printer.ml index 2a198d456..351678802 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -805,7 +805,7 @@ let pr_open_subgoals ?(proof=Proof_global.give_me_the_proof ()) () = | _ , _, _ -> let end_cmd = str "This subproof is complete, but there are some unfocused goals." ++ - (let s = Proof_global.Bullet.suggest p in + (let s = Proof_bullet.suggest p in if Pp.ismt s then s else fnl () ++ s) ++ fnl () in diff --git a/printing/printmod.ml b/printing/printmod.ml index 10b791e37..5c7dcdc10 100644 --- a/printing/printmod.ml +++ b/printing/printmod.ml @@ -89,7 +89,7 @@ let build_ind_type env mip = let print_one_inductive env sigma mib ((_,i) as ind) = let u = if Declareops.inductive_is_polymorphic mib then - Declareops.inductive_polymorphic_instance mib + Univ.AUContext.instance (Declareops.inductive_polymorphic_context mib) else Univ.Instance.empty in let mip = mib.mind_packets.(i) in let params = Inductive.inductive_paramdecls (mib,u) in @@ -100,7 +100,9 @@ let print_one_inductive env sigma mib ((_,i) as ind) = let envpar = push_rel_context params env in let inst = if Declareops.inductive_is_polymorphic mib then - Printer.pr_universe_instance sigma (Declareops.inductive_polymorphic_context mib) + let ctx = Declareops.inductive_polymorphic_context mib in + let ctx = Univ.UContext.make (u, Univ.AUContext.instantiate u ctx) in + Printer.pr_universe_instance sigma ctx else mt () in hov 0 ( @@ -108,6 +110,17 @@ let print_one_inductive env sigma mib ((_,i) as ind) = str ": " ++ Printer.pr_lconstr_env envpar sigma arity ++ str " :=") ++ brk(0,2) ++ print_constructors envpar sigma mip.mind_consnames cstrtypes +let instantiate_cumulativity_info cumi = + let open Univ in + let univs = ACumulativityInfo.univ_context cumi in + let subtyp = ACumulativityInfo.subtyp_context cumi in + let expose ctx = + let inst = AUContext.instance ctx in + let cst = AUContext.instantiate inst ctx in + UContext.make (inst, cst) + in + CumulativityInfo.make (expose univs, expose subtyp) + let print_mutual_inductive env mind mib = let inds = List.init (Array.length mib.mind_packets) (fun x -> (mind, x)) in @@ -131,7 +144,7 @@ let print_mutual_inductive env mind mib = | Monomorphic_ind _ | Polymorphic_ind _ -> str "" | Cumulative_ind cumi -> Printer.pr_cumulativity_info - sigma (Univ.instantiate_cumulativity_info cumi)) + sigma (instantiate_cumulativity_info cumi)) let get_fields = let rec prodec_rec l subst c = @@ -149,7 +162,7 @@ let get_fields = let print_record env mind mib = let u = if Declareops.inductive_is_polymorphic mib then - Declareops.inductive_polymorphic_instance mib + Univ.AUContext.instance (Declareops.inductive_polymorphic_context mib) else Univ.Instance.empty in let mip = mib.mind_packets.(0) in @@ -189,7 +202,7 @@ let print_record env mind mib = | Monomorphic_ind _ | Polymorphic_ind _ -> str "" | Cumulative_ind cumi -> Printer.pr_cumulativity_info - sigma (Univ.instantiate_cumulativity_info cumi) + sigma (instantiate_cumulativity_info cumi) ) let pr_mutual_inductive_body env mind mib = @@ -292,11 +305,13 @@ let print_body is_impl env mp (l,body) = | SFBmodule _ -> keyword "Module" ++ spc () ++ name | SFBmodtype _ -> keyword "Module Type" ++ spc () ++ name | SFBconst cb -> + let ctx = Declareops.constant_polymorphic_context cb in let u = if Declareops.constant_is_polymorphic cb then - Declareops.constant_polymorphic_instance cb + Univ.AUContext.instance ctx else Univ.Instance.empty in + let ctx = Univ.UContext.make (u, Univ.AUContext.instantiate u ctx) in let sigma = Evd.empty in (match cb.const_body with | Def _ -> def "Definition" ++ spc () @@ -316,8 +331,7 @@ let print_body is_impl env mp (l,body) = Printer.pr_lconstr_env env sigma (Vars.subst_instance_constr u (Mod_subst.force_constr l))) | _ -> mt ()) ++ str "." ++ - Printer.pr_universe_ctx sigma - (Declareops.constant_polymorphic_context cb)) + Printer.pr_universe_ctx sigma ctx) | SFBmind mib -> try let env = Option.get env in diff --git a/printing/miscprint.ml b/proofs/miscprint.ml index 5d37c8a02..5d37c8a02 100644 --- a/printing/miscprint.ml +++ b/proofs/miscprint.ml diff --git a/printing/miscprint.mli b/proofs/miscprint.mli index 21d410c7b..21d410c7b 100644 --- a/printing/miscprint.mli +++ b/proofs/miscprint.mli diff --git a/proofs/proof_bullet.ml b/proofs/proof_bullet.ml new file mode 100644 index 000000000..f80cb7cc6 --- /dev/null +++ b/proofs/proof_bullet.ml @@ -0,0 +1,248 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) + +open Proof + +type t = Vernacexpr.bullet + +let bullet_eq b1 b2 = match b1, b2 with +| Vernacexpr.Dash n1, Vernacexpr.Dash n2 -> n1 = n2 +| Vernacexpr.Star n1, Vernacexpr.Star n2 -> n1 = n2 +| Vernacexpr.Plus n1, Vernacexpr.Plus n2 -> n1 = n2 +| _ -> false + +let pr_bullet b = + match b with + | Vernacexpr.Dash n -> Pp.(str (String.make n '-')) + | Vernacexpr.Star n -> Pp.(str (String.make n '*')) + | Vernacexpr.Plus n -> Pp.(str (String.make n '+')) + + +type behavior = { + name : string; + put : proof -> t -> proof; + suggest: proof -> Pp.t +} + +let behaviors = Hashtbl.create 4 +let register_behavior b = Hashtbl.add behaviors b.name b + +(*** initial modes ***) +let none = { + name = "None"; + put = (fun x _ -> x); + suggest = (fun _ -> Pp.mt ()) +} +let _ = register_behavior none + +module Strict = struct + type suggestion = + | Suggest of t (* this bullet is mandatory here *) + | Unfinished of t (* no mandatory bullet here, but this bullet is unfinished *) + | NoBulletInUse (* No mandatory bullet (or brace) here, no bullet pending, + some focused goals exists. *) + | NeedClosingBrace (* Some unfocussed goal exists "{" needed to focus them *) + | ProofFinished (* No more goal anywhere *) + + (* give a message only if more informative than the standard coq message *) + let suggest_on_solved_goal sugg = + match sugg with + | NeedClosingBrace -> Pp.(str"Try unfocusing with \"}\".") + | NoBulletInUse -> Pp.mt () + | ProofFinished -> Pp.mt () + | Suggest b -> Pp.(str"Focus next goal with bullet " ++ pr_bullet b ++ str".") + | Unfinished b -> Pp.(str"The current bullet " ++ pr_bullet b ++ str" is unfinished.") + + (* give always a message. *) + let suggest_on_error sugg = + match sugg with + | NeedClosingBrace -> Pp.(str"Try unfocusing with \"}\".") + | NoBulletInUse -> assert false (* This should never raise an error. *) + | ProofFinished -> Pp.(str"No more subgoals.") + | Suggest b -> Pp.(str"Expecting " ++ pr_bullet b ++ str".") + | Unfinished b -> Pp.(str"Current bullet " ++ pr_bullet b ++ str" is not finished.") + + exception FailedBullet of t * suggestion + + let _ = + CErrors.register_handler + (function + | FailedBullet (b,sugg) -> + let prefix = Pp.(str"Wrong bullet " ++ pr_bullet b ++ str": ") in + CErrors.user_err ~hdr:"Focus" Pp.(prefix ++ suggest_on_error sugg) + | _ -> raise CErrors.Unhandled) + + + (* spiwack: we need only one focus kind as we keep a stack of (distinct!) bullets *) + let bullet_kind = (new_focus_kind () : t list focus_kind) + let bullet_cond = done_cond ~loose_end:true bullet_kind + + (* spiwack: as it is bullets are reset (locally) by *any* non-bullet focusing command + experience will tell if this is the right discipline of if we want to be finer and + reset them only for a choice of bullets. *) + let get_bullets pr = + if is_last_focus bullet_kind pr then + get_at_focus bullet_kind pr + else + [] + + let has_bullet bul pr = + let rec has_bullet = function + | b'::_ when bullet_eq bul b' -> true + | _::l -> has_bullet l + | [] -> false + in + has_bullet (get_bullets pr) + + (* pop a bullet from proof [pr]. There should be at least one + bullet in use. If pop impossible (pending proofs on this level + of bullet or higher) then raise [Proof.CannotUnfocusThisWay]. *) + let pop pr = + match get_bullets pr with + | b::_ -> unfocus bullet_kind pr () , b + | _ -> assert false + + let push (b:t) pr = + focus bullet_cond (b::get_bullets pr) 1 pr + + (* Used only in the next function. + TODO: use a recursive function instead? *) + exception SuggestFound of t + + let suggest_bullet (prf : proof): suggestion = + if is_done prf then ProofFinished + else if not (no_focused_goal prf) + then (* No suggestion if a bullet is not mandatory, look for an unfinished bullet *) + match get_bullets prf with + | b::_ -> Unfinished b + | _ -> NoBulletInUse + else (* There is no goal under focus but some are unfocussed, + let us look at the bullet needed. If no *) + let pcobaye = ref prf in + try + while true do + let pcobaye', b = pop !pcobaye in + (* pop went well, this means that there are no more goals + *under this* bullet b, see if a new b can be pushed. *) + (try let _ = push b pcobaye' in (* push didn't fail so a new b can be pushed. *) + raise (SuggestFound b) + with SuggestFound _ as e -> raise e + | _ -> ()); (* b could not be pushed, so we must look for a outer bullet *) + pcobaye := pcobaye' + done; + assert false + with SuggestFound b -> Suggest b + | _ -> NeedClosingBrace (* No push was possible, but there are still + subgoals somewhere: there must be a "}" to use. *) + + + let rec pop_until (prf : proof) bul : proof = + let prf', b = pop prf in + if bullet_eq bul b then prf' + else pop_until prf' bul + + let put p bul = + try + if not (has_bullet bul p) then + (* bullet is not in use, so pushing it is always ok unless + no goal under focus. *) + push bul p + else + match suggest_bullet p with + | Suggest suggested_bullet when bullet_eq bul suggested_bullet + -> (* suggested_bullet is mandatory and you gave the right one *) + let p' = pop_until p bul in + push bul p' + (* the bullet you gave is in use but not the right one *) + | sugg -> raise (FailedBullet (bul,sugg)) + with NoSuchGoals _ -> (* push went bad *) + raise (FailedBullet (bul,suggest_bullet p)) + + let strict = { + name = "Strict Subproofs"; + put = put; + suggest = (fun prf -> suggest_on_solved_goal (suggest_bullet prf)) + + } + let _ = register_behavior strict +end + +(* Current bullet behavior, controlled by the option *) +let current_behavior = ref Strict.strict + +let _ = + Goptions.(declare_string_option { + optdepr = false; + optname = "bullet behavior"; + optkey = ["Bullet";"Behavior"]; + optread = begin fun () -> + (!current_behavior).name + end; + optwrite = begin fun n -> + current_behavior := + try Hashtbl.find behaviors n + with Not_found -> + CErrors.user_err Pp.(str ("Unknown bullet behavior: \"" ^ n ^ "\".")) + end + }) + +let put p b = + (!current_behavior).put p b + +let suggest p = + (!current_behavior).suggest p + +(**********************************************************) +(* *) +(* Default goal selector *) +(* *) +(**********************************************************) + + +(* Default goal selector: selector chosen when a tactic is applied + without an explicit selector. *) +let default_goal_selector = ref (Vernacexpr.SelectNth 1) +let get_default_goal_selector () = !default_goal_selector + +let pr_range_selector (i, j) = + if i = j then Pp.int i + else Pp.(int i ++ str "-" ++ int j) + +let pr_goal_selector = function + | Vernacexpr.SelectAll -> Pp.str "all" + | Vernacexpr.SelectNth i -> Pp.int i + | Vernacexpr.SelectList l -> + Pp.(str "[" + ++ prlist_with_sep pr_comma pr_range_selector l + ++ str "]") + | Vernacexpr.SelectId id -> Names.Id.print id + +let parse_goal_selector = function + | "all" -> Vernacexpr.SelectAll + | i -> + let err_msg = "The default selector must be \"all\" or a natural number." in + begin try + let i = int_of_string i in + if i < 0 then CErrors.user_err Pp.(str err_msg); + Vernacexpr.SelectNth i + with Failure _ -> CErrors.user_err Pp.(str err_msg) + end + +let _ = + Goptions.(declare_string_option{optdepr = false; + optname = "default goal selector" ; + optkey = ["Default";"Goal";"Selector"] ; + optread = begin fun () -> + Pp.string_of_ppcmds + (pr_goal_selector !default_goal_selector) + end; + optwrite = begin fun n -> + default_goal_selector := parse_goal_selector n + end + }) + diff --git a/proofs/proof_bullet.mli b/proofs/proof_bullet.mli new file mode 100644 index 000000000..9ae521d3f --- /dev/null +++ b/proofs/proof_bullet.mli @@ -0,0 +1,53 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) + +(**********************************************************) +(* *) +(* Bullets *) +(* *) +(**********************************************************) + +open Proof + +type t = Vernacexpr.bullet + +(** A [behavior] is the data of a put function which + is called when a bullet prefixes a tactic, a suggest function + suggesting the right bullet to use on a given proof, together + with a name to identify the behavior. *) +type behavior = { + name : string; + put : proof -> t -> proof; + suggest: proof -> Pp.t +} + +(** A registered behavior can then be accessed in Coq + through the command [Set Bullet Behavior "name"]. + + Two modes are registered originally: + * "Strict Subproofs": + - If this bullet follows another one of its kind, defocuses then focuses + (which fails if the focused subproof is not complete). + - If it is the first bullet of its kind, then focuses a new subproof. + * "None": bullets don't do anything *) +val register_behavior : behavior -> unit + +(** Handles focusing/defocusing with bullets: + *) +val put : proof -> t -> proof +val suggest : proof -> Pp.t + +(**********************************************************) +(* *) +(* Default goal selector *) +(* *) +(**********************************************************) + +val pr_goal_selector : Vernacexpr.goal_selector -> Pp.std_ppcmds +val get_default_goal_selector : unit -> Vernacexpr.goal_selector + diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index 703bdff64..52d6787d4 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -446,265 +446,6 @@ let set_terminator hook = | [] -> raise NoCurrentProof | p :: ps -> pstates := { p with terminator = CEphemeron.create hook } :: ps - - - -(**********************************************************) -(* *) -(* Bullets *) -(* *) -(**********************************************************) - -module Bullet = struct - - type t = Vernacexpr.bullet - - let bullet_eq b1 b2 = match b1, b2 with - | Vernacexpr.Dash n1, Vernacexpr.Dash n2 -> n1 = n2 - | Vernacexpr.Star n1, Vernacexpr.Star n2 -> n1 = n2 - | Vernacexpr.Plus n1, Vernacexpr.Plus n2 -> n1 = n2 - | _ -> false - - let pr_bullet b = - match b with - | Vernacexpr.Dash n -> str (String.make n '-') - | Vernacexpr.Star n -> str (String.make n '*') - | Vernacexpr.Plus n -> str (String.make n '+') - - - type behavior = { - name : string; - put : Proof.proof -> t -> Proof.proof; - suggest: Proof.proof -> std_ppcmds - } - - let behaviors = Hashtbl.create 4 - let register_behavior b = Hashtbl.add behaviors b.name b - - (*** initial modes ***) - let none = { - name = "None"; - put = (fun x _ -> x); - suggest = (fun _ -> mt ()) - } - let _ = register_behavior none - - module Strict = struct - type suggestion = - | Suggest of t (* this bullet is mandatory here *) - | Unfinished of t (* no mandatory bullet here, but this bullet is unfinished *) - | NoBulletInUse (* No mandatory bullet (or brace) here, no bullet pending, - some focused goals exists. *) - | NeedClosingBrace (* Some unfocussed goal exists "{" needed to focus them *) - | ProofFinished (* No more goal anywhere *) - - (* give a message only if more informative than the standard coq message *) - let suggest_on_solved_goal sugg = - match sugg with - | NeedClosingBrace -> str"Try unfocusing with \"}\"." - | NoBulletInUse -> mt () - | ProofFinished -> mt () - | Suggest b -> str"Focus next goal with bullet " ++ pr_bullet b ++ str"." - | Unfinished b -> str"The current bullet " ++ pr_bullet b ++ str" is unfinished." - - (* give always a message. *) - let suggest_on_error sugg = - match sugg with - | NeedClosingBrace -> str"Try unfocusing with \"}\"." - | NoBulletInUse -> assert false (* This should never raise an error. *) - | ProofFinished -> str"No more subgoals." - | Suggest b -> str"Expecting " ++ pr_bullet b ++ str"." - | Unfinished b -> str"Current bullet " ++ pr_bullet b ++ str" is not finished." - - exception FailedBullet of t * suggestion - - let _ = - CErrors.register_handler - (function - | FailedBullet (b,sugg) -> - let prefix = str"Wrong bullet " ++ pr_bullet b ++ str": " in - CErrors.user_err ~hdr:"Focus" (prefix ++ suggest_on_error sugg) - | _ -> raise CErrors.Unhandled) - - - (* spiwack: we need only one focus kind as we keep a stack of (distinct!) bullets *) - let bullet_kind = (Proof.new_focus_kind () : t list Proof.focus_kind) - let bullet_cond = Proof.done_cond ~loose_end:true bullet_kind - - (* spiwack: as it is bullets are reset (locally) by *any* non-bullet focusing command - experience will tell if this is the right discipline of if we want to be finer and - reset them only for a choice of bullets. *) - let get_bullets pr = - if Proof.is_last_focus bullet_kind pr then - Proof.get_at_focus bullet_kind pr - else - [] - - let has_bullet bul pr = - let rec has_bullet = function - | b'::_ when bullet_eq bul b' -> true - | _::l -> has_bullet l - | [] -> false - in - has_bullet (get_bullets pr) - - (* pop a bullet from proof [pr]. There should be at least one - bullet in use. If pop impossible (pending proofs on this level - of bullet or higher) then raise [Proof.CannotUnfocusThisWay]. *) - let pop pr = - match get_bullets pr with - | b::_ -> Proof.unfocus bullet_kind pr () , b - | _ -> assert false - - let push (b:t) pr = - Proof.focus bullet_cond (b::get_bullets pr) 1 pr - - (* Used only in the next function. - TODO: use a recursive function instead? *) - exception SuggestFound of t - - let suggest_bullet (prf:Proof.proof): suggestion = - if Proof.is_done prf then ProofFinished - else if not (Proof.no_focused_goal prf) - then (* No suggestion if a bullet is not mandatory, look for an unfinished bullet *) - match get_bullets prf with - | b::_ -> Unfinished b - | _ -> NoBulletInUse - else (* There is no goal under focus but some are unfocussed, - let us look at the bullet needed. If no *) - let pcobaye = ref prf in - try - while true do - let pcobaye', b = pop !pcobaye in - (* pop went well, this means that there are no more goals - *under this* bullet b, see if a new b can be pushed. *) - (try let _ = push b pcobaye' in (* push didn't fail so a new b can be pushed. *) - raise (SuggestFound b) - with SuggestFound _ as e -> raise e - | _ -> ()); (* b could not be pushed, so we must look for a outer bullet *) - pcobaye := pcobaye' - done; - assert false - with SuggestFound b -> Suggest b - | _ -> NeedClosingBrace (* No push was possible, but there are still - subgoals somewhere: there must be a "}" to use. *) - - - let rec pop_until (prf:Proof.proof) bul: Proof.proof = - let prf', b = pop prf in - if bullet_eq bul b then prf' - else pop_until prf' bul - - let put p bul = - try - if not (has_bullet bul p) then - (* bullet is not in use, so pushing it is always ok unless - no goal under focus. *) - push bul p - else - match suggest_bullet p with - | Suggest suggested_bullet when bullet_eq bul suggested_bullet - -> (* suggested_bullet is mandatory and you gave the right one *) - let p' = pop_until p bul in - push bul p' - (* the bullet you gave is in use but not the right one *) - | sugg -> raise (FailedBullet (bul,sugg)) - with Proof.NoSuchGoals _ -> (* push went bad *) - raise (FailedBullet (bul,suggest_bullet p)) - - let strict = { - name = "Strict Subproofs"; - put = put; - suggest = (fun prf -> suggest_on_solved_goal (suggest_bullet prf)) - - } - let _ = register_behavior strict - end - - (* Current bullet behavior, controlled by the option *) - let current_behavior = ref Strict.strict - - let _ = - Goptions.(declare_string_option { - optdepr = false; - optname = "bullet behavior"; - optkey = ["Bullet";"Behavior"]; - optread = begin fun () -> - (!current_behavior).name - end; - optwrite = begin fun n -> - current_behavior := - try Hashtbl.find behaviors n - with Not_found -> - CErrors.user_err Pp.(str ("Unknown bullet behavior: \"" ^ n ^ "\".")) - end - }) - - let put p b = - (!current_behavior).put p b - - let suggest p = - (!current_behavior).suggest p -end - - -let _ = - let hook n = - let prf = give_me_the_proof () in - (Bullet.suggest prf) in - Proofview.set_nosuchgoals_hook hook - - -(**********************************************************) -(* *) -(* Default goal selector *) -(* *) -(**********************************************************) - - -(* Default goal selector: selector chosen when a tactic is applied - without an explicit selector. *) -let default_goal_selector = ref (Vernacexpr.SelectNth 1) -let get_default_goal_selector () = !default_goal_selector - -let pr_range_selector (i, j) = - if i = j then int i - else int i ++ str "-" ++ int j - -let pr_goal_selector = function - | Vernacexpr.SelectAll -> str "all" - | Vernacexpr.SelectNth i -> int i - | Vernacexpr.SelectList l -> - str "[" - ++ prlist_with_sep pr_comma pr_range_selector l - ++ str "]" - | Vernacexpr.SelectId id -> Id.print id - -let parse_goal_selector = function - | "all" -> Vernacexpr.SelectAll - | i -> - let err_msg = "The default selector must be \"all\" or a natural number." in - begin try - let i = int_of_string i in - if i < 0 then CErrors.user_err Pp.(str err_msg); - Vernacexpr.SelectNth i - with Failure _ -> CErrors.user_err Pp.(str err_msg) - end - -let _ = - Goptions.(declare_string_option{optdepr = false; - optname = "default goal selector" ; - optkey = ["Default";"Goal";"Selector"] ; - optread = begin fun () -> - string_of_ppcmds - (pr_goal_selector !default_goal_selector) - end; - optwrite = begin fun n -> - default_goal_selector := parse_goal_selector n - end - }) - - module V82 = struct let get_current_initial_conclusions () = let { pid; strength; proof } = cur_pstate () in @@ -733,3 +474,11 @@ let update_global_env () = let tac = Proofview.Unsafe.tclEVARS (Evd.update_sigma_env sigma (Global.env ())) in let (p,(status,info)) = Proof.run_tactic (Global.env ()) tac p in (p, ()))) + +(* XXX: Bullet hook, should be really moved elsewhere *) +let _ = + let hook n = + let prf = give_me_the_proof () in + (Proof_bullet.suggest prf) in + Proofview.set_nosuchgoals_hook hook + diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli index 2c3938975..52f5f7404 100644 --- a/proofs/proof_global.mli +++ b/proofs/proof_global.mli @@ -121,52 +121,6 @@ val get_used_variables : unit -> Context.Named.t option val get_universe_binders : unit -> universe_binders option -(**********************************************************) -(* *) -(* Bullets *) -(* *) -(**********************************************************) - -module Bullet : sig - type t = Vernacexpr.bullet - - (** A [behavior] is the data of a put function which - is called when a bullet prefixes a tactic, a suggest function - suggesting the right bullet to use on a given proof, together - with a name to identify the behavior. *) - type behavior = { - name : string; - put : Proof.proof -> t -> Proof.proof; - suggest: Proof.proof -> Pp.std_ppcmds - } - - (** A registered behavior can then be accessed in Coq - through the command [Set Bullet Behavior "name"]. - - Two modes are registered originally: - * "Strict Subproofs": - - If this bullet follows another one of its kind, defocuses then focuses - (which fails if the focused subproof is not complete). - - If it is the first bullet of its kind, then focuses a new subproof. - * "None": bullets don't do anything *) - val register_behavior : behavior -> unit - - (** Handles focusing/defocusing with bullets: - *) - val put : Proof.proof -> t -> Proof.proof - val suggest : Proof.proof -> Pp.std_ppcmds -end - - -(**********************************************************) -(* *) -(* Default goal selector *) -(* *) -(**********************************************************) - -val pr_goal_selector : Vernacexpr.goal_selector -> Pp.std_ppcmds -val get_default_goal_selector : unit -> Vernacexpr.goal_selector - module V82 : sig val get_current_initial_conclusions : unit -> Names.Id.t *(EConstr.types list * Decl_kinds.goal_kind) diff --git a/proofs/proof_type.mli b/proofs/proof_type.ml index 11f1a13e6..11f1a13e6 100644 --- a/proofs/proof_type.mli +++ b/proofs/proof_type.ml diff --git a/proofs/proofs.mllib b/proofs/proofs.mllib index 804a54360..eaf0c693e 100644 --- a/proofs/proofs.mllib +++ b/proofs/proofs.mllib @@ -2,9 +2,11 @@ Miscprint Goal Evar_refiner Proof_using +Proof_type Logic Refine Proof +Proof_bullet Proof_global Redexpr Refiner diff --git a/stm/stm.ml b/stm/stm.ml index fd3d418c1..7c9620854 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -1576,8 +1576,10 @@ end = struct (* {{{ *) let uc = Option.get (Opaqueproof.get_constraints (Global.opaque_tables ()) o) in + (** We only manipulate monomorphic terms here. *) + let map (c, ctx) = assert (Univ.AUContext.is_empty ctx); c in let pr = - Future.from_val (Option.get (Global.body_of_constant_body c)) in + Future.from_val (map (Option.get (Global.body_of_constant_body c))) in let uc = Future.chain ~pure:true uc Univ.hcons_universe_context_set in diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index 7a8595653..6cc9d3d55 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -92,7 +92,7 @@ open Goptions let _ = declare_bool_option - { optdepr = true; + { optdepr = true; (* remove in 8.8 *) optname = "do typeclass search modulo eta conversion"; optkey = ["Typeclasses";"Modulo";"Eta"]; optread = get_typeclasses_modulo_eta; @@ -125,7 +125,7 @@ let _ = let _ = declare_bool_option - { optdepr = false; + { optdepr = true; (* remove in 8.8 *) optname = "compat"; optkey = ["Typeclasses";"Legacy";"Resolution"]; optread = get_typeclasses_legacy_resolution; @@ -494,16 +494,15 @@ let catchable = function | Refiner.FailError _ -> true | e -> Logic.catchable_exception e -(* alternate separators in debug search path output *) -let debug_seps = [| "." ; "-" |] -let next_sep seps = - let num_seps = Array.length seps in - let sep_index = ref 0 in - fun () -> - let sep = seps.(!sep_index) in - sep_index := (!sep_index + 1) mod num_seps; - str sep -let pr_depth l = prlist_with_sep (next_sep debug_seps) int (List.rev l) +let pr_depth l = + let rec fmt elts = + match elts with + | [] -> [] + | [n] -> [string_of_int n] + | n1::n2::rest -> + (string_of_int n1 ^ "." ^ string_of_int n2) :: fmt rest + in + prlist_with_sep (fun () -> str "-") str (fmt (List.rev l)) let is_Prop env sigma concl = let ty = Retyping.get_type_of env sigma concl in @@ -1425,18 +1424,20 @@ let deps_of_constraints cstrs evm p = Intpart.union_set (Evar.Set.union evx evy) p) cstrs -let evar_dependencies evm p = +let evar_dependencies pred evm p = Evd.fold_undefined (fun ev evi _ -> - let evars = Evar.Set.add ev (Evarutil.undefined_evars_of_evar_info evm evi) - in Intpart.union_set evars p) + if Typeclasses.is_resolvable evi && pred evm ev evi then + let evars = Evar.Set.add ev (Evarutil.undefined_evars_of_evar_info evm evi) + in Intpart.union_set evars p + else ()) evm () (** [split_evars] returns groups of undefined evars according to dependencies *) -let split_evars evm = +let split_evars pred evm = let p = Intpart.create () in - evar_dependencies evm p; + evar_dependencies pred evm p; deps_of_constraints (snd (extract_all_conv_pbs evm)) evm p; Intpart.partition p @@ -1521,7 +1522,7 @@ exception Unresolved (** If [do_split] is [true], we try to separate the problem in several components and then solve them separately *) let resolve_all_evars debug depth unique env p oevd do_split fail = - let split = if do_split then split_evars oevd else [Evar.Set.empty] in + let split = if do_split then split_evars p oevd else [Evar.Set.empty] in let in_comp comp ev = if do_split then Evar.Set.mem ev comp else true in let rec docomp evd = function diff --git a/tactics/elimschemes.ml b/tactics/elimschemes.ml index 5d9d36958..2d2a0c1b2 100644 --- a/tactics/elimschemes.ml +++ b/tactics/elimschemes.ml @@ -46,26 +46,15 @@ let optimize_non_type_induction_scheme kind dep sort _ ind = let sigma, nf = Evarutil.nf_evars_and_universes sigma in (nf c', Evd.evar_universe_context sigma), eff else - let mib,mip = Inductive.lookup_mind_specif env ind in - let ctx = Declareops.inductive_polymorphic_context mib in - let u = Univ.UContext.instance ctx in - let ctxset = Univ.ContextSet.of_context ctx in - let ectx = Evd.evar_universe_context_of ctxset in - let sigma = Evd.merge_universe_context sigma ectx in - let sigma, c = build_induction_scheme env sigma (ind,u) dep sort in + let sigma, pind = Evd.fresh_inductive_instance env sigma ind in + let sigma, c = build_induction_scheme env sigma pind dep sort in (c, Evd.evar_universe_context sigma), Safe_typing.empty_private_constants let build_induction_scheme_in_type dep sort ind = let env = Global.env () in let sigma = Evd.from_env env in - let ctx = - let mib,mip = Inductive.lookup_mind_specif env ind in - Declareops.inductive_polymorphic_context mib - in - let u = Univ.UContext.instance ctx in - let ctxset = Univ.ContextSet.of_context ctx in - let sigma = Evd.merge_universe_context sigma (Evd.evar_universe_context_of ctxset) in - let sigma, c = build_induction_scheme env sigma (ind,u) dep sort in + let sigma, pind = Evd.fresh_inductive_instance env sigma ind in + let sigma, c = build_induction_scheme env sigma pind dep sort in c, Evd.evar_universe_context sigma let rect_scheme_kind_from_type = diff --git a/tactics/hints.ml b/tactics/hints.ml index c2c80e630..a572508d4 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -937,7 +937,7 @@ let make_extern pri pat tacast = let make_mode ref m = let open Term in - let ty = Global.type_of_global_unsafe ref in + let ty, _ = Global.type_of_global_in_context (Global.env ()) ref in let ctx, t = decompose_prod ty in let n = List.length ctx in let m' = Array.of_list m in diff --git a/vernac/ind_tables.ml b/tactics/ind_tables.ml index 0407c1e36..0407c1e36 100644 --- a/vernac/ind_tables.ml +++ b/tactics/ind_tables.ml diff --git a/vernac/ind_tables.mli b/tactics/ind_tables.mli index 005555caa..005555caa 100644 --- a/vernac/ind_tables.mli +++ b/tactics/ind_tables.mli diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 2e3a4e33b..8a95ad177 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -80,15 +80,15 @@ let _ = optread = (fun () -> !Flags.tactic_context_compat) ; optwrite = (fun b -> Flags.tactic_context_compat := b) } -let apply_solve_class_goals = ref (false) -let _ = Goptions.declare_bool_option { - Goptions.optdepr = true; - Goptions.optname = - "Perform typeclass resolution on apply-generated subgoals."; - Goptions.optkey = ["Typeclass";"Resolution";"After";"Apply"]; - Goptions.optread = (fun () -> !apply_solve_class_goals); - Goptions.optwrite = (fun a -> apply_solve_class_goals:=a); -} +let apply_solve_class_goals = ref false + +let _ = + declare_bool_option + { optdepr = true; (* remove in 8.8 *) + optname = "Perform typeclass resolution on apply-generated subgoals."; + optkey = ["Typeclass";"Resolution";"After";"Apply"]; + optread = (fun () -> !apply_solve_class_goals); + optwrite = (fun a -> apply_solve_class_goals := a); } let clear_hyp_by_default = ref false @@ -124,7 +124,7 @@ let shrink_abstract = ref true let _ = declare_bool_option - { optdepr = true; + { optdepr = true; (* remove in 8.8 *) optname = "shrinking of abstracted proofs"; optkey = ["Shrink"; "Abstract"]; optread = (fun () -> !shrink_abstract) ; @@ -143,7 +143,7 @@ let use_bracketing_last_or_and_intro_pattern () = let _ = declare_bool_option - { optdepr = true; (* remove in 8.8 *) + { optdepr = false; optname = "bracketing last or-and introduction pattern"; optkey = ["Bracketing";"Last";"Introduction";"Pattern"]; optread = (fun () -> !bracketing_last_or_and_intro_pattern); @@ -5003,9 +5003,19 @@ let cache_term_by_tactic_then ~opaque ?(goal_type=None) id gk tac tacK = Declare.declare_constant ~internal:Declare.InternalTacticRequest ~local:true id decl in let cst = Impargs.with_implicit_protection cst () in - (* let evd, lem = Evd.fresh_global (Global.env ()) evd (ConstRef cst) in *) - let lem, ctx = Universes.unsafe_constr_of_global (ConstRef cst) in - let lem = EConstr.of_constr lem in + let lem = + if const.Entries.const_entry_polymorphic then + let uctx = Univ.ContextSet.of_context const.Entries.const_entry_universes 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 + in hope it is fixed at some point. *) + let (_, body_uctx), _ = Future.force const.Entries.const_entry_body in + 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 + in let evd = Evd.set_universe_context evd ectx in let open Safe_typing in let eff = private_con_of_con (Global.safe_env ()) cst in diff --git a/test-suite/Makefile b/test-suite/Makefile index 5ab4cacda..beb80a3df 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -27,8 +27,8 @@ # Default value when called from a freshly compiled Coq, but can be # easily overridden -LIB := $(shell cd ..; pwd) -BIN := $(LIB)/bin/ +LIB := .. +BIN := $(shell cd ..; pwd)/bin/ coqtop := $(BIN)coqtop -coqlib $(LIB) -boot -q -batch -test-mode -R prerequisite TestSuite coqc := $(BIN)coqc -coqlib $(LIB) -R prerequisite TestSuite @@ -170,6 +170,7 @@ summary.log: report: summary.log $(HIDE)./save-logs.sh $(HIDE)if [ -n "${TRAVIS}" ]; then find logs/ -name '*.log' -not -name 'summary.log' -exec 'bash' '-c' 'echo "travis_fold:start:coq.logs.$$(echo '{}' | sed s,/,.,g)"' ';' -exec cat '{}' ';' -exec 'bash' '-c' 'echo "travis_fold:end:coq.logs.$$(echo '{}' | sed s,/,.,g)"' ';'; fi + $(HIDE)if [ -n "${APPVEYOR}" ]; then find logs/ -name '*.log' -not -name 'summary.log' -exec 'bash' '-c' 'echo {}' ';' -exec cat '{}' ';' -exec 'bash' '-c' 'echo' ';'; fi $(HIDE)if grep -q -F 'Error!' summary.log ; then echo FAILURES; grep -F 'Error!' summary.log; false; else echo NO FAILURES; fi ####################################################################### @@ -293,7 +294,7 @@ $(addsuffix .log,$(wildcard output/*.v)): %.v.log: %.v %.out $(PREREQUISITELOG) | grep -v "^<W>" \ | sed 's/File "[^"]*"/File "stdin"/' \ > $$tmpoutput; \ - diff -u $*.out $$tmpoutput 2>&1; R=$$?; times; \ + diff -u --strip-trailing-cr $*.out $$tmpoutput 2>&1; R=$$?; times; \ if [ $$R = 0 ]; then \ echo $(log_success); \ echo " $<...Ok"; \ @@ -328,7 +329,7 @@ $(addsuffix .log,$(wildcard output-modulo-time/*.v)): %.v.log: %.v %.out -e 's/\s*[-+]inf\s*//g' \ -e 's/^[^a-zA-Z]*//' \ $*.out | sort > $$tmpexpected; \ - diff -b -u $$tmpexpected $$tmpoutput 2>&1; R=$$?; times; \ + diff --strip-trailing-cr -b -u $$tmpexpected $$tmpoutput 2>&1; R=$$?; times; \ if [ $$R = 0 ]; then \ echo $(log_success); \ echo " $<...Ok"; \ @@ -445,7 +446,7 @@ ide : $(patsubst %.fake,%.fake.log,$(wildcard ide/*.fake)) @echo "TEST $<" $(HIDE){ \ echo $(call log_intro,$<); \ - $(BIN)fake_ide $< "$(BIN)coqtop -coqlib $(LIB) -boot -async-proofs on -async-proofs-tactic-error-resilience off -async-proofs-command-error-resilience off" 2>&1; \ + $(BIN)fake_ide $< "-coqlib $(LIB) -boot -async-proofs on -async-proofs-tactic-error-resilience off -async-proofs-command-error-resilience off" 2>&1; \ if [ $$? = 0 ]; then \ echo $(log_success); \ echo " $<...Ok"; \ diff --git a/test-suite/bugs/closed/5641.v b/test-suite/bugs/closed/5641.v new file mode 100644 index 000000000..9f3246f33 --- /dev/null +++ b/test-suite/bugs/closed/5641.v @@ -0,0 +1,6 @@ +Set Universe Polymorphism. + +Definition foo@{i j} (A : Type@{i}) : Type@{j}. +Proof. +abstract (exact ltac:(abstract (exact A))). +Defined. diff --git a/test-suite/bugs/closed/HoTT_coq_123.v b/test-suite/bugs/closed/HoTT_coq_123.v index cd9cad406..7bed956f3 100644 --- a/test-suite/bugs/closed/HoTT_coq_123.v +++ b/test-suite/bugs/closed/HoTT_coq_123.v @@ -104,11 +104,15 @@ Record Functor (C D : PreCategory) := morphism_of : forall s d, morphism C s d -> morphism D (object_of s) (object_of d) }. +(** Workaround to simpl losing universe constraints, see bug #5645. *) +Ltac simpl' := + simpl; match goal with [ |- ?P ] => let T := type of P in idtac end. + Global Instance trunc_forall `{Funext} `{P : A -> Type} `{forall a, IsTrunc n (P a)} : IsTrunc n (forall a, P a) | 100. Proof. generalize dependent P. - induction n as [ | n' IH]; (simpl; intros P ?). + induction n as [ | n' IH]; (simpl'; intros P ?). - admit. - pose (fun f g => trunc_equiv (@apD10 A P f g) ^-1); admit. Defined. diff --git a/test-suite/coq-makefile/arg/run.sh b/test-suite/coq-makefile/arg/run.sh index e98da17c7..e7de90ff2 100755 --- a/test-suite/coq-makefile/arg/run.sh +++ b/test-suite/coq-makefile/arg/run.sh @@ -1,9 +1,7 @@ #!/usr/bin/env bash -#set -x -set -e - . ../template/init.sh coq_makefile -f _CoqProject -o Makefile +cat Makefile.conf make diff --git a/test-suite/coq-makefile/compat-subdirs/run.sh b/test-suite/coq-makefile/compat-subdirs/run.sh index 28d9878f9..221dcd7bf 100755 --- a/test-suite/coq-makefile/compat-subdirs/run.sh +++ b/test-suite/coq-makefile/compat-subdirs/run.sh @@ -1,9 +1,8 @@ #!/usr/bin/env bash -#set -x -set -e - . ../template/init.sh + coq_makefile -f _CoqProject -o Makefile +cat Makefile.conf make exec test -f "subdir/done" diff --git a/test-suite/coq-makefile/coqdoc1/run.sh b/test-suite/coq-makefile/coqdoc1/run.sh index e8291c89d..1feff7479 100755 --- a/test-suite/coq-makefile/coqdoc1/run.sh +++ b/test-suite/coq-makefile/coqdoc1/run.sh @@ -1,17 +1,15 @@ #!/usr/bin/env bash -#set -x -set -e - . ../template/init.sh coq_makefile -f _CoqProject -o Makefile +cat Makefile.conf make make html mlihtml make install DSTROOT="$PWD/tmp" make install-doc DSTROOT="$PWD/tmp" #make debug -(for d in `find tmp -name user-contrib`; do pushd $d >/dev/null; find .; popd >/dev/null; done) | sort -u > actual +(for d in `find tmp -name user-contrib` ; do pushd $d >/dev/null && find . && popd >/dev/null; done) | sort -u > actual sort -u > desired <<EOT . ./test diff --git a/test-suite/coq-makefile/coqdoc2/run.sh b/test-suite/coq-makefile/coqdoc2/run.sh index e8291c89d..1feff7479 100755 --- a/test-suite/coq-makefile/coqdoc2/run.sh +++ b/test-suite/coq-makefile/coqdoc2/run.sh @@ -1,17 +1,15 @@ #!/usr/bin/env bash -#set -x -set -e - . ../template/init.sh coq_makefile -f _CoqProject -o Makefile +cat Makefile.conf make make html mlihtml make install DSTROOT="$PWD/tmp" make install-doc DSTROOT="$PWD/tmp" #make debug -(for d in `find tmp -name user-contrib`; do pushd $d >/dev/null; find .; popd >/dev/null; done) | sort -u > actual +(for d in `find tmp -name user-contrib` ; do pushd $d >/dev/null && find . && popd >/dev/null; done) | sort -u > actual sort -u > desired <<EOT . ./test diff --git a/test-suite/coq-makefile/extend-subdirs/run.sh b/test-suite/coq-makefile/extend-subdirs/run.sh index ea5792a93..221dcd7bf 100755 --- a/test-suite/coq-makefile/extend-subdirs/run.sh +++ b/test-suite/coq-makefile/extend-subdirs/run.sh @@ -1,10 +1,8 @@ #!/usr/bin/env bash -#set -x -set -e - . ../template/init.sh coq_makefile -f _CoqProject -o Makefile +cat Makefile.conf make exec test -f "subdir/done" diff --git a/test-suite/coq-makefile/latex1/run.sh b/test-suite/coq-makefile/latex1/run.sh index 214a9d5b2..b2c5d5669 100755 --- a/test-suite/coq-makefile/latex1/run.sh +++ b/test-suite/coq-makefile/latex1/run.sh @@ -1,13 +1,11 @@ #!/usr/bin/env bash -#set -x -set -e - if which pdflatex; then . ../template/init.sh coq_makefile -f _CoqProject -o Makefile +cat Makefile.conf make exec make all.pdf diff --git a/test-suite/coq-makefile/merlin1/run.sh b/test-suite/coq-makefile/merlin1/run.sh index 752c0c2ce..1f262a939 100755 --- a/test-suite/coq-makefile/merlin1/run.sh +++ b/test-suite/coq-makefile/merlin1/run.sh @@ -1,11 +1,9 @@ #!/usr/bin/env bash -#set -x -set -e - . ../template/init.sh coq_makefile -f _CoqProject -o Makefile +cat Makefile.conf make .merlin cat > desired <<EOT B src diff --git a/test-suite/coq-makefile/mlpack1/run.sh b/test-suite/coq-makefile/mlpack1/run.sh index 10a200dde..51669f28f 100755 --- a/test-suite/coq-makefile/mlpack1/run.sh +++ b/test-suite/coq-makefile/mlpack1/run.sh @@ -1,16 +1,14 @@ #!/usr/bin/env bash -#set -x -set -e - . ../template/init.sh coq_makefile -f _CoqProject -o Makefile +cat Makefile.conf make make html mlihtml make install DSTROOT="$PWD/tmp" #make debug -(cd `find tmp -name user-contrib`; find .) | sort > actual +(cd `find tmp -name user-contrib` && find .) | sort > actual sort > desired <<EOT . ./test diff --git a/test-suite/coq-makefile/mlpack2/run.sh b/test-suite/coq-makefile/mlpack2/run.sh index 10a200dde..51669f28f 100755 --- a/test-suite/coq-makefile/mlpack2/run.sh +++ b/test-suite/coq-makefile/mlpack2/run.sh @@ -1,16 +1,14 @@ #!/usr/bin/env bash -#set -x -set -e - . ../template/init.sh coq_makefile -f _CoqProject -o Makefile +cat Makefile.conf make make html mlihtml make install DSTROOT="$PWD/tmp" #make debug -(cd `find tmp -name user-contrib`; find .) | sort > actual +(cd `find tmp -name user-contrib` && find .) | sort > actual sort > desired <<EOT . ./test diff --git a/test-suite/coq-makefile/multiroot/run.sh b/test-suite/coq-makefile/multiroot/run.sh index 3cd1ac305..d3bb53106 100755 --- a/test-suite/coq-makefile/multiroot/run.sh +++ b/test-suite/coq-makefile/multiroot/run.sh @@ -1,19 +1,17 @@ #!/usr/bin/env bash -#set -x -set -e - . ../template/init.sh cp -r theories theories2 mv src/test_plugin.mlpack src/test_plugin.mllib coq_makefile -f _CoqProject -o Makefile +cat Makefile.conf make make html mlihtml make install DSTROOT="$PWD/tmp" make install-doc DSTROOT="$PWD/tmp" #make debug -(for d in `find tmp -name user-contrib`; do pushd $d >/dev/null; find .; popd >/dev/null; done) | sort -u > actual +(for d in `find tmp -name user-contrib` ; do pushd $d >/dev/null && find . && popd >/dev/null; done) | sort -u > actual sort > desired <<EOT . ./test diff --git a/test-suite/coq-makefile/native1/run.sh b/test-suite/coq-makefile/native1/run.sh index 9f6295d64..3bec11cb7 100755 --- a/test-suite/coq-makefile/native1/run.sh +++ b/test-suite/coq-makefile/native1/run.sh @@ -1,19 +1,17 @@ #!/usr/bin/env bash -#set -x -set -e - NATIVECOMP=`grep "let no_native_compiler = false" ../../../config/coq_config.ml`||true if [[ `which ocamlopt` && $NATIVECOMP ]]; then . ../template/init.sh coq_makefile -f _CoqProject -o Makefile +cat Makefile.conf make make html mlihtml make install DSTROOT="$PWD/tmp" #make debug -(cd `find tmp -name user-contrib`; find .) | sort > actual +(cd `find tmp -name user-contrib` && find .) | sort > actual sort > desired <<EOT . ./test diff --git a/test-suite/coq-makefile/only/run.sh b/test-suite/coq-makefile/only/run.sh index 2ea3deffb..8cf04bf2c 100755 --- a/test-suite/coq-makefile/only/run.sh +++ b/test-suite/coq-makefile/only/run.sh @@ -1,11 +1,9 @@ #!/usr/bin/env bash -#set -x -set -e - . ../template/init.sh coq_makefile -f _CoqProject -o Makefile +cat Makefile.conf make only TGTS="src/test.cmi src/test_aux.cmi" -j2 test -f src/test.cmi test -f src/test_aux.cmi diff --git a/test-suite/coq-makefile/plugin-reach-outside-API-and-fail/run.sh b/test-suite/coq-makefile/plugin-reach-outside-API-and-fail/run.sh index 6301aa03c..88606cd47 100755 --- a/test-suite/coq-makefile/plugin-reach-outside-API-and-fail/run.sh +++ b/test-suite/coq-makefile/plugin-reach-outside-API-and-fail/run.sh @@ -27,6 +27,7 @@ let _ = Pre_env.empty_env EOT ${COQBIN}coq_makefile -f _CoqProject -o Makefile +cat Makefile.conf if make VERBOSE=1; then # make command should have failed (but didn't) diff --git a/test-suite/coq-makefile/plugin-reach-outside-API-and-succeed-by-bypassing-the-API/run.sh b/test-suite/coq-makefile/plugin-reach-outside-API-and-succeed-by-bypassing-the-API/run.sh index 991fb4a61..939ef9c7b 100755 --- a/test-suite/coq-makefile/plugin-reach-outside-API-and-succeed-by-bypassing-the-API/run.sh +++ b/test-suite/coq-makefile/plugin-reach-outside-API-and-succeed-by-bypassing-the-API/run.sh @@ -28,5 +28,6 @@ let _ = Pre_env.empty_env EOT ${COQBIN}coq_makefile -f _CoqProject -o Makefile +cat Makefile.conf make VERBOSE=1 diff --git a/test-suite/coq-makefile/plugin1/run.sh b/test-suite/coq-makefile/plugin1/run.sh index c2d47166f..5433d9e92 100755 --- a/test-suite/coq-makefile/plugin1/run.sh +++ b/test-suite/coq-makefile/plugin1/run.sh @@ -1,17 +1,15 @@ #!/usr/bin/env bash -#set -x -set -e - . ../template/init.sh mv src/test_plugin.mlpack src/test_plugin.mllib coq_makefile -f _CoqProject -o Makefile +cat Makefile.conf make make html mlihtml make install DSTROOT="$PWD/tmp" #make debug -(cd `find tmp -name user-contrib`; find .) | sort > actual +(cd `find tmp -name user-contrib` && find .) | sort > actual sort > desired <<EOT . ./test diff --git a/test-suite/coq-makefile/plugin2/run.sh b/test-suite/coq-makefile/plugin2/run.sh index c2d47166f..5433d9e92 100755 --- a/test-suite/coq-makefile/plugin2/run.sh +++ b/test-suite/coq-makefile/plugin2/run.sh @@ -1,17 +1,15 @@ #!/usr/bin/env bash -#set -x -set -e - . ../template/init.sh mv src/test_plugin.mlpack src/test_plugin.mllib coq_makefile -f _CoqProject -o Makefile +cat Makefile.conf make make html mlihtml make install DSTROOT="$PWD/tmp" #make debug -(cd `find tmp -name user-contrib`; find .) | sort > actual +(cd `find tmp -name user-contrib` && find .) | sort > actual sort > desired <<EOT . ./test diff --git a/test-suite/coq-makefile/plugin3/run.sh b/test-suite/coq-makefile/plugin3/run.sh index c2d47166f..5433d9e92 100755 --- a/test-suite/coq-makefile/plugin3/run.sh +++ b/test-suite/coq-makefile/plugin3/run.sh @@ -1,17 +1,15 @@ #!/usr/bin/env bash -#set -x -set -e - . ../template/init.sh mv src/test_plugin.mlpack src/test_plugin.mllib coq_makefile -f _CoqProject -o Makefile +cat Makefile.conf make make html mlihtml make install DSTROOT="$PWD/tmp" #make debug -(cd `find tmp -name user-contrib`; find .) | sort > actual +(cd `find tmp -name user-contrib` && find .) | sort > actual sort > desired <<EOT . ./test diff --git a/test-suite/coq-makefile/template/init.sh b/test-suite/coq-makefile/template/init.sh index c952d41a3..803fe8029 100755 --- a/test-suite/coq-makefile/template/init.sh +++ b/test-suite/coq-makefile/template/init.sh @@ -1,3 +1,5 @@ +set -e +set -o pipefail export PATH=$COQBIN:$PATH diff --git a/test-suite/coq-makefile/timing/after/Fast.v b/test-suite/coq-makefile/timing/after/Fast.v new file mode 100644 index 000000000..54d3cfc3e --- /dev/null +++ b/test-suite/coq-makefile/timing/after/Fast.v @@ -0,0 +1,4 @@ +Require Coq.ZArith.BinInt. +Definition foo0 := Eval vm_compute in Coq.ZArith.BinInt.Z.div_eucl. +Definition foo1 := Eval vm_compute in Coq.ZArith.BinInt.Z.div_eucl. +Definition foo2 := Eval vm_compute in Coq.ZArith.BinInt.Z.div_eucl. diff --git a/test-suite/coq-makefile/timing/after/Slow.v b/test-suite/coq-makefile/timing/after/Slow.v new file mode 100644 index 000000000..8b1378917 --- /dev/null +++ b/test-suite/coq-makefile/timing/after/Slow.v @@ -0,0 +1 @@ + diff --git a/test-suite/coq-makefile/timing/after/_CoqProject b/test-suite/coq-makefile/timing/after/_CoqProject new file mode 100644 index 000000000..36c3a18c2 --- /dev/null +++ b/test-suite/coq-makefile/timing/after/_CoqProject @@ -0,0 +1,2 @@ +Slow.v +Fast.v diff --git a/test-suite/coq-makefile/timing/after/time-of-build-after.log.desired b/test-suite/coq-makefile/timing/after/time-of-build-after.log.desired new file mode 100644 index 000000000..729de2f36 --- /dev/null +++ b/test-suite/coq-makefile/timing/after/time-of-build-after.log.desired @@ -0,0 +1,16 @@ +Makefile:69: warning: undefined variable '*' +Makefile:204: warning: undefined variable 'DSTROOT' +COQDEP Fast.v +COQDEP Slow.v +Makefile:69: warning: undefined variable '*' +Makefile:204: warning: undefined variable 'DSTROOT' +Makefile:69: warning: undefined variable '*' +Makefile:204: warning: undefined variable 'DSTROOT' +Makefile:69: warning: undefined variable '*' +Makefile:204: warning: undefined variable 'DSTROOT' +COQC Slow.v +Slow (real: 0.04, user: 0.02, sys: 0.01, mem: 45512 ko) +COQC Fast.v +Fast (real: 0.41, user: 0.37, sys: 0.04, mem: 395200 ko) +Makefile:69: warning: undefined variable '*' +Makefile:204: warning: undefined variable 'DSTROOT' diff --git a/test-suite/coq-makefile/timing/after/time-of-build-before.log.desired b/test-suite/coq-makefile/timing/after/time-of-build-before.log.desired new file mode 100644 index 000000000..b25bc3683 --- /dev/null +++ b/test-suite/coq-makefile/timing/after/time-of-build-before.log.desired @@ -0,0 +1,16 @@ +Makefile:69: warning: undefined variable '*' +Makefile:204: warning: undefined variable 'DSTROOT' +COQDEP Fast.v +COQDEP Slow.v +Makefile:69: warning: undefined variable '*' +Makefile:204: warning: undefined variable 'DSTROOT' +Makefile:69: warning: undefined variable '*' +Makefile:204: warning: undefined variable 'DSTROOT' +Makefile:69: warning: undefined variable '*' +Makefile:204: warning: undefined variable 'DSTROOT' +COQC Slow.v +Slow (real: 0.40, user: 0.35, sys: 0.04, mem: 394968 ko) +COQC Fast.v +Fast (real: 0.04, user: 0.03, sys: 0.00, mem: 46564 ko) +Makefile:69: warning: undefined variable '*' +Makefile:204: warning: undefined variable 'DSTROOT' diff --git a/test-suite/coq-makefile/timing/after/time-of-build-both.log.desired b/test-suite/coq-makefile/timing/after/time-of-build-both.log.desired new file mode 100644 index 000000000..56815d241 --- /dev/null +++ b/test-suite/coq-makefile/timing/after/time-of-build-both.log.desired @@ -0,0 +1,6 @@ +After | File Name | Before || Change | % Change +-------------------------------------------------------- +0m00.38s | Total | 0m00.39s || -0m00.01s | -2.56% +-------------------------------------------------------- +0m00.35s | Slow | 0m00.02s || +0m00.32s | +1649.99% +0m00.03s | Fast | 0m00.37s || -0m00.34s | -91.89%
\ No newline at end of file diff --git a/test-suite/coq-makefile/timing/aggregate/Fast.v b/test-suite/coq-makefile/timing/aggregate/Fast.v new file mode 100644 index 000000000..8b1378917 --- /dev/null +++ b/test-suite/coq-makefile/timing/aggregate/Fast.v @@ -0,0 +1 @@ + diff --git a/test-suite/coq-makefile/timing/aggregate/Slow.v b/test-suite/coq-makefile/timing/aggregate/Slow.v new file mode 100644 index 000000000..54d3cfc3e --- /dev/null +++ b/test-suite/coq-makefile/timing/aggregate/Slow.v @@ -0,0 +1,4 @@ +Require Coq.ZArith.BinInt. +Definition foo0 := Eval vm_compute in Coq.ZArith.BinInt.Z.div_eucl. +Definition foo1 := Eval vm_compute in Coq.ZArith.BinInt.Z.div_eucl. +Definition foo2 := Eval vm_compute in Coq.ZArith.BinInt.Z.div_eucl. diff --git a/test-suite/coq-makefile/timing/aggregate/_CoqProject b/test-suite/coq-makefile/timing/aggregate/_CoqProject new file mode 100644 index 000000000..36c3a18c2 --- /dev/null +++ b/test-suite/coq-makefile/timing/aggregate/_CoqProject @@ -0,0 +1,2 @@ +Slow.v +Fast.v diff --git a/test-suite/coq-makefile/timing/before/Fast.v b/test-suite/coq-makefile/timing/before/Fast.v new file mode 100644 index 000000000..8b1378917 --- /dev/null +++ b/test-suite/coq-makefile/timing/before/Fast.v @@ -0,0 +1 @@ + diff --git a/test-suite/coq-makefile/timing/before/Slow.v b/test-suite/coq-makefile/timing/before/Slow.v new file mode 100644 index 000000000..54d3cfc3e --- /dev/null +++ b/test-suite/coq-makefile/timing/before/Slow.v @@ -0,0 +1,4 @@ +Require Coq.ZArith.BinInt. +Definition foo0 := Eval vm_compute in Coq.ZArith.BinInt.Z.div_eucl. +Definition foo1 := Eval vm_compute in Coq.ZArith.BinInt.Z.div_eucl. +Definition foo2 := Eval vm_compute in Coq.ZArith.BinInt.Z.div_eucl. diff --git a/test-suite/coq-makefile/timing/before/_CoqProject b/test-suite/coq-makefile/timing/before/_CoqProject new file mode 100644 index 000000000..36c3a18c2 --- /dev/null +++ b/test-suite/coq-makefile/timing/before/_CoqProject @@ -0,0 +1,2 @@ +Slow.v +Fast.v diff --git a/test-suite/coq-makefile/timing/error/A.v b/test-suite/coq-makefile/timing/error/A.v new file mode 100644 index 000000000..932363a12 --- /dev/null +++ b/test-suite/coq-makefile/timing/error/A.v @@ -0,0 +1 @@ +Check I : I. diff --git a/test-suite/coq-makefile/timing/error/_CoqProject b/test-suite/coq-makefile/timing/error/_CoqProject new file mode 100644 index 000000000..790e05713 --- /dev/null +++ b/test-suite/coq-makefile/timing/error/_CoqProject @@ -0,0 +1 @@ +A.v diff --git a/test-suite/coq-makefile/timing/per-file-after/A.v b/test-suite/coq-makefile/timing/per-file-after/A.v new file mode 100644 index 000000000..851e2b973 --- /dev/null +++ b/test-suite/coq-makefile/timing/per-file-after/A.v @@ -0,0 +1,4 @@ +Require Coq.ZArith.BinInt. +Declare Reduction comp := native_compute. +Definition foo0 := Eval comp in (Coq.ZArith.BinInt.Z.div_eucl, Coq.ZArith.BinInt.Z.div_eucl). +Definition foo1 := Eval comp in (foo0, foo0). diff --git a/test-suite/coq-makefile/timing/per-file-after/A.v.timing.diff.desired b/test-suite/coq-makefile/timing/per-file-after/A.v.timing.diff.desired new file mode 100644 index 000000000..18f0f34b2 --- /dev/null +++ b/test-suite/coq-makefile/timing/per-file-after/A.v.timing.diff.desired @@ -0,0 +1,9 @@ +After | Code | Before || Change | % Change +--------------------------------------------------------------------------------------------------- +0m00.50s | Total | 0m04.17s || -0m03.66s | -87.96% +--------------------------------------------------------------------------------------------------- +0m00.145s | Chars 069 - 162 [Definition~foo0~:=~Eval~comp~i...] | 0m00.192s || -0m00.04s | -24.47% +0m00.126s | Chars 000 - 026 [Require~Coq.ZArith.BinInt.] | 0m00.143s || -0m00.01s | -11.88% + N/A | Chars 027 - 068 [Declare~Reduction~comp~:=~nati...] | 0m00.s || +0m00.00s | N/A +0m00.s | Chars 027 - 068 [Declare~Reduction~comp~:=~vm_c...] | N/A || +0m00.00s | N/A +0m00.231s | Chars 163 - 208 [Definition~foo1~:=~Eval~comp~i...] | 0m03.836s || -0m03.60s | -93.97%
\ No newline at end of file diff --git a/test-suite/coq-makefile/timing/per-file-after/_CoqProject b/test-suite/coq-makefile/timing/per-file-after/_CoqProject new file mode 100644 index 000000000..790e05713 --- /dev/null +++ b/test-suite/coq-makefile/timing/per-file-after/_CoqProject @@ -0,0 +1 @@ +A.v diff --git a/test-suite/coq-makefile/timing/per-file-before/A.v b/test-suite/coq-makefile/timing/per-file-before/A.v new file mode 100644 index 000000000..115c1f95b --- /dev/null +++ b/test-suite/coq-makefile/timing/per-file-before/A.v @@ -0,0 +1,4 @@ +Require Coq.ZArith.BinInt. +Declare Reduction comp := vm_compute. +Definition foo0 := Eval comp in (Coq.ZArith.BinInt.Z.div_eucl, Coq.ZArith.BinInt.Z.div_eucl). +Definition foo1 := Eval comp in (foo0, foo0). diff --git a/test-suite/coq-makefile/timing/per-file-before/_CoqProject b/test-suite/coq-makefile/timing/per-file-before/_CoqProject new file mode 100644 index 000000000..790e05713 --- /dev/null +++ b/test-suite/coq-makefile/timing/per-file-before/_CoqProject @@ -0,0 +1 @@ +A.v diff --git a/test-suite/coq-makefile/timing/run.sh b/test-suite/coq-makefile/timing/run.sh new file mode 100755 index 000000000..9786af10a --- /dev/null +++ b/test-suite/coq-makefile/timing/run.sh @@ -0,0 +1,68 @@ +#!/usr/bin/env bash + +#set -x +set -e + +. ../template/init.sh + +cd error +coq_makefile -f _CoqProject -o Makefile +make cleanall +if make pretty-timed TGTS="all" -j1; then + echo "Error: make pretty-timed should have failed" + exit 1 +fi + +cd ../aggregate +coq_makefile -f _CoqProject -o Makefile +make cleanall +make pretty-timed TGTS="all" -j1 || exit $? + +cd ../before +coq_makefile -f _CoqProject -o Makefile +make cleanall +make make-pretty-timed-before TGTS="all" -j1 || exit $? + +cd ../after +coq_makefile -f _CoqProject -o Makefile +make cleanall +make make-pretty-timed-after TGTS="all" -j1 || exit $? +rm -f time-of-build-before.log +make print-pretty-timed-diff TIME_OF_BUILD_BEFORE_FILE=../before/time-of-build-before.log +cp ../before/time-of-build-before.log ./ +make print-pretty-timed-diff || exit $? + +for ext in "" .desired; do + for file in time-of-build-before.log time-of-build-after.log time-of-build-both.log; do + cat ${file}${ext} | grep -v 'warning: undefined variable' | sed s'/[0-9]//g' | sed s'/ *$//g' | sed s'/^-*$/------/g' | sed s'/ */ /g' | sed s'/\(Total.*\)-\(.*\)-/\1+\2+/g' > ${file}${ext}.processed + done +done +for file in time-of-build-before.log time-of-build-after.log time-of-build-both.log; do + diff -u $file.desired.processed $file.processed || exit $? +done + +cd ../per-file-before +coq_makefile -f _CoqProject -o Makefile +make cleanall +make all TIMING=before -j2 || exit $? + +cd ../per-file-after +coq_makefile -f _CoqProject -o Makefile +make cleanall +make all TIMING=after -j2 || exit $? + +find ../per-file-before/ -name "*.before-timing" -exec 'cp' '{}' './' ';' +make all.timing.diff -j2 || exit $? +cat A.v.timing.diff +echo + +for ext in "" .desired; do + for file in A.v.timing.diff; do + cat ${file}${ext} | sed s'/[0-9]*\.[0-9]*//g' | sed s'/0//g' | sed s'/ */ /g' | sed s'/+/-/g' | sort > ${file}${ext}.processed + done +done +for file in A.v.timing.diff; do + diff -u $file.desired.processed $file.processed || exit $? +done + +exit 0 diff --git a/test-suite/coq-makefile/uninstall1/run.sh b/test-suite/coq-makefile/uninstall1/run.sh index e525e1208..5354f794f 100755 --- a/test-suite/coq-makefile/uninstall1/run.sh +++ b/test-suite/coq-makefile/uninstall1/run.sh @@ -1,11 +1,9 @@ #!/usr/bin/env bash -#set -x -set -e - . ../template/init.sh coq_makefile -f _CoqProject -o Makefile +cat Makefile.conf make make html mlihtml make install DSTROOT="$PWD/tmp" @@ -13,7 +11,7 @@ make install-doc DSTROOT="$PWD/tmp" make uninstall DSTROOT="$PWD/tmp" make uninstall-doc DSTROOT="$PWD/tmp" #make debug -(for d in `find tmp -name user-contrib`; do pushd $d >/dev/null; find .; popd >/dev/null; done) | sort -u > actual +(for d in `find tmp -name user-contrib` ; do pushd $d >/dev/null && find . && popd >/dev/null; done) | sort -u > actual sort -u > desired <<EOT . EOT diff --git a/test-suite/coq-makefile/uninstall2/run.sh b/test-suite/coq-makefile/uninstall2/run.sh index e525e1208..5354f794f 100755 --- a/test-suite/coq-makefile/uninstall2/run.sh +++ b/test-suite/coq-makefile/uninstall2/run.sh @@ -1,11 +1,9 @@ #!/usr/bin/env bash -#set -x -set -e - . ../template/init.sh coq_makefile -f _CoqProject -o Makefile +cat Makefile.conf make make html mlihtml make install DSTROOT="$PWD/tmp" @@ -13,7 +11,7 @@ make install-doc DSTROOT="$PWD/tmp" make uninstall DSTROOT="$PWD/tmp" make uninstall-doc DSTROOT="$PWD/tmp" #make debug -(for d in `find tmp -name user-contrib`; do pushd $d >/dev/null; find .; popd >/dev/null; done) | sort -u > actual +(for d in `find tmp -name user-contrib` ; do pushd $d >/dev/null && find . && popd >/dev/null; done) | sort -u > actual sort -u > desired <<EOT . EOT diff --git a/test-suite/coq-makefile/validate1/run.sh b/test-suite/coq-makefile/validate1/run.sh index aaa4194b3..43bf39de1 100755 --- a/test-suite/coq-makefile/validate1/run.sh +++ b/test-suite/coq-makefile/validate1/run.sh @@ -1,10 +1,8 @@ #!/usr/bin/env bash -#set -x -set -e - . ../template/init.sh coq_makefile -f _CoqProject -o Makefile +cat Makefile.conf make exec make validate diff --git a/test-suite/misc/deps-order.sh b/test-suite/misc/deps-order.sh index 00c5eb1bd..299f49469 100755 --- a/test-suite/misc/deps-order.sh +++ b/test-suite/misc/deps-order.sh @@ -4,7 +4,7 @@ rm -f misc/deps/lib/*.vo misc/deps/client/*.vo tmpoutput=`mktemp /tmp/coqcheck.XXXXXX` $coqdep -R misc/deps/lib lib -R misc/deps/client client misc/deps/client/bar.v 2>&1 | head -n 1 > $tmpoutput -diff -u misc/deps/deps.out $tmpoutput 2>&1 +diff -u --strip-trailing-cr misc/deps/deps.out $tmpoutput 2>&1 R=$? times $coqc -R misc/deps/lib lib misc/deps/lib/foo.v 2>&1 diff --git a/test-suite/modules/polymorphism.v b/test-suite/modules/polymorphism.v new file mode 100644 index 000000000..63eaa382d --- /dev/null +++ b/test-suite/modules/polymorphism.v @@ -0,0 +1,81 @@ +Set Universe Polymorphism. + +(** Tests for module subtyping of polymorphic terms *) + +Module Type S. + +Section Foo. + +Universes i j. +Constraint i <= j. + +Parameter foo : Type@{i} -> Type@{j}. + +End Foo. + +End S. + +(** Same constraints *) + +Module OK_1. + +Definition foo@{i j} (A : Type@{i}) : Type@{j} := A. + +End OK_1. + +Module OK_1_Test : S := OK_1. + +(** More general constraints *) + +Module OK_2. + +Inductive X@{i} : Type@{i} :=. +Definition foo@{i j} (A : Type@{i}) : Type@{j} := X@{j}. + +End OK_2. + +Module OK_2_Test : S := OK_2. + +(** Wrong instance length *) + +Module KO_1. + +Definition foo@{i} (A : Type@{i}) : Type@{i} := A. + +End KO_1. + +Fail Module KO_Test_1 : S := KO_1. + +(** Less general constraints *) + +Module KO_2. + +Section Foo. + +Universe i j. +Constraint i < j. + +Definition foo (A : Type@{i}) : Type@{j} := A. + +End Foo. + +End KO_2. + +Fail Module KO_Test_2 : S := KO_2. + +(** Less general constraints *) + +Module KO_3. + +Section Foo. + +Universe i j. +Constraint i = j. + +Definition foo (A : Type@{i}) : Type@{j} := A. + +End Foo. + +End KO_3. + +Fail Module KO_Test_3 : S := KO_3. diff --git a/test-suite/modules/polymorphism2.v b/test-suite/modules/polymorphism2.v new file mode 100644 index 000000000..7e3327eee --- /dev/null +++ b/test-suite/modules/polymorphism2.v @@ -0,0 +1,87 @@ +Set Universe Polymorphism. + +(** Tests for module subtyping of polymorphic terms *) + +Module Type S. + +Section Foo. + +Universes i j. +Constraint i <= j. + +Inductive foo : Type@{i} -> Type@{j} :=. + +End Foo. + +End S. + +(** Same constraints *) + +Module OK_1. + +Section Foo. + +Universes i j. +Constraint i <= j. + +Inductive foo : Type@{i} -> Type@{j} :=. + +End Foo. + +End OK_1. + +Module OK_1_Test : S := OK_1. + +(** More general constraints *) + +Module OK_2. + +Inductive foo@{i j} : Type@{i} -> Type@{j} :=. + +End OK_2. + +Module OK_2_Test : S := OK_2. + +(** Wrong instance length *) + +Module KO_1. + +Inductive foo@{i} : Type@{i} -> Type@{i} :=. + +End KO_1. + +Fail Module KO_Test_1 : S := KO_1. + +(** Less general constraints *) + +Module KO_2. + +Section Foo. + +Universe i j. +Constraint i < j. + +Inductive foo : Type@{i} -> Type@{j} :=. + +End Foo. + +End KO_2. + +Fail Module KO_Test_2 : S := KO_2. + +(** Less general constraints *) + +Module KO_3. + +Section Foo. + +Universe i j. +Constraint i = j. + +Inductive foo : Type@{i} -> Type@{j} :=. + +End Foo. + +End KO_3. + +Fail Module KO_Test_3 : S := KO_3. diff --git a/test-suite/output/TypeclassDebug.out b/test-suite/output/TypeclassDebug.out new file mode 100644 index 000000000..73369ab71 --- /dev/null +++ b/test-suite/output/TypeclassDebug.out @@ -0,0 +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 +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/test-suite/output/TypeclassDebug.v b/test-suite/output/TypeclassDebug.v new file mode 100644 index 000000000..d38e2a50e --- /dev/null +++ b/test-suite/output/TypeclassDebug.v @@ -0,0 +1,8 @@ +(* show alternating separators in typeclass debug output; see discussion in PR #868 *) + +Parameter foo : Prop. +Axiom H : foo -> foo. +Hint Resolve H : foo. +Goal foo. +Typeclasses eauto := debug. +Fail typeclasses eauto 5 with foo. diff --git a/test-suite/output/Warnings.out b/test-suite/output/Warnings.out new file mode 100644 index 000000000..a70f8ca45 --- /dev/null +++ b/test-suite/output/Warnings.out @@ -0,0 +1,3 @@ +File "stdin", line 4, characters 0-22: +Warning: Projection value has no head constant: fun x : B => x in canonical +instance a of b, ignoring it. [projection-no-head-constant,typechecker] diff --git a/test-suite/output/Warnings.v b/test-suite/output/Warnings.v new file mode 100644 index 000000000..7465442ca --- /dev/null +++ b/test-suite/output/Warnings.v @@ -0,0 +1,5 @@ +(* Term in warning was not printed in the right environment at some time *) +Record A := { B:Type; b:B->B }. +Definition a B := {| B:=B; b:=fun x => x |}. +Canonical Structure a. + diff --git a/test-suite/output/inference.v b/test-suite/output/inference.v index f761a4dc5..73169dae6 100644 --- a/test-suite/output/inference.v +++ b/test-suite/output/inference.v @@ -14,6 +14,7 @@ Definition P (e:option L) := Print P. (* Check that plus is folded even if reduction is involved *) +Set Warnings Append "-deprecated-option". Set Refolding Reduction. Check (fun m n p (H : S m <= (S n) + p) => le_S_n _ _ H). diff --git a/test-suite/success/Hints.v b/test-suite/success/Hints.v index 1abe14774..6962e43e7 100644 --- a/test-suite/success/Hints.v +++ b/test-suite/success/Hints.v @@ -37,7 +37,6 @@ Hint Resolve predf | 0 : predconv. Goal exists n, pred n. eexists. - Fail Timeout 1 typeclasses eauto with pred. Set Typeclasses Filtered Unification. Set Typeclasses Debug Verbosity 2. (* predf is not tried as it doesn't match the goal *) @@ -80,8 +79,6 @@ Qed. (** The other way around: goal contains redexes instead of instances *) Goal exists n, pred (0 + n). eexists. - (* predf is applied indefinitely *) - Fail Timeout 1 typeclasses eauto with pred. (* pred0 (pred _) matches the goal *) typeclasses eauto with predconv. Qed. @@ -169,8 +166,6 @@ Instance foo f : E (id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ f ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id). Proof. - Fail Timeout 1 apply _. (* 3.7s *) - Hint Cut [_* (a_is_b | b_is_c | c_is_d | d_is_e) (a_compose | b_compose | c_compose | d_compose | e_compose)] : typeclass_instances. diff --git a/test-suite/success/abstract_poly.v b/test-suite/success/abstract_poly.v new file mode 100644 index 000000000..b736b734f --- /dev/null +++ b/test-suite/success/abstract_poly.v @@ -0,0 +1,20 @@ +Set Universe Polymorphism. + +Inductive path@{i} {A : Type@{i}} (x : A) : A -> Type@{i} := refl : path x x. +Inductive unit@{i} : Type@{i} := tt. + +Lemma foo@{i j} : forall (m n : unit@{i}) (P : unit -> Type@{j}), path m n -> P m -> P n. +Proof. +intros m n P e p. +abstract (rewrite e in p; exact p). +Defined. + +Check foo_subproof@{Set Set}. + +Lemma bar : forall (m n : unit) (P : unit -> Type), path m n -> P m -> P n. +Proof. +intros m n P e p. +abstract (rewrite e in p; exact p). +Defined. + +Check bar_subproof@{Set Set Set}. diff --git a/theories/Init/Datatypes.v b/theories/Init/Datatypes.v index 99937e8e0..22e10e2e4 100644 --- a/theories/Init/Datatypes.v +++ b/theories/Init/Datatypes.v @@ -336,7 +336,7 @@ Proof. intros. apply CompareSpec2Type; assumption. Defined. (** [identity A a] is the family of datatypes on [A] whose sole non-empty member is the singleton datatype [identity A a a] whose - sole inhabitant is denoted [refl_identity A a] *) + sole inhabitant is denoted [identity_refl A a] *) Inductive identity (A:Type) (a:A) : A -> Type := identity_refl : identity a a. diff --git a/tools/CoqMakefile.in b/tools/CoqMakefile.in index c4afc930a..f1e519d03 100644 --- a/tools/CoqMakefile.in +++ b/tools/CoqMakefile.in @@ -10,6 +10,7 @@ INITIAL_VARS := $(.VARIABLES) # To implement recursion we save the name of the main Makefile SELF := $(lastword $(MAKEFILE_LIST)) +PARENT := $(firstword $(MAKEFILE_LIST)) # This file is generated by coq_makefile and contains many variable # definitions, like the list of .v files or the path to Coq @@ -62,7 +63,21 @@ VERBOSE ?= # Time the Coq process (set to non empty), and how (see default value) TIMED?= TIMECMD?= -STDTIME?=/usr/bin/time -f "$* (user: %U mem: %M ko)" +# Use /usr/bin/time on linux, gtime on Mac OS +TIMEFMT?="$* (real: %e, user: %U, sys: %S, mem: %M ko)" +ifneq (,$(TIMED)) +ifeq (0,$(shell /usr/bin/time -f $(TIMEFMT) true >/dev/null 2>/dev/null; echo $$?)) +STDTIME?=/usr/bin/time -f $(TIMEFMT) +else +ifeq (0,$(shell gtime -f $(TIMEFMT) true >/dev/null 2>/dev/null; echo $$?)) +STDTIME?=gtime -f $(TIMEFMT) +else +STDTIME?=time +endif +endif +else +STDTIME?=/usr/bin/time -f $(TIMEFMT) +endif # Coq binaries COQC ?= "$(COQBIN)coqc" @@ -72,6 +87,14 @@ COQDEP ?= "$(COQBIN)coqdep" GALLINA ?= "$(COQBIN)gallina" COQDOC ?= "$(COQBIN)coqdoc" COQMKTOP ?= "$(COQBIN)coqmktop" +COQMKFILE ?= "$(COQBIN)coq_makefile" + +# Timing scripts +COQMAKE_ONE_TIME_FILE ?= "$(COQLIB)/tools/make-one-time-file.py" +COQMAKE_BOTH_TIME_FILES ?= "$(COQLIB)/tools/make-both-time-files.py" +COQMAKE_BOTH_SINGLE_TIMING_FILES ?= "$(COQLIB)/tools/make-both-single-timing-files.py" +BEFORE ?= +AFTER ?= # OCaml binaries CAMLC ?= "$(OCAMLFIND)" ocamlc -c -rectypes -thread @@ -88,7 +111,15 @@ DESTDIR ?= CAMLDEBUG ?= COQDEBUG ?= - +# Option for making timing files +TIMING?= +# Output file names for timed builds +TIME_OF_BUILD_FILE ?= time-of-build.log +TIME_OF_BUILD_BEFORE_FILE ?= time-of-build-before.log +TIME_OF_BUILD_AFTER_FILE ?= time-of-build-after.log +TIME_OF_PRETTY_BUILD_FILE ?= time-of-build-pretty.log +TIME_OF_PRETTY_BOTH_BUILD_FILE ?= time-of-build-both.log +TIME_OF_PRETTY_BUILD_EXTRA_FILES ?= - # also output to the command line ########## End of parameters ################################################## # What follows may be relevant to you only if you need to @@ -153,15 +184,32 @@ endif PP:=-pp '$(CAMLP4O) -I $(CAMLLIB) -I "$(COQLIB)/grammar" compat5.cmo $(CAMLP4EXTEND) $(GRAMMARS) $(CAMLP4OPTIONS) -impl' -COQLIBINSTALL = $(COQLIB)user-contrib -COQDOCINSTALL = $(DOCDIR)user-contrib -COQTOPINSTALL = $(COQLIB)toploop +ifneq (,$(TIMING)) +TIMING_ARG=-time +ifeq (after,$(TIMING)) +TIMING_EXT=after-timing +else +ifeq (before,$(TIMING)) +TIMING_EXT=before-timing +else +TIMING_EXT=timing +endif +endif +else +TIMING_ARG= +endif # Retro compatibility (DESTDIR is standard on Unix, DESTROOT is not) ifneq "$(DSTROOT)" "" DESTDIR := $(DSTROOT) endif +concat_path = $(if $(1),$(1)/$(subst $(COQMF_WINDRIVE),/,$(2)),$(2)) + +COQLIBINSTALL = $(call concat_path,$(DESTDIR),$(COQLIB)user-contrib) +COQDOCINSTALL = $(call concat_path,$(DESTDIR),$(DOCDIR)user-contrib) +COQTOPINSTALL = $(call concat_path,$(DESTDIR),$(COQLIB)toploop) + # Files ####################################################################### # # We here define a bunch of variables about the files being part of the @@ -256,6 +304,41 @@ all: $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" post-all .PHONY: all +all.timing.diff: + $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" pre-all + $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" real-all.timing.diff TIME_OF_PRETTY_BUILD_EXTRA_FILES="" + $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" post-all +.PHONY: all.timing.diff + +make-pretty-timed-before:: TIME_OF_BUILD_FILE=$(TIME_OF_BUILD_BEFORE_FILE) +make-pretty-timed-after:: TIME_OF_BUILD_FILE=$(TIME_OF_BUILD_AFTER_FILE) +make-pretty-timed make-pretty-timed-before make-pretty-timed-after:: + $(HIDE)rm -f pretty-timed-success.ok + $(HIDE)($(MAKE) --no-print-directory -f "$(PARENT)" $(TGTS) TIMED=1 2>&1 && touch pretty-timed-success.ok) | tee -a $(TIME_OF_BUILD_FILE) + $(HIDE)rm pretty-timed-success.ok # must not be -f; must fail if the touch failed +print-pretty-timed:: + $(HIDE)$(COQMAKE_ONE_TIME_FILE) $(TIME_OF_BUILD_FILE) $(TIME_OF_PRETTY_BUILD_FILE) $(TIME_OF_PRETTY_BUILD_EXTRA_FILES) +print-pretty-timed-diff:: + $(HIDE)$(COQMAKE_BOTH_TIME_FILES) $(TIME_OF_BUILD_BEFORE_FILE) $(TIME_OF_BUILD_AFTER_FILE) $(TIME_OF_PRETTY_BOTH_BUILD_FILE) $(TIME_OF_PRETTY_BUILD_EXTRA_FILES) +ifeq (,$(BEFORE)) +print-pretty-single-time-diff:: + @echo 'Error: Usage: $(MAKE) print-pretty-single-time-diff BEFORE=path/to/file.v.before-timing AFTER=path/to/file.v.after-timing' + $(HIDE)false +else +ifeq (,$(AFTER)) +print-pretty-single-time-diff:: + @echo 'Error: Usage: $(MAKE) print-pretty-single-time-diff BEFORE=path/to/file.v.before-timing AFTER=path/to/file.v.after-timing' + $(HIDE)false +else +print-pretty-single-time-diff:: + $(HIDE)$(COQMAKE_BOTH_SINGLE_TIMING_FILES) $(BEFORE) $(AFTER) $(TIME_OF_PRETTY_BUILD_FILE) $(TIME_OF_PRETTY_BUILD_EXTRA_FILES) +endif +endif +pretty-timed: + $(HIDE)$(MAKE) --no-print-directory -f "$(PARENT)" make-pretty-timed + $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" print-pretty-timed +.PHONY: pretty-timed make-pretty-timed make-pretty-timed-before make-pretty-timed-after print-pretty-timed print-pretty-timed-diff print-pretty-single-time-diff + # Extension points for actions to be performed before/after the all target pre-all:: @# Extension point @@ -272,6 +355,9 @@ post-all:: real-all: $(VOFILES) $(if $(USEBYTE),bytefiles,optfiles) .PHONY: real-all +real-all.timing.diff: $(VOFILES:.vo=.v.timing.diff) +.PHONE: real-all.timing.diff + bytefiles: $(CMOFILES) $(CMAFILES) .PHONY: bytefiles @@ -356,13 +442,13 @@ beautify: $(BEAUTYFILES) install: install-extra $(HIDE)for f in $(FILESTOINSTALL); do\ - df="`$(COQMF_MAKEFILE) -destination-of "$$f" $(COQLIBS)`";\ - if [ -z "$$df" ]; then\ + df="`$(COQMKFILE) -destination-of "$$f" $(COQLIBS)`";\ + if [ "$$?" != "0" -o -z "$$df" ]; then\ echo SKIP "$$f" since it has no logical path;\ else\ - install -d "$(DESTDIR)$(COQLIBINSTALL)/$$df"; \ - install -m 0644 "$$f" "$(DESTDIR)$(COQLIBINSTALL)/$$df"; \ - echo INSTALL "$$f" "$(DESTDIR)$(COQLIBINSTALL)/$$df";\ + install -d "$(COQLIBINSTALL)/$$df" &&\ + install -m 0644 "$$f" "$(COQLIBINSTALL)/$$df" &&\ + echo INSTALL "$$f" "$(COQLIBINSTALL)/$$df";\ fi;\ done install-extra:: @@ -371,28 +457,28 @@ install-extra:: install-byte: $(HIDE)for f in $(BYTEFILESTOINSTALL); do\ - df="`$(COQMF_MAKEFILE) -destination-of "$$f" $(COQLIBS)`";\ - if [ -z "$$df" ]; then\ + df="`$(COQMKFILE) -destination-of "$$f" $(COQLIBS)`";\ + if [ "$$?" != "0" -o -z "$$df" ]; then\ echo SKIP "$$f" since it has no logical path;\ else\ - install -d "$(DESTDIR)$(COQLIBINSTALL)/$$df"; \ - install -m 0644 "$$f" "$(DESTDIR)$(COQLIBINSTALL)/$$df"; \ - echo INSTALL "$$f" "$(DESTDIR)$(COQLIBINSTALL)/$$df";\ + install -d "$(COQLIBINSTALL)/$$df" &&\ + install -m 0644 "$$f" "$(COQLIBINSTALL)/$$df" &&\ + echo INSTALL "$$f" "$(COQLIBINSTALL)/$$df";\ fi;\ done install-doc:: html mlihtml @# Extension point - $(HIDE)install -d "$(DESTDIR)$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/html" + $(HIDE)install -d "$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/html" $(HIDE)for i in html/*; do \ - dest="$(DESTDIR)$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/$$i";\ + dest="$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/$$i";\ install -m 0644 "$$i" "$$dest";\ echo INSTALL "$$i" "$$dest";\ done $(HIDE)install -d \ - "$(DESTDIR)$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/mlihtml" + "$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/mlihtml" $(HIDE)for i in mlihtml/*; do \ - dest="$(DESTDIR)$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/$$i";\ + dest="$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/$$i";\ install -m 0644 "$$i" "$$dest";\ echo INSTALL "$$i" "$$dest";\ done @@ -401,21 +487,21 @@ install-doc:: html mlihtml uninstall:: @# Extension point $(HIDE)for f in $(FILESTOINSTALL); do \ - df="`$(COQMF_MAKEFILE) -destination-of "$$f" $(COQLIBS)`";\ - instf="$(DESTDIR)$(COQLIBINSTALL)/$$df/`basename $$f`"; \ - rm -f "$$instf";\ - echo RM "$$instf"; \ - rmdir "$(DESTDIR)$(COQLIBINSTALL)/$$df/" || true; \ + df="`$(COQMKFILE) -destination-of "$$f" $(COQLIBS)`" &&\ + instf="$(COQLIBINSTALL)/$$df/`basename $$f`" &&\ + rm -f "$$instf" &&\ + echo RM "$$instf" &&\ + (rmdir "$(call concat_path,,$(COQLIBINSTALL)/$$df/)" || true); \ done .PHONY: uninstall uninstall-doc:: @# Extension point - $(SHOW)'RM $(DESTDIR)$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/html' - $(HIDE)rm -rf "$(DESTDIR)$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/html" - $(SHOW)'RM $(DESTDIR)$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/mlihtml' - $(HIDE)rm -rf "$(DESTDIR)$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/mlihtml" - $(HIDE) rmdir "$(DESTDIR)$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/" || true + $(SHOW)'RM $(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/html' + $(HIDE)rm -rf "$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/html" + $(SHOW)'RM $(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/mlihtml' + $(HIDE)rm -rf "$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/mlihtml" + $(HIDE) rmdir "$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/" || true .PHONY: uninstall-doc # Cleaning #################################################################### @@ -445,13 +531,19 @@ clean:: $(HIDE)rm -f $(VFILES:.v=.glob) $(HIDE)rm -f $(VFILES:.v=.tex) $(HIDE)rm -f $(VFILES:.v=.g.tex) + $(HIDE)rm -f pretty-timed-success.ok $(HIDE)rm -rf html mlihtml .PHONY: clean cleanall:: clean @# Extension point - $(SHOW)'CLEAN *.aux' + $(SHOW)'CLEAN *.aux *.timing' $(HIDE)rm -f $(foreach f,$(VFILES:.v=),$(dir $(f)).$(notdir $(f)).aux) + $(HIDE)rm -f $(TIME_OF_BUILD_FILE) $(TIME_OF_BUILD_BEFORE_FILE) $(TIME_OF_BUILD_AFTER_FILE) $(TIME_OF_PRETTY_BUILD_FILE) $(TIME_OF_PRETTY_BOTH_BUILD_FILE) + $(HIDE)rm -f $(VOFILES:.vo=.v.timing) + $(HIDE)rm -f $(VOFILES:.vo=.v.before-timing) + $(HIDE)rm -f $(VOFILES:.vo=.v.after-timing) + $(HIDE)rm -f $(VOFILES:.vo=.v.timing.diff) .PHONY: cleanall archclean:: @@ -520,9 +612,15 @@ $(filter-out $(MLLIBFILES:.mllib=.cmxs) $(MLPACKFILES:.mlpack=.cmxs) $(addsuffix $(SHOW)'[deprecated,use-mllib-or-mlpack] CAMLOPT -shared -o $@' $(HIDE)$(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) -shared -o $@ $< +ifneq (,$(TIMING)) +TIMING_EXTRA = > $<.$(TIMING_EXT) +else +TIMING_EXTRA = +endif + $(VOFILES): %.vo: %.v $(SHOW)COQC $< - $(HIDE)$(TIMER) $(COQC) $(COQDEBUG) $(COQFLAGS) $< + $(HIDE)$(TIMER) $(COQC) $(COQDEBUG) $(TIMING_ARG) $(COQFLAGS) $< $(TIMING_EXTRA) # FIXME ?merge with .vo / .vio ? $(GLOBFILES): %.glob: %.v @@ -532,6 +630,10 @@ $(VFILES:.v=.vio): %.vio: %.v $(SHOW)COQC -quick $< $(HIDE)$(TIMER) $(COQC) -quick $(COQDEBUG) $(COQFLAGS) $< +$(addsuffix .timing.diff,$(VFILES)): %.timing.diff : %.before-timing %.after-timing + $(SHOW)PYTHON TIMING-DIFF $< + $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" print-pretty-single-time-diff BEFORE=$*.before-timing AFTER=$*.after-timing TIME_OF_PRETTY_BUILD_FILE="$@" + $(BEAUTYFILES): %.v.beautified: %.v $(SHOW)'BEAUTIFY $<' $(HIDE)$(TIMER) $(COQC) $(COQDEBUG) $(COQFLAGS) -beautify $< @@ -558,7 +660,7 @@ $(GHTMLFILES): %.g.html: %.v %.glob # Dependency files ############################################################ -ifneq ($(filter-out archclean clean cleanall printenv,$(MAKECMDGOALS)),) +ifneq ($(filter-out archclean clean cleanall printenv make-pretty-timed make-pretty-timed-before make-pretty-timed-after print-pretty-timed print-pretty-timed-diff print-pretty-single-time-diff,$(MAKECMDGOALS)),) -include $(ALLDFILES) else ifeq ($(MAKECMDGOALS),) diff --git a/tools/TimeFileMaker.py b/tools/TimeFileMaker.py new file mode 100644 index 000000000..a207c2171 --- /dev/null +++ b/tools/TimeFileMaker.py @@ -0,0 +1,187 @@ +#!/usr/bin/env python +from __future__ import with_statement +import os, sys, re + +# This script parses the output of `make TIMED=1` into a dictionary +# mapping names of compiled files to the number of minutes and seconds +# that they took to compile. + +STRIP_REG = re.compile('^(coq/|contrib/|)(?:theories/|src/)?') +STRIP_REP = r'\1' +INFINITY = '\xe2\x88\x9e' + +def reformat_time_string(time): + seconds, milliseconds = time.split('.') + seconds = int(seconds) + minutes, seconds = int(seconds / 60), seconds % 60 + return '%dm%02d.%ss' % (minutes, seconds, milliseconds) + +def get_times(file_name): + ''' + Reads the contents of file_name, which should be the output of + 'make TIMED=1', and parses it to construct a dict mapping file + names to compile durations, as strings. Removes common prefixes + using STRIP_REG and STRIP_REP. + ''' + if file_name == '-': + lines = sys.stdin.read() + else: + with open(file_name, 'r') as f: + lines = f.read() + reg = re.compile(r'^([^\s]+) \([^\)]*?user: ([0-9\.]+)[^\)]*?\)$', re.MULTILINE) + times = reg.findall(lines) + if all(time in ('0.00', '0.01') for name, time in times): + reg = re.compile(r'^([^\s]*) \([^\)]*?real: ([0-9\.]+)[^\)]*?\)$', re.MULTILINE) + times = reg.findall(lines) + if all(STRIP_REG.search(name.strip()) for name, time in times): + times = tuple((STRIP_REG.sub(STRIP_REP, name.strip()), time) for name, time in times) + return dict((name, reformat_time_string(time)) for name, time in times) + +def get_single_file_times(file_name): + ''' + Reads the contents of file_name, which should be the output of + 'coqc -time', and parses it to construct a dict mapping lines to + to compile durations, as strings. + ''' + if file_name == '-': + lines = sys.stdin.read() + else: + with open(file_name, 'r') as f: + lines = f.read() + reg = re.compile(r'^Chars ([0-9]+) - ([0-9]+) ([^ ]+) ([0-9\.]+) secs (.*)$', re.MULTILINE) + times = reg.findall(lines) + if len(times) == 0: return dict() + longest = max(max((len(start), len(stop))) for start, stop, name, time, extra in times) + FORMAT = 'Chars %%0%dd - %%0%dd %%s' % (longest, longest) + return dict((FORMAT % (int(start), int(stop), name), reformat_time_string(time)) for start, stop, name, time, extra in times) + +def make_sorting_key(times_dict, descending=True): + def get_key(name): + minutes, seconds = times_dict[name].replace('s', '').split('m') + def fix_sign(num): + return -num if descending else num + return (fix_sign(int(minutes)), fix_sign(float(seconds)), name) + return get_key + +def get_sorted_file_list_from_times_dict(times_dict, descending=True): + ''' + Takes the output dict of get_times and returns the list of keys, + sorted by duration. + ''' + return sorted(times_dict.keys(), key=make_sorting_key(times_dict, descending=descending)) + +def to_seconds(time): + ''' + Converts a string time into a number of seconds. + ''' + minutes, seconds = time.replace('s', '').split('m') + sign = -1 if time[0] == '-' else 1 + return sign * (abs(int(minutes)) * 60 + float(seconds)) + +def from_seconds(seconds, signed=False): + ''' + Converts a number of seconds into a string time. + ''' + sign = ('-' if seconds < 0 else '+') if signed else '' + seconds = abs(seconds) + minutes = int(seconds) / 60 + seconds -= minutes * 60 + full_seconds = int(seconds) + partial_seconds = int(100 * (seconds - full_seconds)) + return sign + '%dm%02d.%02ds' % (minutes, full_seconds, partial_seconds) + +def sum_times(times, signed=False): + ''' + Takes the values of an output from get_times, parses the time + strings, and returns their sum, in the same string format. + ''' + return from_seconds(sum(map(to_seconds, times)), signed=signed) + +def format_percentage(num, signed=True): + sign = ('-' if num < 0 else '+') if signed else '' + num = abs(num) + whole_part = int(num * 100) + frac_part = int(100 * (num * 100 - whole_part)) + return sign + '%d.%02d%%' % (whole_part, frac_part) + +def make_diff_table_string(left_times_dict, right_times_dict, + descending=True, + left_tag="After", tag="File Name", right_tag="Before", with_percent=True, + change_tag="Change", percent_change_tag="% Change"): + # We first get the names of all of the compiled files: all files + # that were compiled either before or after. + all_names_dict = dict() + all_names_dict.update(right_times_dict) + all_names_dict.update(left_times_dict) # do the left (after) last, so that we give precedence to those ones + if len(all_names_dict.keys()) == 0: return 'No timing data' + prediff_times = tuple((name, to_seconds(left_times_dict.get(name,'0m0.0s')), to_seconds(right_times_dict.get(name,'0m0.0s'))) + for name in all_names_dict.keys()) + diff_times_dict = dict((name, from_seconds(lseconds - rseconds, signed=True)) + for name, lseconds, rseconds in prediff_times) + percent_diff_times_dict = dict((name, ((format_percentage((lseconds - rseconds) / rseconds)) + if rseconds != 0 else (INFINITY if lseconds > 0 else 'N/A'))) + for name, lseconds, rseconds in prediff_times) + # update to sort by approximate difference, first + get_key = make_sorting_key(all_names_dict, descending=descending) + all_names_dict = dict((name, (abs(int(to_seconds(diff_times_dict[name]))), get_key(name))) + for name in all_names_dict.keys()) + names = sorted(all_names_dict.keys(), key=all_names_dict.get) + #names = get_sorted_file_list_from_times_dict(all_names_dict, descending=descending) + # set the widths of each of the columns by the longest thing to go in that column + left_sum = sum_times(left_times_dict.values()) + right_sum = sum_times(right_times_dict.values()) + left_sum_float = sum(map(to_seconds, left_times_dict.values())) + right_sum_float = sum(map(to_seconds, right_times_dict.values())) + diff_sum = from_seconds(left_sum_float - right_sum_float, signed=True) + percent_diff_sum = (format_percentage((left_sum_float - right_sum_float) / right_sum_float) + if right_sum_float > 0 else 'N/A') + left_width = max(max(map(len, ['N/A'] + list(left_times_dict.values()))), len(left_sum)) + right_width = max(max(map(len, ['N/A'] + list(right_times_dict.values()))), len(right_sum)) + far_right_width = max(max(map(len, ['N/A', change_tag] + list(diff_times_dict.values()))), len(diff_sum)) + far_far_right_width = max(max(map(len, ['N/A', percent_change_tag] + list(percent_diff_times_dict.values()))), len(percent_diff_sum)) + middle_width = max(map(len, names + [tag, "Total"])) + format_string = ("%%(left)-%ds | %%(middle)-%ds | %%(right)-%ds || %%(far_right)-%ds" + % (left_width, middle_width, right_width, far_right_width)) + if with_percent: + format_string += " | %%(far_far_right)-%ds" % far_far_right_width + header = format_string % {'left': left_tag, 'middle': tag, 'right': right_tag, 'far_right': change_tag, 'far_far_right': percent_change_tag} + total = format_string % {'left': left_sum, 'middle': "Total", 'right': right_sum, 'far_right': diff_sum, 'far_far_right': percent_diff_sum} + # separator to go between headers and body + sep = '-' * len(header) + # the representation of the default value (0), to get replaced by N/A + left_rep, right_rep, far_right_rep, far_far_right_rep = ("%%-%ds | " % left_width) % 0, (" | %%-%ds || " % right_width) % 0, ("|| %%-%ds" % far_right_width) % 0, ("| %%-%ds" % far_far_right_width) % 0 + return '\n'.join([header, sep, total, sep] + + [format_string % {'left': left_times_dict.get(name, 0), + 'middle': name, + 'right': right_times_dict.get(name, 0), + 'far_right': diff_times_dict.get(name, 0), + 'far_far_right': percent_diff_times_dict.get(name, 0)} + for name in names]).replace(left_rep, 'N/A'.center(len(left_rep) - 3) + ' | ').replace(right_rep, ' | ' + 'N/A'.center(len(right_rep) - 7) + ' || ').replace(far_right_rep, '|| ' + 'N/A'.center(len(far_right_rep) - 3)).replace(far_far_right_rep, '| ' + 'N/A'.center(len(far_far_right_rep) - 2)) + +def make_table_string(times_dict, + descending=True, + tag="Time"): + if len(times_dict.keys()) == 0: return 'No timing data' + # We first get the names of all of the compiled files, sorted by + # duration + names = get_sorted_file_list_from_times_dict(times_dict, descending=descending) + # compute the widths of the columns + times_width = max(max(map(len, times_dict.values())), len(sum_times(times_dict.values()))) + names_width = max(map(len, names + ["File Name", "Total"])) + format_string = "%%-%ds | %%-%ds" % (times_width, names_width) + header = format_string % (tag, "File Name") + total = format_string % (sum_times(times_dict.values()), + "Total") + sep = '-' * len(header) + return '\n'.join([header, sep, total, sep] + + [format_string % (times_dict[name], + name) + for name in names]) + +def print_or_write_table(table, files): + if len(files) == 0 or '-' in files: + print(table) + for file_name in files: + if file_name != '-': + with open(file_name, 'w') as f: + f.write(table) diff --git a/tools/coq_makefile.ml b/tools/coq_makefile.ml index 43f7670a6..327f53520 100644 --- a/tools/coq_makefile.ml +++ b/tools/coq_makefile.ml @@ -118,7 +118,7 @@ let makefile_template = let template = "/tools/CoqMakefile.in" in Coq_config.coqlib ^ template -let quote s = if String.contains s ' ' then "\"" ^ s ^ "\"" else s +let quote s = if String.contains s ' ' then "'" ^ s ^ "'" else s let generate_makefile oc conf_file local_file args project = let s = read_whole_file makefile_template in @@ -193,13 +193,19 @@ let generate_conf_includes oc { ml_includes; r_includes; q_includes } = (S.concat " " (map (fun ({ path },l) -> dash2 "R" path l) r_includes)) ;; +let windrive s = + if Coq_config.arch_is_win32 && Str.(string_match (regexp "^[a-zA-Z]:") s 0) + then Str.matched_string s + else s +;; + let generate_conf_coq_config oc args bypass_API = section oc "Coq configuration."; let src_dirs = if bypass_API then Coq_config.all_src_dirs - else Coq_config.api_dirs @ Coq_config.plugins_dirs in + else Coq_config.api_dirs @ Coq_config.plugins_dirs @ ["-open API"] in Envars.print_config ~prefix_var_name:"COQMF_" oc src_dirs; - fprintf oc "COQMF_MAKEFILE=%s\n" (quote (List.hd args)); + fprintf oc "COQMF_WINDRIVE=%s\n" (windrive Coq_config.coqlib) ;; let generate_conf_files oc diff --git a/tools/fake_ide.ml b/tools/fake_ide.ml index c0d2e4d6b..a9da27ba2 100644 --- a/tools/fake_ide.ml +++ b/tools/fake_ide.ml @@ -293,15 +293,28 @@ let usage () = module Coqide = Spawn.Sync(struct end) let main = - Sys.set_signal Sys.sigpipe + if Sys.os_type = "Unix" then Sys.set_signal Sys.sigpipe (Sys.Signal_handle (fun _ -> prerr_endline "Broken Pipe (coqtop died ?)"; exit 1)); let def_args = ["--xml_format=Ppcmds"; "-ideslave"] in - let coqtop_name, coqtop_args, input_file = match Sys.argv with - | [| _; f |] -> "coqtop", Array.of_list def_args, f + let coqtop_name = (* from ide/ideutils.ml *) + let prog_name = "fake_ide" in + let len_prog_name = String.length prog_name in + let fake_ide_path = Sys.executable_name in + let fake_ide_path_len = String.length fake_ide_path in + let pos = fake_ide_path_len - len_prog_name in + let rex = Str.regexp_string prog_name in + try + let i = Str.search_backward rex fake_ide_path pos in + String.sub fake_ide_path 0 i ^ "coqtop" ^ + String.sub fake_ide_path (i + len_prog_name) + (fake_ide_path_len - i - len_prog_name) + with Not_found -> assert false in + let coqtop_args, input_file = match Sys.argv with + | [| _; f |] -> Array.of_list def_args, f | [| _; f; ct |] -> let ct = Str.split (Str.regexp " ") ct in - List.hd ct, Array.of_list (def_args @ List.tl ct), f + Array.of_list (def_args @ ct), f | _ -> usage () in let inc = if input_file = "-" then stdin else open_in input_file in let coq = diff --git a/tools/make-both-single-timing-files.py b/tools/make-both-single-timing-files.py new file mode 100755 index 000000000..2d33503c3 --- /dev/null +++ b/tools/make-both-single-timing-files.py @@ -0,0 +1,18 @@ +#!/usr/bin/env python +import sys +from TimeFileMaker import * + +if __name__ == '__main__': + USAGE = 'Usage: %s AFTER_FILE_NAME BEFORE_FILE_NAME [OUTPUT_FILE_NAME ..]' % sys.argv[0] + HELP_STRING = r'''Formats timing information from the output of two invocations of `coqc -time` into a sorted table''' + if len(sys.argv) < 3 or '--help' in sys.argv[1:] or '-h' in sys.argv[1:]: + print(USAGE) + if '--help' in sys.argv[1:] or '-h' in sys.argv[1:]: + print(HELP_STRING) + if len(sys.argv) == 2: sys.exit(0) + sys.exit(1) + else: + left_dict = get_single_file_times(sys.argv[1]) + right_dict = get_single_file_times(sys.argv[2]) + table = make_diff_table_string(left_dict, right_dict, tag="Code") + print_or_write_table(table, sys.argv[3:]) diff --git a/tools/make-both-time-files.py b/tools/make-both-time-files.py new file mode 100755 index 000000000..69ec5a663 --- /dev/null +++ b/tools/make-both-time-files.py @@ -0,0 +1,22 @@ +#!/usr/bin/env python +import sys +from TimeFileMaker import * + +if __name__ == '__main__': + USAGE = 'Usage: %s AFTER_FILE_NAME BEFORE_FILE_NAME [OUTPUT_FILE_NAME ..]' % sys.argv[0] + HELP_STRING = r'''Formats timing information from the output of two invocations of `make TIMED=1` into a sorted table. + +The input is expected to contain lines in the format: +FILE_NAME (...user: NUMBER_IN_SECONDS...) +''' + if len(sys.argv) < 3 or '--help' in sys.argv[1:] or '-h' in sys.argv[1:]: + print(USAGE) + if '--help' in sys.argv[1:] or '-h' in sys.argv[1:]: + print(HELP_STRING) + if len(sys.argv) == 2: sys.exit(0) + sys.exit(1) + else: + left_dict = get_times(sys.argv[1]) + right_dict = get_times(sys.argv[2]) + table = make_diff_table_string(left_dict, right_dict) + print_or_write_table(table, sys.argv[3:]) diff --git a/tools/make-one-time-file.py b/tools/make-one-time-file.py new file mode 100755 index 000000000..e66136df9 --- /dev/null +++ b/tools/make-one-time-file.py @@ -0,0 +1,21 @@ +#!/usr/bin/env python +import sys +from TimeFileMaker import * + +if __name__ == '__main__': + USAGE = 'Usage: %s FILE_NAME [OUTPUT_FILE_NAME ..]' % sys.argv[0] + HELP_STRING = r'''Formats timing information from the output of `make TIMED=1` into a sorted table. + +The input is expected to contain lines in the format: +FILE_NAME (...user: NUMBER_IN_SECONDS...) +''' + if len(sys.argv) < 2 or '--help' in sys.argv[1:] or '-h' in sys.argv[1:]: + print(USAGE) + if '--help' in sys.argv[1:] or '-h' in sys.argv[1:]: + print(HELP_STRING) + if len(sys.argv) == 2: sys.exit(0) + sys.exit(1) + else: + times_dict = get_times(sys.argv[1]) + table = make_table_string(times_dict) + print_or_write_table(table, sys.argv[2:]) diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 8c394316e..08c235023 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -58,16 +58,18 @@ let init_color () = match colors with | None -> (** Default colors *) - Topfmt.init_color_output () + Topfmt.init_terminal_output ~color:true | Some "" -> (** No color output *) - () + Topfmt.init_terminal_output ~color:false | Some s -> (** Overwrite all colors *) Topfmt.clear_styles (); Topfmt.parse_color_config s; - Topfmt.init_color_output () + Topfmt.init_terminal_output ~color:true end + else + Topfmt.init_terminal_output ~color:false let toploop_init = ref begin fun x -> let () = init_color () in diff --git a/vernac/assumptions.ml b/vernac/assumptions.ml index db07bbd06..86bbf46a3 100644 --- a/vernac/assumptions.ml +++ b/vernac/assumptions.ml @@ -187,7 +187,7 @@ let rec traverse current ctx accu t = match kind_of_term t with let body () = id |> Global.lookup_named |> NamedDecl.get_value in traverse_object accu body (VarRef id) | Const (kn, _) -> - let body () = Global.body_of_constant_body (lookup_constant kn) in + let body () = Option.map fst (Global.body_of_constant_body (lookup_constant kn)) in traverse_object accu body (ConstRef kn) | Ind ((mind, _) as ind, _) -> traverse_inductive accu mind (IndRef ind) @@ -200,7 +200,7 @@ let rec traverse current ctx accu t = match kind_of_term t with | Lambda(_,_,oty), Const (kn, _) when Vars.noccurn 1 oty && not (Declareops.constant_has_body (lookup_constant kn)) -> - let body () = Global.body_of_constant_body (lookup_constant kn) in + let body () = Option.map fst (Global.body_of_constant_body (lookup_constant kn)) in traverse_object ~inhabits:(current,ctx,Vars.subst1 mkProp oty) accu body (ConstRef kn) | _ -> diff --git a/vernac/auto_ind_decl.ml b/vernac/auto_ind_decl.ml index 248224e6b..59920742d 100644 --- a/vernac/auto_ind_decl.ml +++ b/vernac/auto_ind_decl.ml @@ -105,7 +105,7 @@ let mkFullInd (ind,u) n = else mkIndU (ind,u) let check_bool_is_defined () = - try let _ = Global.type_of_global_unsafe Coqlib.glob_bool in () + try let _ = Global.type_of_global_in_context (Global.env ()) Coqlib.glob_bool in () with e when CErrors.noncritical e -> raise (UndefinedCst "bool") let beq_scheme_kind_aux = ref (fun _ -> failwith "Undefined") diff --git a/vernac/class.ml b/vernac/class.ml index 0b510bbcf..be682977e 100644 --- a/vernac/class.ml +++ b/vernac/class.ml @@ -62,7 +62,9 @@ let explain_coercion_error g = function (* Verifications pour l'ajout d'une classe *) let check_reference_arity ref = - if not (Reductionops.is_arity (Global.env()) Evd.empty (EConstr.of_constr (Global.type_of_global_unsafe ref))) (** FIXME *) then + let env = Global.env () in + let c, _ = Global.type_of_global_in_context env ref in + if not (Reductionops.is_arity env Evd.empty (EConstr.of_constr c)) (** FIXME *) then raise (CoercionError (NotAClass ref)) let check_arity = function @@ -252,7 +254,7 @@ let warn_uniform_inheritance = let add_new_coercion_core coef stre poly source target isid = check_source source; - let t = Global.type_of_global_unsafe coef in + let t, _ = Global.type_of_global_in_context (Global.env ()) coef in if coercion_exists coef then raise (CoercionError AlreadyExists); let tg,lp = prods_of t in let llp = List.length lp in diff --git a/vernac/classes.ml b/vernac/classes.ml index a528b9640..ab1892a18 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -68,7 +68,7 @@ let _ = let existing_instance glob g info = let c = global g in let info = Option.default Hints.empty_hint_info info in - let instance = Global.type_of_global_unsafe c in + let instance, _ = Global.type_of_global_in_context (Global.env ()) c in let _, r = decompose_prod_assum instance in match class_of_constr Evd.empty (EConstr.of_constr r) with | Some (_, ((tc,u), _)) -> add_instance (new_instance tc info glob @@ -164,7 +164,7 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) p let ctx'' = ctx' @ ctx in let (k, u), args = Typeclasses.dest_class_app (push_rel_context ctx'' env) !evars (EConstr.of_constr c) in let u = EConstr.EInstance.kind !evars u in - let cl, u = Typeclasses.typeclass_univ_instance (k, u) in + let cl = Typeclasses.typeclass_univ_instance (k, u) in let _, args = List.fold_right (fun decl (args, args') -> match decl with diff --git a/vernac/discharge.ml b/vernac/discharge.ml index b6308aba0..474c0b4dd 100644 --- a/vernac/discharge.ml +++ b/vernac/discharge.ml @@ -77,42 +77,36 @@ let refresh_polymorphic_type_of_inductive (_,mip) = let ctx = List.rev mip.mind_arity_ctxt in mkArity (List.rev ctx, Type ar.template_level), true -let process_inductive (sechyps,abs_ctx) modlist mib = +let process_inductive (sechyps,_,_ as info) modlist mib = + let sechyps = Lib.named_of_variable_context sechyps in let nparams = mib.mind_nparams in - let subst, univs = + let subst, ind_univs = match mib.mind_universes with - | Monomorphic_ind ctx -> Univ.Instance.empty, ctx + | Monomorphic_ind ctx -> Univ.empty_level_subst, Monomorphic_ind_entry ctx | Polymorphic_ind auctx -> - Univ.AUContext.instance auctx, Univ.instantiate_univ_context auctx + let subst, auctx = Lib.discharge_abstract_universe_context info auctx in + let auctx = Univ.AUContext.repr auctx in + subst, Polymorphic_ind_entry auctx | Cumulative_ind cumi -> let auctx = Univ.ACumulativityInfo.univ_context cumi in - Univ.AUContext.instance auctx, Univ.instantiate_univ_context auctx + let subst, auctx = Lib.discharge_abstract_universe_context info auctx in + let auctx = Univ.AUContext.repr auctx in + subst, Cumulative_ind_entry (Universes.univ_inf_ind_from_universe_context auctx) in + let discharge c = Vars.subst_univs_level_constr subst (expmod_constr modlist c) in let inds = Array.map_to_list (fun mip -> let ty, template = refresh_polymorphic_type_of_inductive (mib,mip) in - let arity = expmod_constr modlist ty in - let arity = Vars.subst_instance_constr subst arity in - let lc = Array.map - (fun c -> Vars.subst_instance_constr subst (expmod_constr modlist c)) - mip.mind_user_lc - in + let arity = discharge ty in + let lc = Array.map discharge mip.mind_user_lc in (mip.mind_typename, arity, template, Array.to_list mip.mind_consnames, Array.to_list lc)) mib.mind_packets in - let sechyps' = Context.Named.map (expmod_constr modlist) sechyps in + let sechyps' = Context.Named.map discharge sechyps in let (params',inds') = abstract_inductive sechyps' nparams inds in - let abs_ctx = Univ.instantiate_univ_context abs_ctx in - let univs = Univ.UContext.union abs_ctx univs in - let ind_univs = - match mib.mind_universes with - | Monomorphic_ind _ -> Monomorphic_ind_entry univs - | Polymorphic_ind _ -> Polymorphic_ind_entry univs - | Cumulative_ind _ -> - Cumulative_ind_entry (Universes.univ_inf_ind_from_universe_context univs) in let record = match mib.mind_record with | Some (Some (id, _, _)) -> Some (Some id) | Some None -> Some None diff --git a/vernac/discharge.mli b/vernac/discharge.mli index a0dabe2f4..c8c7e3b8b 100644 --- a/vernac/discharge.mli +++ b/vernac/discharge.mli @@ -11,5 +11,4 @@ open Entries open Opaqueproof val process_inductive : - ((Term.constr, Term.constr) Context.Named.pt * Univ.abstract_universe_context) - -> work_list -> mutual_inductive_body -> mutual_inductive_entry + Lib.abstr_info -> work_list -> mutual_inductive_body -> mutual_inductive_entry diff --git a/vernac/himsg.ml b/vernac/himsg.ml index ca3fb392f..784c6d338 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -909,6 +909,7 @@ let explain_not_match_error = function quote (Printer.safe_pr_lconstr_env env Evd.empty t2) | IncompatibleConstraints cst -> str " the expected (polymorphic) constraints do not imply " ++ + let cst = Univ.AUContext.instantiate (Univ.AUContext.instance cst) cst in quote (Univ.pr_constraints (Termops.pr_evd_level Evd.empty) cst) let explain_signature_mismatch l spec why = diff --git a/vernac/indschemes.ml b/vernac/indschemes.ml index 6d93f0e41..3d97a767c 100644 --- a/vernac/indschemes.ml +++ b/vernac/indschemes.ml @@ -383,9 +383,8 @@ let do_mutual_induction_scheme lnamedepindsort = match inst with | None -> let _, ctx = Global.type_of_global_in_context env0 (IndRef ind) in - let ctxs = Univ.ContextSet.of_context ctx in - let evd = Evd.from_ctx (Evd.evar_universe_context_of ctxs) in - let u = Univ.UContext.instance ctx in + let u, ctx = Universes.fresh_instance_from ctx None in + let evd = Evd.from_ctx (Evd.evar_universe_context_of ctx) in evd, (ind,u), Some u | Some ui -> evd, (ind, ui), inst in diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml index 2eeaf4d5d..645320c60 100644 --- a/vernac/lemmas.ml +++ b/vernac/lemmas.ml @@ -44,12 +44,15 @@ let call_hook fix_exn hook l c = (* Support for mutually proved theorems *) -let retrieve_first_recthm = function +let retrieve_first_recthm uctx = function | VarRef id -> (NamedDecl.get_value (Global.lookup_named id),variable_opacity id) | ConstRef cst -> let cb = Global.lookup_constant cst in - (Global.body_of_constant_body cb, is_opaque cb) + let (_, uctx) = UState.universe_context uctx in + let inst = Univ.UContext.instance uctx in + let map (c, ctx) = Vars.subst_instance_constr inst c in + (Option.map map (Global.body_of_constant_body cb), is_opaque cb) | _ -> assert false let adjust_guardness_conditions const = function @@ -412,7 +415,7 @@ let start_proof_with_initialization kind ctx recguard thms snl hook = let other_thms_data = if List.is_empty other_thms then [] else (* there are several theorems defined mutually *) - let body,opaq = retrieve_first_recthm ref in + let body,opaq = retrieve_first_recthm ctx ref in let subst = Evd.evar_universe_context_subst ctx in let norm c = Universes.subst_opt_univs_constr subst c in let ctx = UState.context_set (*FIXME*) ctx in diff --git a/vernac/obligations.ml b/vernac/obligations.ml index c0acdaf57..10d3317f8 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -285,7 +285,7 @@ type obligation = { obl_name : Id.t; obl_type : types; obl_location : Evar_kinds.t Loc.located; - obl_body : constant obligation_body option; + obl_body : pconstant obligation_body option; obl_status : bool * Evar_kinds.obligation_definition_status; obl_deps : Int.Set.t; obl_tac : unit Proofview.tactic option; @@ -350,7 +350,7 @@ let get_shrink_obligations () = !shrink_obligations let _ = declare_bool_option - { optdepr = true; + { optdepr = true; (* remove in 8.8 *) optname = "Shrinking of Program obligations"; optkey = ["Shrink";"Obligations"]; optread = get_shrink_obligations; @@ -358,18 +358,8 @@ let _ = let evar_of_obligation o = make_evar (Global.named_context_val ()) o.obl_type -let get_body obl = - match obl.obl_body with - | None -> None - | Some (DefinedObl c) -> - let u = Environ.constant_instance (Global.env ()) c in - let pc = (c, u) in - Some (DefinedObl pc) - | Some (TermObl c) -> - Some (TermObl c) - let get_obligation_body expand obl = - match get_body obl with + match obl.obl_body with | None -> None | Some c -> if expand && snd obl.obl_status == Evar_kinds.Expand then @@ -664,7 +654,7 @@ let declare_obligation prg obl body ty uctx = definition_message obl.obl_name; true, { obl with obl_body = if poly then - Some (DefinedObl constant) + Some (DefinedObl (constant, Univ.UContext.instance uctx)) else Some (TermObl (it_mkLambda_or_LetIn_or_clean (mkApp (mkConst constant, args)) ctx)) } @@ -892,20 +882,22 @@ let obligation_hook prg obl num auto ctx' _ gr = if not transparent then err_not_transp () | _ -> () in - let obl = { obl with obl_body = Some (DefinedObl cst) } in - let () = if transparent then add_hint true prg cst in - let obls = Array.copy obls in - let _ = obls.(num) <- obl in let ctx' = match ctx' with None -> prg.prg_ctx | Some ctx' -> ctx' in - let ctx' = + let inst, ctx' = if not (pi2 prg.prg_kind) (* Not polymorphic *) then (* The universe context was declared globally, we continue from the new global environment. *) let evd = Evd.from_env (Global.env ()) in let ctx' = Evd.merge_universe_subst evd (Evd.universe_subst (Evd.from_ctx ctx')) in - Evd.evar_universe_context ctx' - else ctx' + Univ.Instance.empty, Evd.evar_universe_context ctx' + else + let (_, uctx) = UState.universe_context ctx' in + Univ.UContext.instance uctx, ctx' in + let obl = { obl with obl_body = Some (DefinedObl (cst, inst)) } in + let () = if transparent then add_hint true prg cst in + let obls = Array.copy obls in + let _ = obls.(num) <- obl in let prg = { prg with prg_ctx = ctx' } in let () = try ignore (update_obls prg obls (pred rem)) @@ -1132,7 +1124,7 @@ let admit_prog prg = (ParameterEntry (None,false,(x.obl_type,ctx),None), IsAssumption Conjectural) in assumption_message x.obl_name; - obls.(i) <- { x with obl_body = Some (DefinedObl kn) } + obls.(i) <- { x with obl_body = Some (DefinedObl (kn, Univ.Instance.empty)) } | Some _ -> ()) obls; ignore(update_obls prg obls 0) diff --git a/vernac/record.ml b/vernac/record.ml index d61f44cac..63ca22786 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -265,16 +265,10 @@ let warn_non_primitive_record = let declare_projections indsp ?(kind=StructureComponent) binder_name coers fieldimpls fields = let env = Global.env() in let (mib,mip) = Global.lookup_inductive indsp in - let u = Declareops.inductive_polymorphic_instance mib in - let paramdecls = Inductive.inductive_paramdecls (mib, u) in let poly = Declareops.inductive_is_polymorphic mib in - let ctx = - match mib.mind_universes with - | Monomorphic_ind ctx -> ctx - | Polymorphic_ind auctx -> Univ.instantiate_univ_context auctx - | Cumulative_ind cumi -> - Univ.instantiate_univ_context (Univ.ACumulativityInfo.univ_context cumi) - in + let ctx = Univ.AUContext.repr (Declareops.inductive_polymorphic_context mib) in + let u = Univ.UContext.instance ctx in + let paramdecls = Inductive.inductive_paramdecls (mib, u) in let indu = indsp, u in let r = mkIndU (indsp,u) in let rp = applist (r, Context.Rel.to_extended_list mkRel 0 paramdecls) in @@ -334,8 +328,7 @@ let declare_projections indsp ?(kind=StructureComponent) binder_name coers field const_entry_secctx = None; const_entry_type = Some projtyp; const_entry_polymorphic = poly; - const_entry_universes = - if poly then ctx else Univ.UContext.empty; + const_entry_universes = ctx; const_entry_opaque = false; const_entry_inline_code = false; const_entry_feedback = None } in @@ -431,6 +424,12 @@ let declare_structure finite univs id idbuild paramimpls params arity template let kn = Command.declare_mutual_inductive_with_eliminations mie [] [(paramimpls,[])] in let rsp = (kn,0) in (* This is ind path of idstruc *) let cstr = (rsp,1) in + let fields = + if poly then + let subst, _ = Univ.abstract_universes ctx in + Context.Rel.map (fun c -> Vars.subst_univs_level_constr subst c) fields + else fields + in let kinds,sp_projs = declare_projections rsp ~kind binder_name coers fieldimpls fields in let build = ConstructRef cstr in let () = if is_coe then Class.try_add_new_coercion build ~local:false poly in @@ -518,8 +517,18 @@ let declare_class finite def cum poly ctx id idbuild paramimpls params arity | None -> None) params, params in + let univs, ctx_context, fields = + if poly then + let usubst, auctx = Univ.abstract_universes ctx in + let map c = Vars.subst_univs_level_constr usubst c in + let fields = Context.Rel.map map fields in + let ctx_context = on_snd (fun d -> Context.Rel.map map d) ctx_context in + auctx, ctx_context, fields + else Univ.AUContext.empty, ctx_context, fields + in let k = - { cl_impl = impl; + { cl_univs = univs; + cl_impl = impl; cl_strict = !typeclasses_strict; cl_unique = !typeclasses_unique; cl_context = ctx_context; @@ -530,10 +539,11 @@ let declare_class finite def cum poly ctx id idbuild paramimpls params arity let add_constant_class cst = - let ty = Universes.unsafe_type_of_global (ConstRef cst) in + let ty, univs = Global.type_of_global_in_context (Global.env ()) (ConstRef cst) in let ctx, arity = decompose_prod_assum ty in let tc = - { cl_impl = ConstRef cst; + { cl_univs = univs; + cl_impl = ConstRef cst; cl_context = (List.map (const None) ctx, ctx); cl_props = [LocalAssum (Anonymous, arity)]; cl_projs = []; @@ -547,12 +557,13 @@ let add_inductive_class ind = let mind, oneind = Global.lookup_inductive ind in let k = let ctx = oneind.mind_arity_ctxt in - let inst = Declareops.inductive_polymorphic_instance mind in - let ty = Inductive.type_of_inductive - (push_rel_context ctx (Global.env ())) - ((mind,oneind),inst) - in - { cl_impl = IndRef ind; + let univs = Declareops.inductive_polymorphic_context mind in + let env = push_context ~strict:false (Univ.AUContext.repr univs) (Global.env ()) in + let env = push_rel_context ctx env in + let inst = Univ.make_abstract_instance univs in + let ty = Inductive.type_of_inductive env ((mind, oneind), inst) in + { cl_univs = univs; + cl_impl = IndRef ind; cl_context = List.map (const None) ctx, ctx; cl_props = [LocalAssum (Anonymous, ty)]; cl_projs = []; diff --git a/vernac/search.ml b/vernac/search.ml index 00536e52e..0f56f81e7 100644 --- a/vernac/search.ml +++ b/vernac/search.ml @@ -78,14 +78,14 @@ let iter_declarations (fn : global_reference -> env -> constr -> unit) = | "CONSTANT" -> let cst = Global.constant_of_delta_kn kn in let gr = ConstRef cst in - let typ = Global.type_of_global_unsafe gr in + let (typ, _) = Global.type_of_global_in_context (Global.env ()) gr in fn gr env typ | "INDUCTIVE" -> let mind = Global.mind_of_delta_kn kn in let mib = Global.lookup_mind mind in let iter_packet i mip = let ind = (mind, i) in - let u = Declareops.inductive_polymorphic_instance mib in + let u = Univ.make_abstract_instance (Declareops.inductive_polymorphic_context mib) in let i = (ind, u) in let typ = Inductiveops.type_of_inductive env i in let () = fn (IndRef ind) env typ in diff --git a/vernac/topfmt.ml b/vernac/topfmt.ml index b3810f7d5..e7b14309d 100644 --- a/vernac/topfmt.ml +++ b/vernac/topfmt.ml @@ -149,7 +149,7 @@ let gen_logger dbg warn ?pre_hdr level msg = match level with (** Standard loggers *) (* We provide a generic clear_log_backend callback for backends - wanting to do clenaup after the print. + wanting to do cleanup after the print. *) let std_logger_cleanup = ref (fun () -> ()) @@ -207,6 +207,8 @@ let make_style_stack () = italic = Some false; underline = Some false; negative = Some false; + prefix = None; + suffix = None; }) in let style_stack = ref [] in @@ -235,20 +237,49 @@ let make_style_stack () = let clear () = style_stack := [] in push, pop, clear -let init_color_output () = +let make_printing_functions () = + let empty = Terminal.make () in + let print_prefix ft tag = + let style = + try CString.Map.find tag !tag_map + with | Not_found -> empty + in + match style.Terminal.prefix with Some s -> Format.pp_print_string ft s | None -> () + in + let print_suffix ft tag = + let style = + try CString.Map.find tag !tag_map + with | Not_found -> empty + in + match style.Terminal.suffix with Some s -> Format.pp_print_string ft s | None -> () + in + print_prefix, print_suffix + +let init_terminal_output ~color = init_tag_map (default_tag_map ()); let push_tag, pop_tag, clear_tag = make_style_stack () in - std_logger_cleanup := clear_tag; - let tag_handler = { + let print_prefix, print_suffix = make_printing_functions () in + let tag_handler ft = { Format.mark_open_tag = push_tag; Format.mark_close_tag = pop_tag; - Format.print_open_tag = ignore; - Format.print_close_tag = ignore; + Format.print_open_tag = print_prefix ft; + Format.print_close_tag = print_suffix ft; } in - Format.pp_set_mark_tags !std_ft true; - Format.pp_set_mark_tags !err_ft true; - Format.pp_set_formatter_tag_functions !std_ft tag_handler; - Format.pp_set_formatter_tag_functions !err_ft tag_handler + if color then + (* Use 0-length markers *) + begin + std_logger_cleanup := clear_tag; + Format.pp_set_mark_tags !std_ft true; + Format.pp_set_mark_tags !err_ft true + end + else + (* Use textual markers *) + begin + Format.pp_set_print_tags !std_ft true; + Format.pp_set_print_tags !err_ft true + end; + Format.pp_set_formatter_tag_functions !std_ft (tag_handler !std_ft); + Format.pp_set_formatter_tag_functions !err_ft (tag_handler !err_ft) (* Rules for emacs: - Debug/info: emacs_quote_info diff --git a/vernac/topfmt.mli b/vernac/topfmt.mli index 0e781bcc1..6e006fc6c 100644 --- a/vernac/topfmt.mli +++ b/vernac/topfmt.mli @@ -41,11 +41,13 @@ val std_logger : ?pre_hdr:Pp.std_ppcmds -> Feedback.level -> Pp.std_ppcmds -> val emacs_logger : ?pre_hdr:Pp.std_ppcmds -> Feedback.level -> Pp.std_ppcmds -> unit (** Color output *) -val init_color_output : unit -> unit val clear_styles : unit -> unit val parse_color_config : string -> unit val dump_tags : unit -> (string * Terminal.style) list +(** Initialization of interpretation of tags *) +val init_terminal_output : color:bool -> unit + (** Error printing *) (* To be deprecated when we can fully move to feedback-based error printing. *) diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index bbec28aff..9650ea19d 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -986,7 +986,7 @@ let vernac_arguments locality reference args more_implicits nargs_for_red flags let sr = smart_global reference in let inf_names = - let ty = Global.type_of_global_unsafe sr in + let ty, _ = Global.type_of_global_in_context (Global.env ()) sr in Impargs.compute_implicits_names (Global.env ()) ty in let prev_names = @@ -1811,9 +1811,9 @@ let vernac_end_subproof () = Proof_global.simple_with_current_proof (fun _ p -> Proof.unfocus subproof_kind p ()) -let vernac_bullet (bullet:Proof_global.Bullet.t) = +let vernac_bullet (bullet : Proof_bullet.t) = Proof_global.simple_with_current_proof (fun _ p -> - Proof_global.Bullet.put p bullet) + Proof_bullet.put p bullet) let vernac_show = let open Feedback in function | ShowScript -> assert false (* Only the stm knows the script *) |