diff options
67 files changed, 869 insertions, 1260 deletions
diff --git a/API/API.mli b/API/API.mli index 029f458cc7..9f7a6ded81 100644 --- a/API/API.mli +++ b/API/API.mli @@ -4669,8 +4669,6 @@ 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 : diff --git a/Makefile.build b/Makefile.build index 0dafde9977..05d751f541 100644 --- a/Makefile.build +++ b/Makefile.build @@ -101,7 +101,7 @@ DEPENDENCIES := \ ########################################################################### # Default timing command -STDTIME=/usr/bin/time -f "$* (user: %U mem: %M ko)" +STDTIME=/usr/bin/time -f "$* (real: %e, user: %U, sys: %S, mem: %M ko)" TIMER=$(if $(TIMED), $(STDTIME), $(TIMECMD)) @@ -275,7 +275,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 +307,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 +317,7 @@ $(COQTOPEXE): $(COQTOPBYTE) endif $(COQTOPBYTE): $(COQMKTOP) $(LINKCMO) $(LIBCOQRUN) $(TOPLOOPCMA) - $(SHOW)'COQMKTOP -o $@' + $(SHOW)'COQMKTOP -o $@' $(HIDE)$(COQMKTOP) -boot -top $(BYTEFLAGS) -o $@ # coqmktop @@ -667,7 +667,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: @@ -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/checker/environ.ml b/checker/environ.ml index 11b8ea67cc..d3f393c651 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/inductive.ml b/checker/inductive.ml index 93ffa329a6..1271a02b0e 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 698b8b77c2..8f605935db 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/reduction.ml b/checker/reduction.ml index 93b8b907ca..6d8783d7e5 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 5fd5510a7f..3097c3a0b9 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/univ.ml b/checker/univ.ml index b434db129e..2cd4252b20 100644 --- a/checker/univ.ml +++ b/checker/univ.ml @@ -1160,6 +1160,33 @@ struct 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 +1202,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 +1212,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 @@ -1242,7 +1281,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,36 +1312,6 @@ 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 diff --git a/checker/univ.mli b/checker/univ.mli index 457ccbdfff..01df46fa1e 100644 --- a/checker/univ.mli +++ b/checker/univ.mli @@ -209,6 +209,10 @@ sig type t val instance : t -> Instance.t + val size : t -> int + + val instantiate : Instance.t -> t -> Constraint.t + val repr : t -> UContext.t end @@ -276,7 +280,6 @@ 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 *) @@ -287,7 +290,10 @@ val instantiate_cumulativity_info : abstract_cumulativity_info -> cumulativity_i (** 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 c75c3d7e1c..9976c19d44 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.0~alpha" let coq_macos_version = "8.6.90" (** "[...] should be a string comprised of three non-negative, period-separated integers [...]" *) let vo_magic = 8691 diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index 99ec43e412..91337b9013 100644 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -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 0dd904648c..4cfe0911b6 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/doc/refman/RefMan-ind.tex b/doc/refman/RefMan-ind.tex deleted file mode 100644 index 43bd2419f0..0000000000 --- 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/tutorial/Tutorial.tex b/doc/tutorial/Tutorial.tex index 30b6304c16..8337b1c48f 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 c542fd976a..b4e2160f4e 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 e98f59f0f9..530204501e 100644 --- a/engine/proofview.mli +++ b/engine/proofview.mli @@ -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/universes.ml b/engine/universes.ml index 28058aeed8..fc441fd0b4 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,7 +316,7 @@ 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 = diff --git a/kernel/cooking.ml b/kernel/cooking.ml index b9e7ec1691..95822fac68 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 1337036b8b..efce219826 100644 --- a/kernel/declareops.ml +++ b/kernel/declareops.ml @@ -44,47 +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 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 @@ -268,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 7350724b8b..a8ba5fa392 100644 --- a/kernel/declareops.mli +++ b/kernel/declareops.mli @@ -27,25 +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 - (** 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 *) @@ -68,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/environ.ml b/kernel/environ.ml index dd204c7d59..b01b652001 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 f8887d8e83..cd7a9d2791 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 04971f83dc..e248436ec4 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 e3fb472be1..1eaba49aa9 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/mod_typing.ml b/kernel/mod_typing.ml index 71c0370083..c7f3e5c51b 100644 --- a/kernel/mod_typing.ml +++ b/kernel/mod_typing.ml @@ -92,37 +92,29 @@ let rec check_with_def env struc (idl,(c,ctx)) mp equiv = 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) | Polymorphic_const uctx -> - let uctx = Univ.instantiate_univ_context uctx in - 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 + 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 24be46933e..a079bc8931 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 4a150d54bd..e2a94b6919 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 eb238941b7..da7fcd6f23 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 de4efbba93..2bf9f43a5a 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 6f128d5d30..bd82dd465b 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,7 +332,7 @@ 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) -> CErrors.user_err Pp.(str @@ "The kernel does not recognize yet that a parameter can be " ^ diff --git a/kernel/subtyping.mli b/kernel/subtyping.mli index 6590d7e712..b24c20aa02 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 283febed24..3e516cae04 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) -> @@ -470,7 +469,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 487257a776..9793dd881d 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 935a3cab4a..4de373eb4c 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 1c887e2a99..6614d60276 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,31 +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) @@ -1378,19 +1389,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 d7ee3eceec..53297ac462 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,10 +461,10 @@ val abstract_cumulativity_info : cumulativity_info -> universe_level_subst * abs val make_abstract_instance : abstract_universe_context -> universe_instance -(** Get the instantiated graph. *) +(** Don't use. *) val instantiate_univ_context : abstract_universe_context -> universe_context -(** Get the instantiated graphs for both universe constraints and subtyping constraints. *) +(** Don't use. *) val instantiate_cumulativity_info : abstract_cumulativity_info -> cumulativity_info (** {6 Pretty-printing of universes. } *) diff --git a/lib/hashset.ml b/lib/hashset.ml index 23ac2fed09..7f96627a68 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/terminal.ml b/lib/terminal.ml index 3b6e34f0b8..34efddfbca 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 dbc418dd6a..b1b76e6e2a 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 8b59c84dda..e90151bffe 100644 --- a/library/global.ml +++ b/library/global.ml @@ -122,7 +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 + | Polymorphic_const ctx -> + Vars.subst_instance_constr (Univ.AUContext.instance ctx) c + +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) (** Operations on kernel names *) @@ -164,49 +179,49 @@ let type_of_global_unsafe r = 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 + let cb = Environ.lookup_constant c env in + let inst = Univ.AUContext.instance (Declareops.constant_polymorphic_context cb) in + let ty = Typeops.type_of_constant_type env cb.Declarations.const_type in + Vars.subst_instance_constr inst ty | 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 inst = Univ.AUContext.instance (Declareops.inductive_polymorphic_context mib) in + Inductive.type_of_inductive env (specif, inst) | 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 inst = Univ.AUContext.instance (Declareops.inductive_polymorphic_context mib) in + Inductive.type_of_constructor (cstr,inst) specif let type_of_global_in_context env r = match r with | VarRef id -> Environ.named_type id env, Univ.UContext.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 inst = Univ.AUContext.instance univs in + let univs = Univ.UContext.make (inst, Univ.AUContext.instantiate inst univs) 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.AUContext.instance univs in + let univs = Univ.UContext.make (inst, Univ.AUContext.instantiate inst univs) 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.AUContext.instance univs in + let univs = Univ.UContext.make (inst, Univ.AUContext.instantiate inst 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 754fa1516b..5ddf54b4af 100644 --- a/library/global.mli +++ b/library/global.mli @@ -141,7 +141,7 @@ val type_of_global_unsafe : Globnames.global_reference -> Constr.types [Evarutil.new_global] and [Retyping.get_type_of]. *) (** 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 0f420c0e65..a1cb812429 100644 --- a/library/heads.ml +++ b/library/heads.ml @@ -128,7 +128,7 @@ 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) diff --git a/library/lib.ml b/library/lib.ml index 009eb88fc1..439f83578d 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 = diff --git a/library/univops.ml b/library/univops.ml index 669be2d452..3bafb824d1 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 b5f7715b11..09147cb41c 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/pretyping/evarconv.ml b/pretyping/evarconv.ml index b5d195873c..87f29ba492 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -353,9 +353,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 +363,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/recordops.ml b/pretyping/recordops.ml index 1cb694da66..c498089ca8 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -189,22 +189,28 @@ 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.AUContext.instance ctx in + let ctx = Univ.UContext.make (u, Univ.AUContext.instantiate u 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 +227,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 +302,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.AUContext.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/reductionops.ml b/pretyping/reductionops.ml index cc1709f1c2..21ed8e0a23 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -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 201f79c39f..bae831b637 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -117,10 +117,10 @@ let typeclass_univ_instance (cl,u') = match cl.cl_impl with | ConstRef c -> let cb = Global.lookup_constant c in - Declareops.constant_polymorphic_instance cb + Univ.AUContext.instance (Declareops.constant_polymorphic_context cb) | IndRef c -> let mib,oib = Global.lookup_inductive c in - Declareops.inductive_polymorphic_instance mib + Univ.AUContext.instance (Declareops.inductive_polymorphic_context 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') diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index b3eaa3cb95..66cc42cb61 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/prettyp.ml b/printing/prettyp.ml index 15c0f80b93..ff12737f66 100644 --- a/printing/prettyp.ml +++ b/printing/prettyp.ml @@ -78,6 +78,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 @@ -503,13 +505,25 @@ 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 = let otab = Global.opaque_tables () in diff --git a/printing/printmod.ml b/printing/printmod.ml index 10b791e37f..2e0e6d2845 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 ( @@ -149,7 +151,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 @@ -292,11 +294,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 +320,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/tactics/elimschemes.ml b/tactics/elimschemes.ml index 5d9d36958f..e058806a35 100644 --- a/tactics/elimschemes.ml +++ b/tactics/elimschemes.ml @@ -48,7 +48,8 @@ let optimize_non_type_induction_scheme kind dep sort _ ind = 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 u = Univ.AUContext.instance ctx in + let ctx = Univ.UContext.make (u, Univ.AUContext.instantiate u 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 @@ -62,7 +63,8 @@ let build_induction_scheme_in_type dep sort ind = let mib,mip = Inductive.lookup_mind_specif env ind in Declareops.inductive_polymorphic_context mib in - let u = Univ.UContext.instance ctx in + let u = Univ.AUContext.instance ctx in + let ctx = Univ.UContext.make (u, Univ.AUContext.instantiate u 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 diff --git a/test-suite/bugs/closed/5641.v b/test-suite/bugs/closed/5641.v new file mode 100644 index 0000000000..9f3246f33d --- /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/modules/polymorphism.v b/test-suite/modules/polymorphism.v new file mode 100644 index 0000000000..63eaa382dc --- /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 0000000000..7e3327eee0 --- /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/Warnings.out b/test-suite/output/Warnings.out new file mode 100644 index 0000000000..a70f8ca45a --- /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 0000000000..7465442cab --- /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/tools/CoqMakefile.in b/tools/CoqMakefile.in index c4afc930a7..86be54d462 100644 --- a/tools/CoqMakefile.in +++ b/tools/CoqMakefile.in @@ -62,7 +62,7 @@ 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)" +STDTIME?=/usr/bin/time -f "$* (real: %e, user: %U, sys: %S, mem: %M ko)" # Coq binaries COQC ?= "$(COQBIN)coqc" diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 8c394316e9..08c2350237 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/himsg.ml b/vernac/himsg.ml index ca3fb392fe..86dcb6d4dc 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.UContext.constraints (Univ.instantiate_univ_context cst) in quote (Univ.pr_constraints (Termops.pr_evd_level Evd.empty) cst) let explain_signature_mismatch l spec why = diff --git a/vernac/obligations.ml b/vernac/obligations.ml index c0acdaf57d..5a1c260b1f 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -362,7 +362,7 @@ let get_body obl = match obl.obl_body with | None -> None | Some (DefinedObl c) -> - let u = Environ.constant_instance (Global.env ()) c in + let u = Univ.AUContext.instance (Environ.constant_context (Global.env ()) c) in let pc = (c, u) in Some (DefinedObl pc) | Some (TermObl c) -> diff --git a/vernac/record.ml b/vernac/record.ml index d61f44cac8..366f504545 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -265,7 +265,7 @@ 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 u = Univ.AUContext.instance (Declareops.inductive_polymorphic_context mib) in let paramdecls = Inductive.inductive_paramdecls (mib, u) in let poly = Declareops.inductive_is_polymorphic mib in let ctx = @@ -547,7 +547,7 @@ 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 inst = Univ.AUContext.instance (Declareops.inductive_polymorphic_context mind) in let ty = Inductive.type_of_inductive (push_rel_context ctx (Global.env ())) ((mind,oneind),inst) diff --git a/vernac/search.ml b/vernac/search.ml index 00536e52ec..788a2aa4a9 100644 --- a/vernac/search.ml +++ b/vernac/search.ml @@ -85,7 +85,7 @@ let iter_declarations (fn : global_reference -> env -> constr -> unit) = 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.AUContext.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 b3810f7d53..e7b14309d1 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 0e781bcc1b..6e006fc6c9 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. *) |