diff options
| author |  Matthieu Sozeau <mattam@mattam.org> | 2012-10-10 15:35:36 -0400 |
|---|---|---|
| committer | Matthieu Sozeau <mattam@mattam.org> | 2014-05-06 09:58:53 +0200 |
| commit | a4043608f704f026de7eb5167a109ca48e00c221 (patch) | |
| tree | 938b6b8cb8d6d5dbaf7be3c62abcc8fdfcd45fc2 | |
| parent | a2a249211c2ac1e18eff0d4f28e5afc98c137f97 (diff) | |
This commit adds full universe polymorphism and fast projections to Coq.
Add [Polymorphic] and [Monomorphic] local flag for definitions as well as
[Set Universe Polymorphism] global flag to make all following definitions
polymorphic. Mainly syntax for now.
First part of the big changes to the kernel:
- Const, Ind, Construct now come with a universe level instance
- It is used for type inference in the kernel, which now also takes
a graph as input: actually a set of local universe variables and their
constraints. Type inference just checks that the constraints are enough
to satisfy its own rules.
- Remove polymorphic_arity and _knowing_parameters everywhere: we
don't need full applications for polymorphism to apply anymore, as
we generate fresh variables at each constant/inductive/constructor
application. However knowing_parameters variants might be reinstated
later for optimization.
- New structures exported in univ.mli:
- universe_list for universe level instances
- universe_context(_set) for the local universe constraints, also
recording which variables will be local and hence generalized after
inference if defining a polymorphic ind/constant.
- this patch makes coq stop compiling at indtypes.ml
Adapt kernel, library, pretyping, tactics and toplevel to universe polymorphism.
Various degrees of integration, places where I was not sure what to do or
just postponed bigger reorganizations of the code are marked with FIXMEs.
Main changes:
- Kernel now checks constraints and does not infer them anymore.
- The inference functions produce a context of constraints that were checked
during inference, useful to do double-checking of the univ. poly. code
but might be removed later.
- Constant, Inductive entries now have a universe context (local variables
and constraints) associated to them.
- Printing, debugging functions for the new structures are also implemented.
- Now stopping at Logic.v
- Lots of new code in kernel/univ.ml that should be reviewed.
- kernel/indtypes probably does not do what's right when inferring inductive
type constraints.
- Adapted evd to use the new universe context structure.
- Did not deal with unification/evar_conv.
- Add externalisation code for universe level instances.
- Support for polymorphism in pretyping/command and proofs/proofview etc.
Needed wrapping of [fresh_.._instance] through the evar_map, which
contains the local state of universes during type-checking.
- Correct the inductive scheme generation to support polymorphism as well.
- Have to review kernel code for correctness, and especially rework the
computation of universe constraints for inductives.
Stops somewhat later in Logic.v
- Fix naming of local/toplevel universes to be correctly done at typechecking time:
local variables have no dirpath.
- Add code to do substitution of universes in modules, not finished yet.
- Move fresh_* functions out of kernel, it won't ever build a universe level again!
- Adapt a lot of new_Type to use the correct dirpath and declare the new types in the evar_map
so we keep track of them.
- A bit of code factorization (evd_comb moved, pretype_global).
- Refactor more code
- Adapt plugins code (sometimes wrong, marked with FIXME)
- Fix cases generating unneeded universe (not sure it's ok though)
- Fix scheme generation for good, might have opportunity to cleanup
the terms later.
Init compiles now (which means rewrite, inversion, elim etc.. work as well).
- Unsolved issue of pretyping to lower sorts properly (to Prop for example).
This has to do with the (Retyping.get_type_of) giving algebraic universes that
would appear on the right of constraints.
This makes checking for dangling universes at the end of pretyping fail,
hence the check in kernel/univ was removed. It should come back when we have
a fix for this.
- Correctly (?) compute the levels of inductive types.
Removed old code pertaining to universe polymorphism. Note that we generate
constraint variables for the conclusion of inductive types invariably.
- Shrink constraints before going to the kernel, combine substitution of the
smaller universe set with normalization of evars (maybe not done everywhere,
only ordinary inductives, definitions and proofs)
- More API reworks overall. tclPUSHCONTEXT can be used to add fresh universes
to the proof goal (used in a few places to get the right instance.
- Quick fix for auto that won't work in the long run. It should always have been
restricted to take constant references as input, without any loss of generality
over constrs.
Fix some plugins and insertion of non-polymorphic constants in a module.
Now stops in relation classes.
Cleanup and move code from kernel to library and from pretyping to library too.
Now there is a unique universe counter declared in library/universes.ml along
with all the functions to generate new universes and get fresh constant/inductive
terms.
- Various function renamings
- One important change in kernel/univ.ml: now [sup] can be applied to Prop.
- Adapt records/classes to universe polymorphism
- Now stops in EqDepFacts due to imprecise universe polymorphism.
Forgot to git add those files.
interp_constr returns the universe context
The context is then pushed through the environment (or proof goal
sigma).
- Fix insertion of constants/inductives in env, pushing constraints to
the global env for non-polymorphic ones.
- Add Prop as a universe level to do proper type inference with sorts.
It is allowed to take [sup] of [Prop] now.
- New nf_evar based on new Evd.map(_undefined)
- In proofs/logic.ml: conv_leq_goal might create some constraints that
are now recorded.
- Adapt Program code to universes.
Merge with latest trunk + fixes
-Use new constr_of_global from universes
- fix eqschemes to use polymorphic universes
- begin fixing cctac but f_equal still fails
- fix [simpl] and rest of tacred
- all the eq_constr with mkConst foo should be fixed as well, only
partially done
- Fix term hashing function to recognize equal terms up to universe instances.
- Fix congruence closure to equate terms that differ only in universe instances,
these will be resolved by constraints.
Add a set of undefined universe variables to unification.
Universe variables can now be declared rigid or flexible (unifiable).
Flexible variables are resolved at the end of typechecking by instantiating
them to their glb, adding upper bound constraints associated to them.
Also:
- Add polymorphic flag for inductives.
- Fix cooking partially
- Fix kernel/univ.ml to do normalization of universe expressions at
the end of substitution.
Correct classes/structures universe inference
- Required a bit of extension in Univ to handle Max properly (sup u
(u+1)) was returning (max(u,u+1)) for example.
- Try a version where substitution of universe expressions for universe
levels is allowed at the end of unification. By an invariant this
should only instantiate with max() types that are morally "on the
right" only.
This is controlled using a rigidity attribute of universe variables,
also allowing to properly do unification w.r.t. universes during
typechecking/inference.
- Currently fails in Vectors/Fin.v because case compilation generates
"flexible" universes that actually appear in the term...
Fix unification of universe variables.
- Fix choice of canonical universe in presence of universe constraints,
and do so by relying on a trichotomy for universe variables: rigid
(won't be substituted), flexible (might be if not substituted by an
algebraic) and flexible_alg (always substituted).
- Fix romega code and a few more plugins, most of the standard library
goes through now.
- Had to define some inductives as Polymorphic explicitly to make
proofs go through, more to come, and definitions should be polymorphic
too, otherwise inconsistencies appear quickly (two uses of the same
polymorphic ind through monomorphic functions (like nth on lists of
Props and nats) will fix the monomorphic function's universe with eq
constraints that are incompatible).
- Correct universe polymorphism handling for fixpoint/cofixpoint
definitions.
- Fix romega to use the right universes for list constructors.
- Fix internalization/externalization to deal properly with the
implicit parsing of params.
- Fix fourier tactic w.r.t. GRefs
- Fix substitution saturation of universes.
- Fix number syntax plugin.
- Fix setoid_ring to take its coefficients in a Set rather
than a Type, avoiding a large number of useless universe constraints.
- Fix minor checker decl
- Fix btauto w.r.t. GRef
- Fix proofview to normalize universes in the original types as well.
- Fix definitions of projections to not take two universes at the same level,
but at different levels instead, avoiding unnecessary constraints that could
lower the level of one component depending on the use of the other component.
Fix simpl fst, snd to use @fst @snd as they have maximal implicits now.
- More simpl snd, fst fixes.
- Try to make the nth theory of lists polymorphic.
Check with Enrico if this change is ok. Case appearing in RingMicromega's call
to congruence l417, through a call to refine -> the_conv_x_leq.
Compile everything.
- "Fix" checker by deactivating code related to polymorphism, should
be updated.
- Make most of List.v polymorphic to help with following definitions.
- When starting a lemma, normalize w.r.t. universes, so that the types
get a fixed universe, not refinable later.
- In record, don't assign a fully flexible universe variable to the record
type if it is a definitional typeclass, as translate_constant doesn't expect
an algebraic universe in the type of a constant. It certainly should though.
- Fix micromega code.
Fix after rebase.
Update printing functions to print the polymorphic status of definitions
and their universe context.
Refine printing of universe contexts
- Fix printer for universe constraints
- Rework normalization of constraints to separate the Union-Find result
from computation of lubs/glbs.
Keep universe contexts of inductives/constants in entries for correct
substitution inside modules. Abstract interface to get an instantiation
of an inductive with its universe substitution in the kernel (no
substitution if the inductive is not polymorphic, even if mind_universes
is non-empty).
Make fst and snd polymorphic, fix instances in RelationPairs to use
different universes for the two elements of a pair.
- Fix bug in nf_constraints: was removing Set <= constraints, but should
remove Prop <= constraints only.
- Make proj1_sig, projT1... polymorphic to avoid weird universe unifications,
giving rise to universe inconsistenties.
Adapt auto hints to polymorphic references.
Really produce polymorphic hints... second try
- Remove algebraic universes that can't appear in the goal when taking the
type of a lemma to start.
Proper handling of universe contexts in clenv and auto so that
polymorphic hints are really refreshed at each application.
Fix erroneous shadowing of sigma variable.
- Make apparent the universe context used in pretyping, including information
about flexibility of universe variables.
- Fix induction to generate a fresh constant instance with flexible universe variables.
Add function to do conversion w.r.t. an evar map and its local universes.
- Fix define_evar_as_sort to not forget constraints coming from the refinement.
- Do not nf_constraints while we don't have the whole term at hand to substitute in.
- Move substitution of full universes to Universes
- Normalize universes inside an evar_map when doing nf_evar_map_universes.
- Normalize universes at each call to interp_ltac (potentially expensive)
Do not normalize all evars at each call to interp_gen in tactics: rather
incrementally normalize the terms at hand, supposing the normalization of universes
will concern only those appearing in it (dangerous but much more efficient).
Do not needlessly generate new universes constraints for projections of records.
Correct polymorphic discharge of section variables.
Fix autorewrite w.r.t. universes: polymorphic rewrite hints get fresh universe
instances at each application.
Fix r2l rewrite scheme to support universe polymorphism
Fix a bug in l2r_forward scheme and fix congruence scheme to handle polymorphism correctly.
Second try at fixing autorewrite, cannot do without pushing the constraints and the set of fresh
universe variables into the proof context.
- tclPUSHCONTEXT allow to set the ctx universe variables as flexible or rigid
- Fix bug in elimschemes, not taking the right sigma
Wrong sigma used in leibniz_rewrite
Avoid recomputation of bounds for equal universes in normalization of constraints,
only the canonical one need to be computed.
Make coercions work with universe polymorphic projections.
Fix eronneous bound in universes constraint solving.
Make kernel reduction and term comparison strictly aware of universe instances,
with variants for relaxed comparison that output constraints.
Otherwise some constraints that should appear during pretyping don't and we generate
unnecessary constraints/universe variables.
Have to adapt a few tactics to this new behavior by making them universe aware.
- Fix elimschemes to minimize universe variables
- Fix coercions to not forget the universe constraints generated by an application
- Change universe substitutions to maps instead of assoc lists.
- Fix absurd tactic to handle univs properly
- Make length and app polymorphic in List, unification sets their levels otherwise.
Move to modules for namespace management instead of long names in universe code.
More putting things into modules.
Change evar_map structure to support an incremental substitution of universes
(populated from Eq constraints), allowing safe and fast inference of precise levels,
without computing lubs.
- Add many printers and reorganize code
- Extend nf_evar to normalize universe variables according to the substitution.
- Fix ChoiceFacts.v in Logic, no universe inconsistencies anymore. But Diaconescu
still has one (something fixes a universe to Set).
- Adapt omega, functional induction to the changes.
Fix congruence, eq_constr implem, discharge of polymorphic inductives.
Fix merge in auto.
The [-parameters-matter] option (formerly relevant_equality).
Add -parameters-matter to coqc
Do compute the param levels at elaboration time if parameters_matter.
- Fix generalize tactic
- add ppuniverse_subst
- Start fixing normalize_universe_context w.r.t. normalize_univ_variables.
- Fix HUGE bug in Ltac interpretation not folding the sigma correctly if interpreting a tactic application
to multiple arguments.
- Fix bug in union of universe substitution.
- rename parameters-matter to indices-matter
- Fix computation of levels from indices not parameters.
- Fixing parsing so that [Polymorphic] can be applied to gallina extensions.
- When elaborating definitions, make the universes from the type rigid when
checking the term: they should stay abstracted.
- Fix typeclasses eauto's handling of universes for exact hints.
Rework all the code for infering the levels of inductives and checking their
allowed eliminations sorts.
This is based on the computation of a natural level for an inductive type I.
The natural level [nat] of [I : args -> sort := c1 : A1 -> I t1 .. cn : An -> I tn] is
computed by taking the max of the levels of the args (if indices matter) and the
levels of the constructor arguments.
The declared level [decl] of I is [sort], which might be Prop, Set or some Type u (u fresh
or not).
If [decl >= nat && not (decl = Prop && n >= 2)], the level of the inductive is [decl],
otherwise, _smashing_ occured.
If [decl] is impredicative (Prop or Set when Set is impredicative), we accept the
declared level, otherwise it's an error.
To compute the allowed elimination sorts, we have the following situations:
- No smashing occured: all sorts are allowed. (Recall props that are not
smashed are Empty/Unitary props)
- Some smashing occured:
- if [decl] is Type, we allow all eliminations (above or below [decl],
not sure why this is justified in general).
- if [decl] is Set, we used smashing for impredicativity, so only
small sorts are allowed (Prop, Set).
- if [decl] is Prop, only logical sorts are allowed: I has either
large universes inside it or more than 1 constructor.
This does not treat the case where only a Set appeared in I which
was previously accepted it seems.
All the standard library works with these changes. Still have to cleanup
kernel/indtypes.ml. It is a good time to have a whiskey with OJ.
Thanks to Peter Lumsdaine for bug reporting:
- fix externalisation of universe instances (still appearing when no Printing Universes)
- add [convert] and [convert_leq] tactics that keep track of evars and universe constraints.
- use them in [exact_check].
Fix odd behavior in inductive type declarations allowing to silently lower a Type i parameter
to Set for squashing a naturally Type i inductive to Set. Reinstate the LargeNonPropInductiveNotInType
exception.
Fix the is_small function not dealing properly with aliases of Prop/Set in Type.
Add check_leq in Evd and use it to decide if we're trying to squash an
inductive naturally in some Type to Set.
- Fix handling of universe polymorphism in typeclasses Class/Instance declarations.
- Don't allow lowering a rigid Type universe to Set silently.
- Move Ring/Field back to Type. It was silently putting R in Set due to the definition of ring_morph.
- Rework inference of universe levels for inductive definitions.
- Make fold_left/right polymorphic on both levels A and B (the list's type). They don't have to be
at the same level.
Handle selective Polymorphic/Monomorphic flag right for records.
Remove leftover command
Fix after update with latest trunk.
Backport patches on HoTT/coq to rebased version of universe polymorphism.
- Fix autorewrite wrong handling of universe-polymorphic rewrite rules. Fixes part of issue #7.
- Fix the [eq_constr_univs] and add an [leq_constr_univs] to avoid eager equation of universe
levels that could just be inequal. Use it during kernel conversion. Fixes issue #6.
- Fix a bug in unification that was failing too early if a choice in unification of universes
raised an inconsistency.
- While normalizing universes, remove Prop in the le part of Max expressions.
- Stop rigidifying the universes on the right hand side of a : in definitions.
- Now Hints can be declared polymorphic or not. In the first case they
must be "refreshed" (undefined universes are renamed) at each application.
- Have to refresh the set of universe variables associated to a hint
when it can be used multiple times in a single proof to avoid fixing
a level... A better & less expensive solution should exist.
- Do not include the levels of let-ins as part of records levels.
- Fix a NotConvertible uncaught exception to raise a more informative
error message.
- Better substitution of algebraics in algebraics (for universe variables that
can be algebraics).
- Fix issue #2, Context was not properly normalizing the universe context.
- Fix issue with typeclasses that were not catching UniverseInconsistencies
raised by unification, resulting in early failure of proof-search.
- Let the result type of definitional classes be an algebraic.
- Adapt coercions to universe polymorphic flag (Identity Coercion etc..)
- Move away a dangerous call in autoinstance that added constraints for every
polymorphic definitions once in the environment for no use.
Forgot one part of the last patch on coercions.
- Adapt auto/eauto to polymorphic hints as well.
- Factor out the function to refresh a clenv w.r.t. undefined universes.
Use leq_univ_poly in evarconv to avoid fixing universes.
Disallow polymorphic hints based on a constr as it is not possible to infer their universe
context. Only global references can be made polymorphic. Fixes issue #8.
Fix SearchAbout bug (issue #10).
Fix program w.r.t. universes: the universe context of a definition changes
according to the successive refinements due to typechecking obligations.
This requires the Proof modules to return the generated universe substitution
when finishing a proof, and this information is passed in the closing hook.
The interface is not very clean, will certainly change in the future.
- Better treatment of polymorphic hints in auto: terms can be polymorphic now, we refresh their
context as well.
- Needs a little change in test-pattern that seems breaks multiary uses of destruct in NZDiv.v, l495.
FIX to do.
Fix [make_pattern_test] to keep the universe information around and still
allow tactics to take multiple patterns at once.
- Fix printing of universe instances that should not be factorized blindly
- Fix handling of the universe context in program definitions by allowing the
hook at the end of an interactive proof to give back the refined universe context,
before it is transformed in the kernel.
- Fix a bug in evarconv where solve_evar_evar was not checking types of instances,
resulting in a loss of constraints in unification of universes and a growing number
of useless parametric universes.
- Move from universe_level_subst to universe_subst everywhere.
- Changed representation of universes for a canonical one
- Adapt the code so that universe variables might be substituted by
arbitrary universes (including algebraics). Not used yet except for
polymorphic universe variables instances.
- Adapt code to new constraint structure.
- Fix setoid rewrite handling of evars that was forgetting the initial
universe substitution !
- Fix code that was just testing conversion instead of keeping the
resulting universe constraints around in the proof engine.
- Make a version of reduction/fconv that deals with the more general
set of universe constraints.
- [auto using] should use polymorphic versions of the constants.
- When starting a proof, don't forget about the algebraic universes in
the universe context.
Rationalize substitution and normalization functions for universes.
Also change back the structure of universes to avoid considering levels
n+k as pure levels: they are universe expressions like max.
Everything is factored out in the Universes and Univ modules now and
the normalization functions can be efficient in the sense that they
can cache the normalized universes incrementally.
- Adapt normalize_context code to new normalization/substitution functions.
- Set more things to be polymorphic, e.g. in Ring or SetoidList for the rest
of the code to work properly while the constraint generation code is not adapted.
And temporarily extend the universe constraint code in univ to solve max(is) = max(js)
by first-order unification (these constraints should actually be implied not enforced).
- Fix romega plugin to use the right universes for polymorphic lists.
- Fix auto not refreshing the poly hints correctly.
- Proper postponing of universe constraints during unification, avoid making
arbitrary choices.
- Fix nf_evars_and* to keep the substitution around for later normalizations.
- Do add simplified universe constraints coming from unification during typechecking.
- Fix solve_by_tac in obligations to handle universes right, and the corresponding
substitution function.
Test global universe equality early during simplication of constraints.
Better hashconsing, but still not good on universe lists.
- Add postponing of "lub" constraints that should not be checked early,
they are implied by the others.
- Fix constructor tactic to use a fresh constructor instance avoiding
fixing universes.
- Use [eq_constr_universes] instead of [eq_constr_univs] everywhere,
this is the comparison function that doesn't care about the universe
instances.
- Almost all the library compiles in this new setting, but some more tactics
need to be adapted.
- Reinstate hconsing.
- Keep Prop <= u constraints that can be used to set the level of a universe
metavariable.
Add better hashconsing and unionfind in normalisation of constraints.
Fix a few problems in choose_canonical, normalization and substitution functions.
Fix after merge
Fixes after rebase with latest Coq trunk, everything compiles again,
albeit slowly in some cases.
- Fix module substitution and comparison of table keys in conversion
using the wrong order (should always be UserOrd now)
- Cleanup in universes, removing commented code.
- Fix normalization of universe context which was assigning global
levels to local ones. Should always be the other way!
- Fix universe implementation to implement sorted cons of universes
preserving order. Makes Univ.sup correct again, keeping universe in
normalized form.
- In evarconv.ml, allow again a Fix to appear as head of a weak-head normal
form (due to partially applied fixpoints).
- Catch anomalies of conversion as errors in reductionops.ml, sad but
necessary as eta-expansion might build ill-typed stacks like FProd,
[shift;app Rel 1], as it expands not only if the other side is rigid.
- Fix module substitution bug in auto.ml
- Fix case compilation: impossible cases compilation was generating useless universe
levels. Use an IDProp constant instead of the polymorphic identity to not influence
the level of the original type when building the case construct for the return type.
- Simplify normalization of universe constraints.
- Compute constructor levels of records correctly.
Fall back to levels for universe instances, avoiding issues of unification.
Add more to the test-suite for universe polymorphism.
Fix after rebase with trunk
Fix substitution of universes inside fields/params of records to be made
after all normalization is done and the level of the record has been
computed.
Proper sharing of lower bounds with fixed universes.
Conflicts:
library/universes.ml
library/universes.mli
Constraints were not enforced in compilation of cases
Fix after rebase with trunk
- Canonical projections up to universes
- Fix computation of class/record universe levels to allow
squashing to Prop/Set in impredicative set mode.
- Fix descend_in_conjunctions to properly instantiate projections with universes
- Avoid Context-bound variables taking extra universes in their associated universe context.
- Fix evar_define using the wrong direction when refreshing a universe under cumulativity
- Do not instantiate a local universe with some lower bound to a global one just because
they have the same local glb (they might not have the same one globally).
- Was loosing some global constraints during normalization (brought again by the kernel), fixed now.
- Proper [abstract] with polymorphic lemmas (polymorphic if the current proof is).
- Fix silly bug in autorewrite: any hint after the first one was always monomorphic.
- Fix fourier after rebase
- Refresh universes when checking types of metas in unification (avoid (sup (sup univ))).
- Speedup a script in FSetPositive.v
Rework definitions in RelationClasses and Morphisms to share universe
levels as much as possible. This factorizes many useless x <=
RelationClasses.foo constraints in code that uses setoid rewriting.
Slight incompatible change in the implicits for Reflexivity and
Irreflexivity as well.
- Share even more universes in Morphisms using a let.
- Use splay_prod instead of splay_prod_assum which doesn't reduce let's
to find a relation in setoid_rewrite
- Fix [Declare Instance] not properly dealing with let's in typeclass contexts.
Fixes in inductiveops, evarutil.
Patch by Yves Bertot to allow naming universes in inductive definitions.
Fixes in tacinterp not propagating evars correctly.
Fix for issue #27: lowering a Type to Prop is allowed during
inference (resulting in a Type (* Set *)) but kernel reduction
was wrongly refusing the equation [Type (*Set*) = Set].
Fix in interface of canonical structures: an instantiated polymorphic
projection is not needed to lookup a structure, just the projection name
is enough (reported by C. Cohen).
Move from universe inference to universe checking in the kernel.
All tactics have to be adapted so that they carry around their generated
constraints (living in their sigma), which is mostly straightforward.
The more important changes are when refering to Coq constants, the
tactics code is adapted so that primitive eq, pairing and sigma types might
be polymorphic.
Fix another few places in tacinterp and evarconv/evarsolve where the sigma
was not folded correctly.
- Fix discharge adding spurious global constraints on polymorphic universe variables
appearing in assumptions.
- Fixes in inductiveops not taking into account universe polymorphic inductives.
WIP on checked universe polymorphism, it is clearly incompatible
with the previous usage of polymorphic inductives + non-polymorphic
definitions on them as universe levels now appear in the inductive type,
and add equality constraints between universes that were otherwise just
in a cumulativity relation (not sure that was actually correct).
Refined version of unification of universe instances for first-order unification,
prefering unfolding to arbitrary identification of universes.
Moved kernel to universe checking only.
Adapt the code to properly infer constraints during typechecking and
refinement (tactics) and only check constraints when adding
constants/inductives to the environment. Exception made of module
subtyping that needs inference of constraints... The kernel conversion
(fconv) has two modes: checking only and inference, the later being used
by modules only. Evarconv/unification make use of a different strategy for
conversion of constants that prefer unfolding to blind unification of
rigid universes. Likewise, conversion checking backtracks on different universe
instances (modulo the constraints).
- adapt congruence/funind/ring plugins to this new mode, forcing them to
declare their constraints.
- To avoid big performance penalty with reification, make ring/field non-polymorphic
(non-linear explosion in run time to be investigated further).
- pattern and change tactics need special treatment: as they are not _reduction_
but conversion functions, their operation requires to update an evar_map with
new universe constraints.
- Fix vm_compute to work better with universes. If the normal
form is made only of constructors then the readback is correct. However a deeper change will
be needed to treat substitution of universe instances when unfolding constants.
Remove libtypes.ml
Fix after merge.
Fix after rebase with trunk.
**** Add projections to the kernel, as optimized implementations of constants.
- New constructor Proj expects a projection constant applied to its principal
inductive argument.
- Reduction machines shortcut the expansion to a case and directly project the
right argument.
- No need to keep parameters as part of the projection's arguments as they
are inferable from the type of the principal argument.
- ML code now compiles, debugging needed.
Start debugging the implementation of projections. Externalisation should
keep the information about projections.
Internalization, pattern-matching, unification and reduction
of projections.
Fix some code that used to have _ for parameters that are no longer
present in projections.
Fixes in unification, reduction, term indexing, auto hints based on projections,
add debug printers.
Fix byte-compilation of projections, unification, congruence with projections.
Adapt .v files using "@proj _ _ record" syntax, should come back on this later.
Fix coercion insertion code to properly deal with projection coercions.
Fix [simpl proj]... TODO [unfold proj], proj is not considered evaluable.
- Fix whnf of projections, now respecting opacity information.
- Fix conversion of projections to try first-order first and then
incrementally unfold them.
- Fix computation of implicit args for projections, simply dropping
the information for parameters.
- Fix a few scripts that relied on projections carrying their parameters (few at's,
rewrites).
- Fix unify_with_subterm to properly match under projections.
- Fix bug in cooking of projections.
- Add pattern PProj for projections.
- A very strange bug appeared in BigZ.v, making coqtop segfault on the export
of BigN... tofix
Fixes after rebase with trunk. Everything compiles now, with efficient
projections.
Fixes after rebase with trunk (esp. reductionops).
Remove warnings, backport patch from old univs+projs branch.
Proper expansion of projections during unification.
They are considered as maybe flexible keys in evarconv/unification. We
try firstorder unification and otherwise expand them as necessary,
completely mimicking the original behavior, when they were
constants. Fix head_constr_bound interface, the arguments are never
needed (they're outside their environment actually). [simpl] and
[red]/[intro] should behave just like before now.
Fix evarconv that was giving up on proj x = ?e problems too early.
- Port patch by Maxime Denes implementing fast projections in the native conversion.
- Backport patch to add eta-expansion for records.
Do not raise an exception but simply fails if trying to do eta on an inductive that is not a record.
Fix projections detyping/matching and unification.ml not always
recovering on first-order universe inequalities.
Correct eta-expansion for records, and change strategy for conversion
with projections to favor reduction over first-order unification a
little more. Fix a bug in Ltac pattern matching on projections.
Fix evars_reset_evd to not recheck existing constraints in case it is just an update
(performance improvement for typeclass resolution).
- Respect Global/Transparent oracle during unification. Opaque means
_never_ unfolded there.
- Add empty universes as well as the initial universes (having Prop < Set).
- Better display of universe inconsistencies.
- Add Beta Ziliani's patch to go fast avoiding imitation when possible.
- Allow instantiation by lower bound even if there are universes above
- (tentative) In refinement, avoid incremental refinement of terms
containing no holes and do it in one step (much faster on big terms).
Turned on only if not a checked command.
Remove dead code in univ/universes.ml and cleanup setup of hashconsing,
for a small speed and memory footprint improvement.
- Fix bug in unification using cumulativity when conversion should have been used.
- Fix unification of evars having type Type, no longer forcing them to be equal
(potentially more constraints): algorithm is now complete w.r.t. cumulativity.
- In clenvtac, use refine_nocheck as we are guaranteed to get well-typed terms
from unification now, including sufficient universe constraints. Small general
speedup.
- Fix inference of universe levels of inductive types to avoid smashing
inadvertently from Set to Prop.
- Fix computation of discharged hypotheses forgetting the arity in inductives.
- Fix wrong order in printing of universe inconsistency explanation
- Allow coercions between two polymorphic instances of the same inductive/constant.
- Do evar normalization and saturation by classes before trying to use program coercion
during pretyping.
- In unification, force equalities of universes when unifying the same rigid head constants.
- Fix omission of projections in constr_leq
- Fix [admit] tactic's handling of normalized universes.
Fix typing of projections not properly normalizing w.r.t. evars, resulting in anomaly sometimes.
Adapt rewrite to work with computational relations (in Type), while
maintaining backward compatibility with Propositional rewriting.
Introduce a [diff] function on evar maps and universe contexts to
properly deal with clause environments. Local hints in auto now store
just the extension of the evar map they rely on, so merging them becomes
efficient. This fixes an important performance issue in auto and typeclass
resolution in presence of a large number of universe constraints.
Change FSetPositive and MSetPositive to put their [elt] and [t] universes in
Type to avoid restricting global universes to [Set]. This is due to [flip]s
polymorphic type being fixed in monomorphic instances of Morphisms.v,
and rewriting hence forcing unification of levels that could be left unrelated.
- Try a fast_typeops implementation of kernel type inference that
allocates less by not rebuilding the term, shows a little performance
improvement, and less allocation.
- Build universe inconsistency explanations lazily, avoiding huge blowup
(x5) in check_constraints/merge_constraints in time and space (these
are stressed in universe polymorphic mode).
- Hashcons universe instances.
Add interface file for fast_typeops
Use monomorphic comparisons, little optimizations of hashconsing and
comparison in univ.ml.
Fix huge slowdown due to building huge error messages. Lazy is not
enough to tame this completely.
Fix last performance issue, due to abstracts building huge terms abstracting on parts of the section
context. Was due to wrong handling of Let... Qed.s in abstract. Performance is a tiny bit better than the
trunk now.
First step at compatibility layer for projections.
Compatibility mode for projections. c.(p), p c use primitive projs,
while @p refers to an expansion [λ params c, c.(p)]. Recovers almost
entire source compatibility with trunk scripts, except when mixing
@p and p and doing syntactic matching (they're unifiable though).
Add a [Set Primitive Projections] flag to set/unset the use of primitive
projections, selectively for each record. Adapt code to handle both the
legacy encoding and the primitive projections. Library is almost
source-to-source compatible, except for syntactic operations relying
on the presence of parameters. In primitive projections mode, @p refers
to an expansion [λ params r. p.(r)]. More information in CHANGES (to be
reformated/moved to reference manual).
Backport changes from HoTT/coq:
- Fix anomaly on uncatched NotASort in retyping.
- Better recognition of evars that are subject to typeclass resolution.
Fixes bug reported by J. Gross on coq-club.
- Print universe polymorphism information for parameters as well.
Fix interface for unsatisfiable constraints error, now a type error.
Try making ring polymorphic again, with a big slowdown, to be investigated.
Fix evar/universe leak in setoid rewrite.
- Add profiling flag
- Move setoid_ring back to non-polymorphic mode to compare perfs with trunk
- Change unification to allow using infer_conv more often (big perf culprit),
but semantics of backtracking on unification of constants is not properly
implemented there.
- Fix is_empty/union_evar_universe_context forgetting about some assignments.
- Performance is now very close to the trunk from june,
with projections deactivated.
403 files changed, 17014 insertions, 7278 deletions
diff --git a/.gitignore b/.gitignore index 5b4ffa77b..6624f901a 100644 --- a/.gitignore +++ b/.gitignore @@ -153,3 +153,4 @@ ide/index_urls.txt dev/ocamldoc/html/ dev/ocamldoc/coq.* dev/ocamldoc/ocamldoc.sty +dev/myinclude @@ -1,6 +1,38 @@ Changes from V8.4 ================= +Logic + +- Primitive projections for records allow for a compact representation of +projections, without parameters and avoid the behavior of defined +projections that can unfold to a case expression. To turn the use of +native projections on, use [Set Primitive Projections]. Record, Class +and Structure types defined while this option is set will be defined +with primitive projections instead of the usual encoding as a case +expression. For compatibility, when p is a primitive projection, @p can +be used to refer to the projection with explicit parameters, i.e. [@p] +is definitionaly equal to [λ params r. r.(p)]. Records with primitive +projections have eta-conversion, the canonical form being +[mkR pars (p1 t) ... (pn t)]. + + With native projections, the parsing of projection applications changes: +- r.(p) and (p r) elaborate to native projection application, and the + parameters cannot be mentionned. The following arguments are + parsed according to the remaining implicits declared for the projection + (i.e. the implicits after the record type argument). In dot notation, + the record type argument is considered explicit no matter what its + implicit status is. +- r.(@p params) and @p args are parsed as regular applications of the projection + with explicit parameters. +- [simpl p] is forbidden, but [simpl @p] will simplify both the projection + and it's explicit [@p] version. +- [unfold p] has no effect on projection applications unless it is applied + to a constructor. If the explicit version appears it reduces to the + projection application. +- [pattern x at n], [rewrite x at n] and in general abstraction and selection + of occurrences may fail due to the disappearance of parameters. + + Vernacular commands - The command "Record foo ..." does not generate induction principles @@ -258,7 +258,21 @@ devdocclean: .PHONY: tags printenv tags: - echo $(MLIFILES) $(MLSTATICFILES) $(ML4FILES) | sort -r | xargs \ + echo $(filter-out checker/%, $(MLIFILES)) $(filter-out checker/%, $(MLSTATICFILES)) $(ML4FILES) | sort -r | xargs \ + etags --language=none\ + "--regex=/let[ \t]+\([^ \t]+\)/\1/" \ + "--regex=/let[ \t]+rec[ \t]+\([^ \t]+\)/\1/" \ + "--regex=/and[ \t]+\([^ \t]+\)/\1/" \ + "--regex=/type[ \t]+\([^ \t]+\)/\1/" \ + "--regex=/exception[ \t]+\([^ \t]+\)/\1/" \ + "--regex=/val[ \t]+\([^ \t]+\)/\1/" \ + "--regex=/module[ \t]+\([^ \t]+\)/\1/" + echo $(ML4FILES) | sort -r | xargs \ + etags --append --language=none\ + "--regex=/[ \t]*\([^: \t]+\)[ \t]*:/\1/" + +checker-tags: + echo $(filter-out kernel/%, $(MLIFILES)) $(filter-out kernel/%, $(MLSTATICFILES)) $(ML4FILES) | sort -r | xargs \ etags --language=none\ "--regex=/let[ \t]+\([^ \t]+\)/\1/" \ "--regex=/let[ \t]+rec[ \t]+\([^ \t]+\)/\1/" \ diff --git a/Makefile.build b/Makefile.build index db2d0f720..6d12063ca 100644 --- a/Makefile.build +++ b/Makefile.build @@ -59,7 +59,7 @@ CURDEPS:=$(addsuffix .d, $(CURFILES)) VERBOSE= NO_RECOMPILE_ML4= NO_RECALC_DEPS= -READABLE_ML4= # non-empty means .ml of .ml4 will be ascii instead of binary +READABLE_ML4=true # non-empty means .ml of .ml4 will be ascii instead of binary VALIDATE= COQ_XML= # is "-xml" when building XML library VM= # is "-no-vm" to not use the vm" diff --git a/checker/cic.mli b/checker/cic.mli index 380093c57..d2f785abf 100644 --- a/checker/cic.mli +++ b/checker/cic.mli @@ -163,14 +163,7 @@ type engagement = ImpredicativeSet (** {6 Representation of constants (Definition/Axiom) } *) -type polymorphic_arity = { - poly_param_levels : Univ.universe option list; - poly_level : Univ.universe; -} - -type constant_type = - | NonPolymorphicType of constr - | PolymorphicArity of rel_context * polymorphic_arity +type constant_type = constr (** Inlining level of parameters at functor applications. This is ignored by the checker. *) @@ -203,15 +196,6 @@ type recarg = type wf_paths = recarg Rtree.t -type monomorphic_inductive_arity = { - mind_user_arity : constr; - mind_sort : sorts; -} - -type inductive_arity = -| Monomorphic of monomorphic_inductive_arity -| Polymorphic of polymorphic_arity - type one_inductive_body = { (** {8 Primitive datas } *) @@ -219,7 +203,7 @@ type one_inductive_body = { mind_arity_ctxt : rel_context; (** Arity context of [Ii] with parameters: [forall params, Ui] *) - mind_arity : inductive_arity; (** Arity sort and original user arity if monomorphic *) + mind_arity : constr; (** Arity sort and original user arity if monomorphic *) mind_consnames : Id.t array; (** Names of the constructors: [cij] *) diff --git a/checker/declarations.ml b/checker/declarations.ml index baf2e57db..4dd814d57 100644 --- a/checker/declarations.ml +++ b/checker/declarations.ml @@ -433,6 +433,9 @@ let subst_constant_def sub = function | Def c -> Def (subst_constr_subst sub c) | OpaqueDef lc -> OpaqueDef (subst_lazy_constr sub lc) +(** Local variables and graph *) +type universe_context = Univ.LSet.t * Univ.constraints + let body_of_constant cb = match cb.const_body with | Undef _ -> None | Def c -> Some (force_constr c) @@ -488,9 +491,8 @@ let eq_wf_paths = Rtree.equal eq_recarg with In (params) : Un := cn1 : Tn1 | ... | cnpn : Tnpn *) -let subst_arity sub = function -| NonPolymorphicType s -> NonPolymorphicType (subst_mps sub s) -| PolymorphicArity (ctx,s) -> PolymorphicArity (subst_rel_context sub ctx,s) +let subst_arity sub s = subst_mps sub s + (* TODO: should be changed to non-coping after Term.subst_mps *) (* NB: we leave bytecode and native code fields untouched *) @@ -499,14 +501,6 @@ let subst_const_body sub cb = const_body = subst_constant_def sub cb.const_body; const_type = subst_arity sub cb.const_type } -let subst_arity sub = function -| Monomorphic s -> - Monomorphic { - mind_user_arity = subst_mps sub s.mind_user_arity; - mind_sort = s.mind_sort; - } -| Polymorphic s as x -> x - let subst_mind_packet sub mbp = { mind_consnames = mbp.mind_consnames; mind_consnrealdecls = mbp.mind_consnrealdecls; diff --git a/checker/environ.ml b/checker/environ.ml index eb084a910..79234e9e2 100644 --- a/checker/environ.ml +++ b/checker/environ.ml @@ -77,7 +77,7 @@ let push_rec_types (lna,typarray,_) env = (* Universe constraints *) let add_constraints c env = - if c == empty_constraint then + if c == Constraint.empty then env else let s = env.env_stratification in diff --git a/checker/indtypes.ml b/checker/indtypes.ml index a64232442..5927e1633 100644 --- a/checker/indtypes.ml +++ b/checker/indtypes.ml @@ -139,14 +139,12 @@ let typecheck_arity env params inds = let nparamargs = rel_context_nhyps params in let nparamdecls = rel_context_length params in let check_arity arctxt = function - Monomorphic mar -> - let ar = mar.mind_user_arity in - let _ = infer_type env ar in - conv env (it_mkProd_or_LetIn (Sort mar.mind_sort) arctxt) ar; - ar - | Polymorphic par -> - check_polymorphic_arity env params par; - it_mkProd_or_LetIn (Sort(Type par.poly_level)) arctxt in + mar -> + let _ = infer_type env mar in + mar in + (* | Polymorphic par -> *) + (* check_polymorphic_arity env params par; *) + (* it_mkProd_or_LetIn (Sort(Type par.poly_level)) arctxt in *) let env_arities = Array.fold_left (fun env_ar ind -> @@ -178,11 +176,11 @@ let typecheck_arity env params inds = let check_predicativity env s small level = match s, engagement env with Type u, _ -> - let u' = fresh_local_univ () in - let cst = - merge_constraints (enforce_leq u u' empty_constraint) - (universes env) in - if not (check_leq cst level u') then + (* let u' = fresh_local_univ () in *) + (* let cst = *) + (* merge_constraints (enforce_leq u u' empty_constraint) *) + (* (universes env) in *) + if not (check_leq (universes env) level u) then failwith "impredicative Type inductive type" | Prop Pos, Some ImpredicativeSet -> () | Prop Pos, _ -> @@ -191,8 +189,8 @@ let check_predicativity env s small level = let sort_of_ind = function - Monomorphic mar -> mar.mind_sort - | Polymorphic par -> Type par.poly_level + mar -> snd (destArity mar) + (* | Polymorphic par -> Type par.poly_level *) let all_sorts = [InProp;InSet;InType] let small_sorts = [InProp;InSet] diff --git a/checker/inductive.ml b/checker/inductive.ml index e6a24f705..b32379b35 100644 --- a/checker/inductive.ml +++ b/checker/inductive.ml @@ -161,11 +161,11 @@ let rec make_subst env = function (* (actualize_decl_level), then to the conclusion of the arity (via *) (* the substitution) *) let ctx,subst = make_subst env (sign, exp, []) in - if polymorphism_on_non_applied_parameters then - let s = fresh_local_univ () in - let t = actualize_decl_level env (Type s) t in - (na,None,t)::ctx, cons_subst u s subst - else + (* if polymorphism_on_non_applied_parameters then *) + (* let s = fresh_local_univ () in *) + (* let t = actualize_decl_level env (Type s) t in *) + (* (na,None,t)::ctx, cons_subst u s subst *) + (* else *) d::ctx, subst | sign, [], _ -> (* Uniform parameters are exhausted *) @@ -173,23 +173,21 @@ let rec make_subst env = function | [], _, _ -> assert false -let instantiate_universes env ctx ar argsorts = - let args = Array.to_list argsorts in - let ctx,subst = make_subst env (ctx,ar.poly_param_levels,args) in - let level = subst_large_constraints subst ar.poly_level in - ctx, - if is_type0m_univ level then Prop Null - else if is_type0_univ level then Prop Pos - else Type level +(* let instantiate_universes env ctx ar argsorts = *) +(* let args = Array.to_list argsorts in *) +(* let ctx,subst = make_subst env (ctx,ar.poly_param_levels,args) in *) +(* let level = subst_large_constraints subst ar.poly_level in *) +(* ctx, *) +(* if is_type0m_univ level then Prop Null *) +(* else if is_type0_univ level then Prop Pos *) +(* else Type level *) let type_of_inductive_knowing_parameters env mip paramtyps = - match mip.mind_arity with - | Monomorphic s -> - s.mind_user_arity - | Polymorphic ar -> - let ctx = List.rev mip.mind_arity_ctxt in - let ctx,s = instantiate_universes env ctx ar paramtyps in - mkArity (List.rev ctx,s) + mip.mind_arity + (* | Polymorphic ar -> *) + (* let ctx = List.rev mip.mind_arity_ctxt in *) + (* let ctx,s = instantiate_universes env ctx ar paramtyps in *) + (* mkArity (List.rev ctx,s) *) (* Type of a (non applied) inductive type *) @@ -236,9 +234,7 @@ let error_elim_expln kp ki = (* Get type of inductive, with parameters instantiated *) let inductive_sort_family mip = - match mip.mind_arity with - | Monomorphic s -> family_of_sort s.mind_sort - | Polymorphic _ -> InType + family_of_sort (snd (destArity mip.mind_arity)) let mind_arity mip = mip.mind_arity_ctxt, inductive_sort_family mip diff --git a/checker/inductive.mli b/checker/inductive.mli index 0e9b9ccf3..082bdae19 100644 --- a/checker/inductive.mli +++ b/checker/inductive.mli @@ -54,8 +54,8 @@ val type_of_inductive_knowing_parameters : val max_inductive_sort : sorts array -> Univ.universe -val instantiate_universes : env -> rel_context -> - polymorphic_arity -> constr array -> rel_context * sorts +(* val instantiate_universes : env -> rel_context -> *) +(* inductive_arity -> constr array -> rel_context * sorts *) (***************************************************************) (* Debug *) diff --git a/checker/mod_checking.ml b/checker/mod_checking.ml index add993581..4f4cc5560 100644 --- a/checker/mod_checking.ml +++ b/checker/mod_checking.ml @@ -14,31 +14,30 @@ open Environ (** {6 Checking constants } *) -let refresh_arity ar = - let ctxt, hd = decompose_prod_assum ar in - match hd with - Sort (Type u) when not (Univ.is_univ_variable u) -> - let u' = Univ.fresh_local_univ() in - mkArity (ctxt,Type u'), - Univ.enforce_leq u u' Univ.empty_constraint - | _ -> ar, Univ.empty_constraint +(* let refresh_arity ar = *) +(* let ctxt, hd = decompose_prod_assum ar in *) +(* match hd with *) +(* Sort (Type u) when not (Univ.is_univ_variable u) -> *) +(* let u' = Univ.fresh_local_univ() in *) +(* mkArity (ctxt,Type u'), *) +(* Univ.enforce_leq u u' Univ.empty_constraint *) +(* | _ -> ar, Univ.empty_constraint *) let check_constant_declaration env kn cb = Flags.if_verbose ppnl (str " checking cst: " ++ prcon kn); (* let env = add_constraints cb.const_constraints env in*) (match cb.const_type with - NonPolymorphicType ty -> - let ty, cu = refresh_arity ty in - let envty = add_constraints cu env in - let _ = infer_type envty ty in - (match body_of_constant cb with + ty -> + let env' = add_constraints cb.const_constraints env in + let _ = infer_type env' ty in + (match body_of_constant cb with | Some bd -> - let j = infer env bd in - conv_leq envty j ty + let j = infer env' bd in + conv_leq env' j ty | None -> ()) - | PolymorphicArity(ctxt,par) -> - let _ = check_ctxt env ctxt in - check_polymorphic_arity env ctxt par); + (* | PolymorphicArity(ctxt,par) -> *) + (* let _ = check_ctxt env ctxt in *) + (* check_polymorphic_arity env ctxt par *)); add_constant kn cb env diff --git a/checker/term.ml b/checker/term.ml index ea81f5dab..67d380336 100644 --- a/checker/term.ml +++ b/checker/term.ml @@ -347,7 +347,7 @@ let compare_sorts s1 s2 = match s1, s2 with | Pos, Null -> false | Null, Pos -> false end -| Type u1, Type u2 -> Universe.equal u1 u2 +| Type u1, Type u2 -> Universe.eq u1 u2 | Prop _, Type _ -> false | Type _, Prop _ -> false diff --git a/checker/typeops.ml b/checker/typeops.ml index 95753769d..6a705b198 100644 --- a/checker/typeops.ml +++ b/checker/typeops.ml @@ -67,12 +67,11 @@ let judge_of_relative env n = (* Type of constants *) let type_of_constant_knowing_parameters env t paramtyps = - match t with - | NonPolymorphicType t -> t - | PolymorphicArity (sign,ar) -> - let ctx = List.rev sign in - let ctx,s = instantiate_universes env ctx ar paramtyps in - mkArity (List.rev ctx,s) + t + (* | PolymorphicArity (sign,ar) -> *) + (* let ctx = List.rev sign in *) + (* let ctx,s = instantiate_universes env ctx ar paramtyps in *) + (* mkArity (List.rev ctx,s) *) let type_of_constant_type env t = type_of_constant_knowing_parameters env t [||] @@ -220,14 +219,14 @@ let type_fixpoint env lna lar lbody vdefj = (************************************************************************) -let refresh_arity env ar = - let ctxt, hd = decompose_prod_assum ar in - match hd with - Sort (Type u) when not (is_univ_variable u) -> - let u' = fresh_local_univ() in - let env' = add_constraints (enforce_leq u u' empty_constraint) env in - env', mkArity (ctxt,Type u') - | _ -> env, ar +(* let refresh_arity env ar = *) +(* let ctxt, hd = decompose_prod_assum ar in *) +(* match hd with *) +(* Sort (Type u) when not (is_univ_variable u) -> *) +(* let u' = fresh_local_univ() in *) +(* let env' = add_constraints (enforce_leq u u' empty_constraint) env in *) +(* env', mkArity (ctxt,Type u') *) +(* | _ -> env, ar *) (* The typing machine. *) @@ -282,7 +281,7 @@ let rec execute env cstr = (* /!\ c2 can be an inferred type => refresh (but the pushed type is still c2) *) let _ = - let env',c2' = refresh_arity env c2 in + let env',c2' = (* refresh_arity env *) env, c2 in let _ = execute_type env' c2' in judge_of_cast env' (c1,j1) DEFAULTcast c2' in let env1 = push_rel (name,Some c1,c2) env in @@ -365,14 +364,14 @@ let check_kind env ar u = if snd (dest_prod env ar) = Sort(Type u) then () else failwith "not the correct sort" -let check_polymorphic_arity env params par = - let pl = par.poly_param_levels in - let rec check_p env pl params = - match pl, params with - Some u::pl, (na,None,ty)::params -> - check_kind env ty u; - check_p (push_rel (na,None,ty) env) pl params - | None::pl,d::params -> check_p (push_rel d env) pl params - | [], _ -> () - | _ -> failwith "check_poly: not the right number of params" in - check_p env pl (List.rev params) +(* let check_polymorphic_arity env params par = *) +(* let pl = par.poly_param_levels in *) +(* let rec check_p env pl params = *) +(* match pl, params with *) +(* Some u::pl, (na,None,ty)::params -> *) +(* check_kind env ty u; *) +(* check_p (push_rel (na,None,ty) env) pl params *) +(* | None::pl,d::params -> check_p (push_rel d env) pl params *) +(* | [], _ -> () *) +(* | _ -> failwith "check_poly: not the right number of params" in *) +(* check_p env pl (List.rev params) *) diff --git a/checker/typeops.mli b/checker/typeops.mli index 92535606f..97d79fe54 100644 --- a/checker/typeops.mli +++ b/checker/typeops.mli @@ -16,8 +16,8 @@ open Environ val infer : env -> constr -> constr val infer_type : env -> constr -> sorts val check_ctxt : env -> rel_context -> env -val check_polymorphic_arity : - env -> rel_context -> polymorphic_arity -> unit +(* val check_polymorphic_arity : *) +(* env -> rel_context -> polymorphic_arity -> unit *) -val type_of_constant_type : env -> constant_type -> constr +val type_of_constant_type : env -> constr -> constr diff --git a/dev/base_include b/dev/base_include index c889d17eb..c58a35748 100644 --- a/dev/base_include +++ b/dev/base_include @@ -93,6 +93,7 @@ open Evarutil open Evarsolve open Tacred open Evd +open Universes open Termops open Namegen open Indrec diff --git a/dev/include b/dev/include index 23fcbd8db..58fff078b 100644 --- a/dev/include +++ b/dev/include @@ -29,12 +29,25 @@ #install_printer (* pattern *) pppattern;; #install_printer (* glob_constr *) ppglob_constr;; - +#install_printer (* open constr *) ppopenconstr;; #install_printer (* constr *) ppconstr;; #install_printer (* constr_substituted *) ppsconstr;; +#install_printer (* constraints *) ppconstraints;; +#install_printer (* univ constraints *) ppuniverseconstraints;; #install_printer (* universe *) ppuni;; #install_printer (* universes *) ppuniverses;; -#install_printer (* constraints *) ppconstraints;; +#install_printer (* univ level *) ppuni_level;; +#install_printer (* univ context *) ppuniverse_context;; +#install_printer (* univ context set *) ppuniverse_context_set;; +#install_printer (* univ set *) ppuniverse_set;; +#install_printer (* univ instance *) ppuniverse_instance;; +#install_printer (* univ subst *) ppuniverse_subst;; +#install_printer (* univ full subst *) ppuniverse_level_subst;; +#install_printer (* univ opt subst *) ppuniverse_opt_subst;; +#install_printer (* evar univ ctx *) ppevar_universe_context;; +#install_printer (* constraints_map *) ppconstraints_map;; +#install_printer (* inductive *) ppind;; +#install_printer (* 'a scheme_kind *) ppscheme;; #install_printer (* type_judgement *) pptype;; #install_printer (* judgement *) ppj;; diff --git a/dev/myinclude b/dev/myinclude new file mode 100644 index 000000000..48de3647a --- /dev/null +++ b/dev/myinclude @@ -0,0 +1 @@ +#use "include";; diff --git a/dev/printers.mllib b/dev/printers.mllib index 1e2764997..fb8d4c73e 100644 --- a/dev/printers.mllib +++ b/dev/printers.mllib @@ -82,6 +82,7 @@ Type_errors Modops Inductive Typeops +Fast_typeops Indtypes Cooking Term_typing @@ -89,6 +90,7 @@ Subtyping Mod_typing Nativelibrary Safe_typing +Unionfind Summary Nameops @@ -107,6 +109,7 @@ Locusops Miscops Termops Namegen +Universes Evd Glob_ops Redops @@ -188,4 +191,9 @@ Himsg Cerrors Locality Vernacinterp +Dischargedhypsmap +Discharge +Declare +Ind_tables Top_printers + diff --git a/dev/top_printers.ml b/dev/top_printers.ml index 7d6370b9d..31c5e608a 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -22,6 +22,7 @@ open Evd open Goptions open Genarg open Clenv +open Universes let _ = Constrextern.print_evar_arguments := true let _ = Constrextern.print_universes := true @@ -44,9 +45,11 @@ let ppmp mp = pp(str (string_of_mp mp)) let ppcon con = pp(debug_pr_con con) let ppkn kn = pp(pr_kn kn) let ppmind kn = pp(debug_pr_mind kn) +let ppind (kn,i) = pp(debug_pr_mind kn ++ str"," ++int i) let ppsp sp = pp(pr_path sp) let ppqualid qid = pp(pr_qualid qid) let ppclindex cl = pp(Classops.pr_cl_index cl) +let ppscheme k = pp (Ind_tables.pr_scheme_kind k) let pprecarg = function | Declarations.Norec -> str "Norec" @@ -60,6 +63,7 @@ let ppwf_paths x = pp (Rtree.pp_tree pprecarg x) let rawdebug = ref false let ppevar evk = pp (str (Evd.string_of_existential evk)) let ppconstr x = pp (Termops.print_constr x) +let ppconstr_expr x = pp (Ppconstr.pr_constr_expr x) let ppconstrdb x = pp(Flags.with_option rawdebug Termops.print_constr x) let ppterm = ppconstr let ppsconstr x = ppconstr (Mod_subst.force_constr x) @@ -67,7 +71,6 @@ let ppconstr_univ x = Constrextern.with_universes ppconstr x let ppglob_constr = (fun x -> pp(pr_lglob_constr x)) let pppattern = (fun x -> pp(pr_constr_pattern x)) let pptype = (fun x -> try pp(pr_ltype x) with e -> pp (str (Printexc.to_string e))) - let ppfconstr c = ppconstr (Closure.term_of_fconstr c) let ppbigint n = pp (str (Bigint.to_string n));; @@ -145,6 +148,10 @@ let ppexistentialfilter filter = match Evd.Filter.repr filter with let ppclenv clenv = pp(pr_clenv clenv) let ppgoalgoal gl = pp(Goal.pr_goal gl) let ppgoal g = pp(Printer.pr_goal g) +let ppgoalsigma g = pp(Printer.pr_goal g ++ pr_evar_map None (Refiner.project g)) + +let ppopenconstr (x : Evd.open_constr) = + let (evd,c) = x in pp (pr_evar_map (Some 2) evd ++ pr_constr c) (* spiwack: deactivated until a replacement is found let pppftreestate p = pp(print_pftreestate p) *) @@ -163,10 +170,20 @@ let pppftreestate p = pp(print_pftreestate p) (* let pproof p = pp(print_proof Evd.empty empty_named_context p) *) let ppuni u = pp(pr_uni u) - -let ppuniverses u = pp (str"[" ++ pr_universes u ++ str"]") - +let ppuni_level u = pp (Level.pr u) +let ppuniverses u = pp (str"[" ++ Universe.pr u ++ str"]") + +let ppuniverse_set l = pp (LSet.pr l) +let ppuniverse_instance l = pp (Instance.pr l) +let ppuniverse_context l = pp (pr_universe_context l) +let ppuniverse_context_set l = pp (pr_universe_context_set l) +let ppuniverse_subst l = pp (Univ.pr_universe_subst l) +let ppuniverse_opt_subst l = pp (Universes.pr_universe_opt_subst l) +let ppuniverse_level_subst l = pp (Univ.pr_universe_level_subst l) +let ppevar_universe_context l = pp (Evd.pr_evar_universe_context l) +let ppconstraints_map c = pp (Universes.pr_constraints_map c) let ppconstraints c = pp (pr_constraints c) +let ppuniverseconstraints c = pp (UniverseConstraints.pr c) let ppenv e = pp (str "[" ++ pr_named_context_of e ++ str "]" ++ spc() ++ @@ -202,12 +219,13 @@ let constr_display csr = ^(term_display t)^","^(term_display c)^")" | App (c,l) -> "App("^(term_display c)^","^(array_display l)^")\n" | Evar (e,l) -> "Evar("^(string_of_existential e)^","^(array_display l)^")" - | Const c -> "Const("^(string_of_con c)^")" - | Ind (sp,i) -> - "MutInd("^(string_of_mind sp)^","^(string_of_int i)^")" - | Construct ((sp,i),j) -> + | Const (c,u) -> "Const("^(string_of_con c)^","^(universes_display u)^")" + | Ind ((sp,i),u) -> + "MutInd("^(string_of_mind sp)^","^(string_of_int i)^","^(universes_display u)^")" + | Construct (((sp,i),j),u) -> "MutConstruct(("^(string_of_mind sp)^","^(string_of_int i)^")," - ^(string_of_int j)^")" + ^","^(universes_display u)^(string_of_int j)^")" + | Proj (p, c) -> "Proj("^(string_of_con p)^","^term_display c ^")" | Case (ci,p,c,bl) -> "MutCase(<abs>,"^(term_display p)^","^(term_display c)^"," ^(array_display bl)^")" @@ -231,13 +249,22 @@ let constr_display csr = (fun x i -> (term_display x)^(if not(i="") then (";"^i) else "")) v "")^"|]" + and univ_display u = + incr cnt; pp (str "with " ++ int !cnt ++ str" " ++ pr_uni u ++ fnl ()) + + and level_display u = + incr cnt; pp (str "with " ++ int !cnt ++ str" " ++ Level.pr u ++ fnl ()) + and sort_display = function | Prop(Pos) -> "Prop(Pos)" | Prop(Null) -> "Prop(Null)" - | Type u -> - incr cnt; pp (str "with " ++ int !cnt ++ pr_uni u ++ fnl ()); + | Type u -> univ_display u; "Type("^(string_of_int !cnt)^")" + and universes_display l = + Array.fold_right (fun x i -> level_display x; (string_of_int !cnt)^(if not(i="") + then (" "^i) else "")) (Instance.to_array l) "" + and name_display = function | Name id -> "Name("^(Id.to_string id)^")" | Anonymous -> "Anonymous" @@ -282,19 +309,28 @@ let print_pure_constr csr = | Evar (e,l) -> print_string "Evar#"; print_int (Evar.repr e); print_string "{"; Array.iter (fun x -> print_space (); box_display x) l; print_string"}" - | Const c -> print_string "Cons("; + | Const (c,u) -> print_string "Cons("; sp_con_display c; + print_string ","; universes_display u; + print_string ")" + | Proj (p,c') -> print_string "Proj("; + sp_con_display p; + print_string ","; + box_display c'; print_string ")" - | Ind (sp,i) -> + | Ind ((sp,i),u) -> print_string "Ind("; sp_display sp; print_string ","; print_int i; + print_string ","; universes_display u; print_string ")" - | Construct ((sp,i),j) -> + | Construct (((sp,i),j),u) -> print_string "Constr("; sp_display sp; print_string ","; - print_int i; print_string ","; print_int j; print_string ")" + print_int i; print_string ","; print_int j; + print_string ","; universes_display u; + print_string ")" | Case (ci,p,c,bl) -> open_vbox 0; print_string "<"; box_display p; print_string ">"; @@ -336,6 +372,9 @@ let print_pure_constr csr = and box_display c = open_hovbox 1; term_display c; close_box() + and universes_display u = + Array.iter (fun u -> print_space (); pp (Level.pr u)) (Instance.to_array u) + and sort_display = function | Prop(Pos) -> print_string "Set" | Prop(Null) -> print_string "Prop" @@ -404,7 +443,7 @@ let in_current_context f c = let (evmap,sign) = try Pfedit.get_current_goal_context () with e when Logic.catchable_exception e -> (Evd.empty, Global.env()) in - f (Constrintern.interp_constr evmap sign c) + f (fst (Constrintern.interp_constr evmap sign c))(*FIXME*) (* We expand the result of preprocessing to be independent of camlp4 diff --git a/grammar/q_constr.ml4 b/grammar/q_constr.ml4 index a731ade68..cf671adcb 100644 --- a/grammar/q_constr.ml4 +++ b/grammar/q_constr.ml4 @@ -18,7 +18,7 @@ let dloc = <:expr< Loc.ghost >> let apply_ref f l = <:expr< - Glob_term.GApp ($dloc$, Glob_term.GRef ($dloc$, Lazy.force $f$), $mlexpr_of_list (fun x -> x) l$) + Glob_term.GApp ($dloc$, Glob_term.GRef ($dloc$, Lazy.force $f$, None), $mlexpr_of_list (fun x -> x) l$) >> EXTEND @@ -74,7 +74,7 @@ EXTEND | "?"; id = ident -> <:expr< Glob_term.GPatVar($dloc$,(False,$id$)) >> | "{"; c1 = constr; "}"; "+"; "{"; c2 = constr; "}" -> apply_ref <:expr< coq_sumbool_ref >> [c1;c2] - | "%"; e = string -> <:expr< Glob_term.GRef ($dloc$,Lazy.force $lid:e$) >> + | "%"; e = string -> <:expr< Glob_term.GRef ($dloc$,Lazy.force $lid:e$, None) >> | c = match_constr -> c | "("; c = constr LEVEL "200"; ")" -> c ] ] ; diff --git a/grammar/q_coqast.ml4 b/grammar/q_coqast.ml4 index b3f60dee6..9a0a22b9f 100644 --- a/grammar/q_coqast.ml4 +++ b/grammar/q_coqast.ml4 @@ -140,10 +140,10 @@ let mlexpr_of_binder_kind = function $mlexpr_of_binding_kind b'$ $mlexpr_of_bool b''$ >> let rec mlexpr_of_constr = function - | Constrexpr.CRef (Libnames.Ident (loc,id)) when is_meta (Id.to_string id) -> + | Constrexpr.CRef (Libnames.Ident (loc,id),_) when is_meta (Id.to_string id) -> let loc = of_coqloc loc in anti loc (Id.to_string id) - | Constrexpr.CRef r -> <:expr< Constrexpr.CRef $mlexpr_of_reference r$ >> + | Constrexpr.CRef (r,n) -> <:expr< Constrexpr.CRef $mlexpr_of_reference r$ None >> | Constrexpr.CFix (loc,_,_) -> failwith "mlexpr_of_constr: TODO" | Constrexpr.CCoFix (loc,_,_) -> failwith "mlexpr_of_constr: TODO" | Constrexpr.CProdN (loc,l,a) -> @@ -154,8 +154,9 @@ let rec mlexpr_of_constr = function let loc = of_coqloc loc in <:expr< Constrexpr.CLambdaN $dloc$ $mlexpr_of_list (mlexpr_of_triple (mlexpr_of_list (mlexpr_of_pair (fun _ -> dloc) mlexpr_of_name)) mlexpr_of_binder_kind mlexpr_of_constr) l$ $mlexpr_of_constr a$ >> | Constrexpr.CLetIn (loc,_,_,_) -> failwith "mlexpr_of_constr: TODO" - | Constrexpr.CAppExpl (loc,a,l) -> + | Constrexpr.CAppExpl (loc,(p,r,us),l) -> let loc = of_coqloc loc in + let a = (p,r) in <:expr< Constrexpr.CAppExpl $dloc$ $mlexpr_of_pair (mlexpr_of_option mlexpr_of_int) mlexpr_of_reference a$ $mlexpr_of_list mlexpr_of_constr l$ >> | Constrexpr.CApp (loc,a,l) -> let loc = of_coqloc loc in diff --git a/interp/constrexpr_ops.ml b/interp/constrexpr_ops.ml index 85ad1cee7..1ba0cafa7 100644 --- a/interp/constrexpr_ops.ml +++ b/interp/constrexpr_ops.ml @@ -91,10 +91,16 @@ and cases_pattern_notation_substitution_eq (s1, n1) (s2, n2) = List.equal cases_pattern_expr_eq s1 s2 && List.equal (List.equal cases_pattern_expr_eq) n1 n2 +let eq_universes u1 u2 = + match u1, u2 with + | None, None -> true + | Some l, Some l' -> l = l' + | _, _ -> false + let rec constr_expr_eq e1 e2 = if e1 == e2 then true else match e1, e2 with - | CRef r1, CRef r2 -> eq_reference r1 r2 + | CRef (r1,u1), CRef (r2,u2) -> eq_reference r1 r2 && eq_universes u1 u2 | CFix(_,id1,fl1), CFix(_,id2,fl2) -> eq_located Id.equal id1 id2 && List.equal fix_expr_eq fl1 fl2 @@ -111,7 +117,7 @@ let rec constr_expr_eq e1 e2 = Name.equal na1 na2 && constr_expr_eq a1 a2 && constr_expr_eq b1 b2 - | CAppExpl(_,(proj1,r1),al1), CAppExpl(_,(proj2,r2),al2) -> + | CAppExpl(_,(proj1,r1,_),al1), CAppExpl(_,(proj2,r2,_),al2) -> Option.equal Int.equal proj1 proj2 && eq_reference r1 r2 && List.equal constr_expr_eq al1 al2 @@ -221,8 +227,8 @@ and constr_notation_substitution_eq (e1, el1, bl1) (e2, el2, bl2) = List.equal (List.equal local_binder_eq) bl1 bl2 let constr_loc = function - | CRef (Ident (loc,_)) -> loc - | CRef (Qualid (loc,_)) -> loc + | CRef (Ident (loc,_),_) -> loc + | CRef (Qualid (loc,_),_) -> loc | CFix (loc,_,_) -> loc | CCoFix (loc,_,_) -> loc | CProdN (loc,_,_) -> loc @@ -272,8 +278,8 @@ let local_binders_loc bll = match bll with (** Pseudo-constructors *) -let mkIdentC id = CRef (Ident (Loc.ghost, id)) -let mkRefC r = CRef r +let mkIdentC id = CRef (Ident (Loc.ghost, id),None) +let mkRefC r = CRef (r,None) let mkCastC (a,k) = CCast (Loc.ghost,a,k) let mkLambdaC (idl,bk,a,b) = CLambdaN (Loc.ghost,[idl,bk,a],b) let mkLetInC (id,a,b) = CLetIn (Loc.ghost,id,a,b) @@ -324,13 +330,13 @@ let coerce_reference_to_id = function str "This expression should be a simple identifier.") let coerce_to_id = function - | CRef (Ident (loc,id)) -> (loc,id) + | CRef (Ident (loc,id),_) -> (loc,id) | a -> Errors.user_err_loc (constr_loc a,"coerce_to_id", str "This expression should be a simple identifier.") let coerce_to_name = function - | CRef (Ident (loc,id)) -> (loc,Name id) + | CRef (Ident (loc,id),_) -> (loc,Name id) | CHole (loc,_,_) -> (loc,Anonymous) | a -> Errors.user_err_loc (constr_loc a,"coerce_to_name", diff --git a/interp/constrextern.ml b/interp/constrextern.ml index 6a893bde6..e4ac9426b 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -439,6 +439,11 @@ let occur_name na aty = let is_projection nargs = function | Some r when not !Flags.raw_print && !print_projections -> + if true (* FIXME *) (* !Record.primitive_flag *) then + (match r with + | ConstRef c when Environ.is_projection c (Global.env ()) -> Some 1 + | _ -> None) + else (try let n = Recordops.find_projection_nparams r + 1 in if n <= nargs then Some n else None @@ -477,10 +482,12 @@ let explicitize loc inctx impl (cf,f) args = | args, [] -> List.map (fun a -> (a,None)) args (*In case of polymorphism*) | [], _ -> [] in match is_projection (List.length args) cf with - | Some i as ip -> + | Some i -> if not (List.is_empty impl) && is_status_implicit (List.nth impl (i-1)) then - let f' = match f with CRef f -> f | _ -> assert false in - CAppExpl (loc,(ip,f'),args) + let args = exprec 1 (args,impl) in + CApp (loc, (None, f), args) + (* let f',us = match f with CRef (f,us) -> f,us | _ -> assert false in *) + (* CAppExpl (loc,(ip,f',us),args) *) else let (args1,args2) = List.chop i args in let (impl1,impl2) = if List.is_empty impl then [],[] else List.chop i impl in @@ -488,29 +495,29 @@ let explicitize loc inctx impl (cf,f) args = let args2 = exprec (i+1) (args2,impl2) in CApp (loc,(Some (List.length args1),f),args1@args2) | None -> - let args = exprec 1 (args,impl) in - if List.is_empty args then f else CApp (loc, (None, f), args) + let args = exprec 1 (args,impl) in + if List.is_empty args then f else CApp (loc, (None, f), args) -let extern_global loc impl f = +let extern_global loc impl f us = if not !Constrintern.parsing_explicit && not (List.is_empty impl) && List.for_all is_status_implicit impl then - CAppExpl (loc, (None, f), []) + CAppExpl (loc, (None, f, us), []) else - CRef f + CRef (f,us) -let extern_app loc inctx impl (cf,f) args = +let extern_app loc inctx impl (cf,f) us args = if List.is_empty args then (* If coming from a notation "Notation a := @b" *) - CAppExpl (loc, (None, f), []) + CAppExpl (loc, (None, f, us), []) else if not !Constrintern.parsing_explicit && ((!Flags.raw_print || (!print_implicits && not !print_implicits_explicit_args)) && List.exists is_status_implicit impl) then - CAppExpl (loc, (is_projection (List.length args) cf, f), args) + CAppExpl (loc, (is_projection (List.length args) cf,f,us), args) else - explicitize loc inctx impl (cf,CRef f) args + explicitize loc inctx impl (cf,CRef (f,us)) args let rec extern_args extern scopes env args subscopes = match args with @@ -522,7 +529,7 @@ let rec extern_args extern scopes env args subscopes = extern argscopes env a :: extern_args extern scopes env args subscopes let rec remove_coercions inctx = function - | GApp (loc,GRef (_,r),args) as c + | GApp (loc,GRef (_,r,_),args) as c when not (!Flags.raw_print || !print_coercions) -> let nargs = List.length args in @@ -579,6 +586,10 @@ let extern_glob_sort = function | GType (Some _) as s when !print_universes -> s | GType _ -> GType None +let extern_universes = function + | Some _ as l when !print_universes -> l + | _ -> None + let rec extern inctx scopes vars r = let r' = remove_coercions inctx r in try @@ -590,11 +601,11 @@ let rec extern inctx scopes vars r = if !Flags.raw_print || !print_no_symbol then raise No_match; extern_symbol scopes vars r'' (uninterp_notations r'') with No_match -> match r' with - | GRef (loc,ref) -> + | GRef (loc,ref,us) -> extern_global loc (select_stronger_impargs (implicits_of_global ref)) - (extern_reference loc vars ref) + (extern_reference loc vars ref) (extern_universes us) - | GVar (loc,id) -> CRef (Ident (loc,id)) + | GVar (loc,id) -> CRef (Ident (loc,id),None) | GEvar (loc,n,None) when !print_meta_as_hole -> CHole (loc, None, None) @@ -606,7 +617,7 @@ let rec extern inctx scopes vars r = | GApp (loc,f,args) -> (match f with - | GRef (rloc,ref) -> + | GRef (rloc,ref,us) -> let subscopes = find_arguments_scope ref in let args = extern_args (extern true) (snd scopes) vars args subscopes in @@ -652,11 +663,24 @@ let rec extern inctx scopes vars r = | Not_found | No_match | Exit -> extern_app loc inctx (select_stronger_impargs (implicits_of_global ref)) - (Some ref,extern_reference rloc vars ref) args + (Some ref,extern_reference rloc vars ref) (extern_universes us) args end + + | GProj (loc,p,c) -> + let ref = ConstRef p in + let subscopes = find_arguments_scope ref in + let args = + extern_args (extern true) (snd scopes) vars (c :: args) subscopes + in + extern_app loc inctx [] (Some ref, extern_reference loc vars ref) + None args + | _ -> - explicitize loc inctx [] (None,sub_extern false scopes vars f) - (List.map (sub_extern true scopes vars) args)) + explicitize loc inctx [] (None,sub_extern false scopes vars f) + (List.map (sub_extern true scopes vars) args)) + + | GProj (loc,p,c) -> + extern inctx scopes vars (GApp (loc,r',[])) | GLetIn (loc,na,t,c) -> CLetIn (loc,(loc,na),sub_extern false scopes vars t, @@ -816,7 +840,7 @@ and extern_symbol (tmp_scope,scopes as allscopes) vars t = function let args1, args2 = List.chop n args in let subscopes, impls = match f with - | GRef (_,ref) -> + | GRef (_,ref,us) -> let subscopes = try List.skipn n (find_arguments_scope ref) with Failure _ -> [] in @@ -830,13 +854,13 @@ and extern_symbol (tmp_scope,scopes as allscopes) vars t = function [], [] in (if Int.equal n 0 then f else GApp (Loc.ghost,f,args1)), args2, subscopes, impls - | GApp (_,(GRef (_,ref) as f),args), None -> + | GApp (_,(GRef (_,ref,us) as f),args), None -> let subscopes = find_arguments_scope ref in let impls = select_impargs_size (List.length args) (implicits_of_global ref) in f, args, subscopes, impls - | GRef _, Some 0 -> GApp (Loc.ghost,t,[]), [], [], [] + | GRef (_,ref,us), Some 0 -> GApp (Loc.ghost,t,[]), [], [], [] | _, None -> t, [], [], [] | _ -> raise No_match in (* Try matching ... *) @@ -871,7 +895,7 @@ and extern_symbol (tmp_scope,scopes as allscopes) vars t = function List.map (fun (c,(scopt,scl)) -> extern true (scopt,scl@scopes) vars c, None) terms in - let a = CRef (Qualid (loc, shortest_qualid_of_syndef vars kn)) in + let a = CRef (Qualid (loc, shortest_qualid_of_syndef vars kn),None) in if List.is_empty l then a else CApp (loc,(None,a),l) in if List.is_empty args then e else @@ -934,7 +958,7 @@ let any_any_branch = (loc,[],[PatVar (loc,Anonymous)],GHole (loc,Evar_kinds.InternalHole,None)) let rec glob_of_pat env = function - | PRef ref -> GRef (loc,ref) + | PRef ref -> GRef (loc,ref,None) | PVar id -> GVar (loc,id) | PEvar (n,l) -> GEvar (loc,n,Some (Array.map_to_list (glob_of_pat env) l)) | PRel n -> @@ -946,6 +970,7 @@ let rec glob_of_pat env = function GVar (loc,id) | PMeta None -> GHole (loc,Evar_kinds.InternalHole, None) | PMeta (Some n) -> GPatVar (loc,(false,n)) + | PProj (p,c) -> GApp (loc,GRef (loc, ConstRef p,None),[glob_of_pat env c]) | PApp (f,args) -> GApp (loc,glob_of_pat env f,Array.map_to_list (glob_of_pat env) args) | PSoApp (n,args) -> diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 7fba83e66..0905ad1d6 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -93,7 +93,7 @@ let global_reference_of_reference ref = locate_reference (snd (qualid_of_reference ref)) let global_reference id = - constr_of_global (locate_reference (qualid_of_ident id)) + Universes.constr_of_global (locate_reference (qualid_of_ident id)) let construct_reference ctx id = try @@ -102,7 +102,7 @@ let construct_reference ctx id = global_reference id let global_reference_in_absolute_module dir id = - constr_of_global (Nametab.global_of_path (Libnames.make_path dir id)) + Universes.constr_of_global (Nametab.global_of_path (Libnames.make_path dir id)) (**********************************************************************) (* Internalization errors *) @@ -300,7 +300,7 @@ let reset_tmp_scope env = {env with tmp_scope = None} let set_scope env = function | CastConv (GSort _) -> set_type_scope env - | CastConv (GRef (_,ref) | GApp (_,GRef (_,ref),_)) -> + | CastConv (GRef (_,ref,_) | GApp (_,GRef (_,ref,_),_)) -> {env with tmp_scope = compute_scope_of_global ref} | _ -> env @@ -410,7 +410,7 @@ let intern_generalized_binder ?(global_level=false) intern_type lvar let name = let id = match ty with - | CApp (_, (_, CRef (Ident (loc,id))), _) -> id + | CApp (_, (_, CRef (Ident (loc,id),_)), _) -> id | _ -> Id.of_string "H" in Implicit_quantifiers.make_fresh ids' (Global.env ()) id in Name name @@ -650,7 +650,7 @@ let intern_var genv (ltacvars,ntnvars) namedctx loc id = try let ty,expl_impls,impls,argsc = Id.Map.find id genv.impls in let expl_impls = List.map - (fun id -> CRef (Ident (loc,id)), Some (loc,ExplByName id)) expl_impls in + (fun id -> CRef (Ident (loc,id),None), Some (loc,ExplByName id)) expl_impls in let tys = string_of_ty ty in Dumpglob.dump_reference loc "<>" (Id.to_string id) tys; GVar (loc,id), make_implicits_list impls, argsc, expl_impls @@ -682,19 +682,38 @@ let intern_var genv (ltacvars,ntnvars) namedctx loc id = let impls = implicits_of_global ref in let scopes = find_arguments_scope ref in Dumpglob.dump_reference loc "<>" (string_of_qualid (Decls.variable_secpath id)) "var"; - GRef (loc, ref), impls, scopes, [] + GRef (loc, ref, None), impls, scopes, [] with e when Errors.noncritical e -> (* [id] a goal variable *) GVar (loc,id), [], [], [] -let find_appl_head_data = function - | GRef (_,ref) as x -> x,implicits_of_global ref,find_arguments_scope ref,[] - | GApp (_,GRef (_,ref),l) as x +let is_projection_ref = function + | ConstRef r -> if Environ.is_projection r (Global.env ()) then Some r else None + | _ -> None + +let find_appl_head_data c = + match c with + | GRef (loc,ref,_) as x -> + let impls = implicits_of_global ref in + let isproj, impls = + match is_projection_ref ref with + | Some r -> true, List.map (projection_implicits (Global.env ()) r) impls + | None -> false, impls + in + let scopes = find_arguments_scope ref in + x, isproj, impls, scopes, [] + | GApp (_,GRef (_,ref,_),l) as x when l != [] && Flags.version_strictly_greater Flags.V8_2 -> let n = List.length l in - x,List.map (drop_first_implicits n) (implicits_of_global ref), - List.skipn_at_least n (find_arguments_scope ref),[] - | x -> x,[],[],[] + let impls = implicits_of_global ref in + let isproj, impls = + match is_projection_ref ref with + | Some r -> true, List.map (projection_implicits (Global.env ()) r) impls + | None -> false, impls + in + x, isproj, List.map (drop_first_implicits n) impls, + List.skipn_at_least n (find_arguments_scope ref),[] + | x -> x,false,[],[],[] let error_not_enough_arguments loc = user_err_loc (loc,"",str "Abbreviation is not applied enough.") @@ -726,8 +745,7 @@ let intern_reference ref = (* Is it a global reference or a syntactic definition? *) let intern_qualid loc qid intern env lvar args = match intern_extended_global_of_qualid (loc,qid) with - | TrueGlobal ref -> - GRef (loc, ref), args + | TrueGlobal ref -> GRef (loc, ref, None), args | SynDef sp -> let (ids,c) = Syntax_def.search_syntactic_definition sp in let nids = List.length ids in @@ -742,7 +760,7 @@ let intern_qualid loc qid intern env lvar args = (* Rule out section vars since these should have been found by intern_var *) let intern_non_secvar_qualid loc qid intern env lvar args = match intern_qualid loc qid intern env lvar args with - | GRef (_, VarRef _),_ -> raise Not_found + | GRef (_, VarRef _, _),_ -> raise Not_found | r -> r let intern_applied_reference intern env namedctx lvar args = function @@ -751,22 +769,24 @@ let intern_applied_reference intern env namedctx lvar args = function try intern_qualid loc qid intern env lvar args with Not_found -> error_global_not_found_loc loc qid in - find_appl_head_data r, args2 + let x, isproj, imp, scopes, l = find_appl_head_data r in + (x,imp,scopes,l), isproj, args2 | Ident (loc, id) -> - try intern_var env lvar namedctx loc id, args + try intern_var env lvar namedctx loc id, false, args with Not_found -> let qid = qualid_of_ident id in try let r,args2 = intern_non_secvar_qualid loc qid intern env lvar args in - find_appl_head_data r, args2 + let x, isproj, imp, scopes, l = find_appl_head_data r in + (x,imp,scopes,l), isproj, args2 with Not_found -> (* Extra allowance for non globalizing functions *) if !interning_grammar || env.unb then - (GVar (loc,id), [], [], []),args + (GVar (loc,id), [], [], []), false, args else error_global_not_found_loc loc qid let interp_reference vars r = - let (r,_,_,_),_ = + let (r,_,_,_),_,_ = intern_applied_reference (fun _ -> error_not_enough_arguments Loc.ghost) {ids = Id.Set.empty; unb = false ; tmp_scope = None; scopes = []; impls = empty_internalization_env} [] @@ -1276,10 +1296,9 @@ let merge_impargs l args = let check_projection isproj nargs r = match (r,isproj) with - | GRef (loc, ref), Some _ -> + | GRef (loc, ref, _), Some _ -> (try - let n = Recordops.find_projection_nparams ref + 1 in - if not (Int.equal nargs n) then + if not (Int.equal nargs 1) then user_err_loc (loc,"",str "Projection does not have the right number of explicit parameters."); with Not_found -> user_err_loc @@ -1291,7 +1310,8 @@ let get_implicit_name n imps = Some (Impargs.name_of_implicit (List.nth imps (n-1))) let set_hole_implicit i b = function - | GRef (loc,r) | GApp (_,GRef (loc,r),_) -> (loc,Evar_kinds.ImplicitArg (r,i,b),None) + | GRef (loc,r,_) | GApp (_,GRef (loc,r,_),_) -> (loc,Evar_kinds.ImplicitArg (r,i,b),None) + | GProj (loc,p,_) -> (loc,Evar_kinds.ImplicitArg (ConstRef p,i,b),None) | GVar (loc,id) -> (loc,Evar_kinds.ImplicitArg (VarRef id,i,b),None) | _ -> anomaly (Pp.str "Only refs have implicits") @@ -1335,14 +1355,17 @@ let extract_explicit_arg imps args = (**********************************************************************) (* Main loop *) +let is_projection_ref env = function + | ConstRef c -> Environ.is_projection c env + | _ -> false + let internalize globalenv env allow_patvar lvar c = let rec intern env = function - | CRef ref as x -> - let (c,imp,subscopes,l),_ = + | CRef (ref,us) as x -> + let (c,imp,subscopes,l),isproj,_ = intern_applied_reference intern env (Environ.named_context globalenv) lvar [] ref in - (match intern_impargs c env imp subscopes l with - | [] -> c - | l -> GApp (constr_loc x, c, l)) + apply_impargs (None, isproj) c env imp subscopes l (constr_loc x) + | CFix (loc, (locid,iddef), dl) -> let lf = List.map (fun ((_, id),_,_,_,_) -> id) dl in let dl = Array.of_list dl in @@ -1435,33 +1458,35 @@ let internalize globalenv env allow_patvar lvar c = | CDelimiters (loc, key, e) -> intern {env with tmp_scope = None; scopes = find_delimiters_scope loc key :: env.scopes} e - | CAppExpl (loc, (isproj,ref), args) -> - let (f,_,args_scopes,_),args = + | CAppExpl (loc, (isproj,ref,us), args) -> + let (f,_,args_scopes,_),_,args = let args = List.map (fun a -> (a,None)) args in - intern_applied_reference intern env (Environ.named_context globalenv) lvar args ref in - check_projection isproj (List.length args) f; + intern_applied_reference intern env (Environ.named_context globalenv) + lvar args ref in + (* check_projection isproj (List.length args) f; *) (* Rem: GApp(_,f,[]) stands for @f *) - GApp (loc, f, intern_args env args_scopes (List.map fst args)) + GApp (loc, f, intern_args env args_scopes (List.map fst args)) + | CApp (loc, (isproj,f), args) -> let isproj,f,args = match f with (* Compact notations like "t.(f args') args" *) - | CApp (_,(Some _,f), args') when not (Option.has_some isproj) -> isproj,f,args'@args + | CApp (_,(Some _ as isproj',f), args') when not (Option.has_some isproj) -> + isproj',f,args'@args (* Don't compact "(f args') args" to resolve implicits separately *) | _ -> isproj,f,args in - let (c,impargs,args_scopes,l),args = + let (c,impargs,args_scopes,l),isprojf,args = match f with - | CRef ref -> intern_applied_reference intern env (Environ.named_context globalenv) lvar args ref + | CRef (ref,us) -> + intern_applied_reference intern env + (Environ.named_context globalenv) lvar args ref | CNotation (loc,ntn,([],[],[])) -> let c = intern_notation intern env lvar loc ntn ([],[],[]) in - find_appl_head_data c, args - | x -> (intern env f,[],[],[]), args in - let args = - intern_impargs c env impargs args_scopes (merge_impargs l args) in - check_projection isproj (List.length args) c; - (match c with - (* Now compact "(f args') args" *) - | GApp (loc', f', args') -> GApp (Loc.merge loc' loc, f',args'@args) - | _ -> GApp (loc, c, args)) + let x, isproj, impl, scopes, l = find_appl_head_data c in + (x,impl,scopes,l), false, args + | x -> (intern env f,[],[],[]), false, args in + apply_impargs (isproj,isprojf) c env impargs args_scopes + (merge_impargs l args) loc + | CRecord (loc, _, fs) -> let cargs = sort_fields true loc fs @@ -1472,7 +1497,7 @@ let internalize globalenv env allow_patvar lvar c = | None -> user_err_loc (loc, "intern", str"No constructor inference.") | Some (n, constrname, args) -> let pars = List.make n (CHole (loc, None, None)) in - let app = CAppExpl (loc, (None, constrname), List.rev_append pars args) in + let app = CAppExpl (loc, (None, constrname,None), List.rev_append pars args) in intern env app end | CCases (loc, sty, rtnpo, tms, eqns) -> @@ -1500,7 +1525,7 @@ let internalize globalenv env allow_patvar lvar c = | [] -> Option.map (intern_type env') rtnpo (* Only PatVar in "in" clauses *) | l -> let thevars,thepats=List.split l in Some ( - GCases(Loc.ghost,Term.RegularStyle,Some (GSort (Loc.ghost,GType None)), (* "return Type" *) + GCases(Loc.ghost,Term.RegularStyle,(* Some (GSort (Loc.ghost,GType None)) *)None, (* "return Type" *) List.map (fun id -> GVar (Loc.ghost,id),(Name id,None)) thevars, (* "match v1,..,vn" *) [Loc.ghost,[],thepats, (* "|p1,..,pn" *) Option.cata (intern_type env') (GHole(Loc.ghost,Evar_kinds.CasesType,None)) rtnpo; (* "=> P" is there were a P "=> _" else *) @@ -1599,7 +1624,7 @@ let internalize globalenv env allow_patvar lvar c = (* the "as" part *) let extra_id,na = match tm', na with | GVar (loc,id), None when not (Id.Map.mem id (snd lvar)) -> Some id,(loc,Name id) - | GRef (loc, VarRef id), None -> Some id,(loc,Name id) + | GRef (loc, VarRef id, _), None -> Some id,(loc,Name id) | _, None -> None,(Loc.ghost,Anonymous) | _, Some (loc,na) -> None,(loc,na) in (* the "in" part *) @@ -1691,6 +1716,41 @@ let internalize globalenv env allow_patvar lvar c = intern_args env subscopes rargs in aux 1 l subscopes eargs rargs + and make_first_explicit (l, r) = + match r with + | hd :: tl -> l, None :: tl + | [] -> l, [] + + and apply_impargs (isproj,isprojf) c env imp subscopes l loc = + let l = + let imp = + if isprojf && isproj <> None then + (* Drop first implicit which corresponds to record given in c.(p) notation *) + List.map make_first_explicit imp + else imp + in intern_impargs c env imp subscopes l + in + if isprojf then + match c, l with + | GApp (loc', GRef (loc'', ConstRef f, _), hd :: tl), rest -> + let proj = GProj (Loc.merge loc'' (loc_of_glob_constr hd), f, hd) in + if List.is_empty tl then smart_gapp proj loc rest + else GApp (loc, proj, tl @ rest) + | GRef (loc', ConstRef f, _), hd :: tl -> + let proj = GProj (Loc.merge loc' (loc_of_glob_constr hd), f, hd) in + smart_gapp proj loc tl + | _ -> user_err_loc (loc, "apply_impargs", + str"Projection is not applied to enough arguments") + else + (* check_projection isproj *) + smart_gapp c loc l + + and smart_gapp f loc = function + | [] -> f + | l -> match f with + | GApp (loc', g, args) -> GApp (Loc.merge loc' loc, g, args@l) + | _ -> GApp (Loc.merge (loc_of_glob_constr f) loc, f, l) + and intern_args env subscopes = function | [] -> [] | a::args -> @@ -1871,7 +1931,7 @@ let interp_rawcontext_evars evdref env bl = (push_rel d env, d::params, succ n, impls) | Some b -> let c = understand_judgment_tcc evdref env b in - let d = (na, Some c.uj_val, Termops.refresh_universes c.uj_type) in + let d = (na, Some c.uj_val, c.uj_type) in (push_rel d env, d::params, succ n, impls)) (env,[],1,[]) (List.rev bl) in (env, par), impls diff --git a/interp/constrintern.mli b/interp/constrintern.mli index a0bcdc4f4..9ce6ec779 100644 --- a/interp/constrintern.mli +++ b/interp/constrintern.mli @@ -91,13 +91,13 @@ val intern_context : bool -> env -> internalization_env -> local_binder list -> (** Main interpretation functions expecting evars to be all resolved *) val interp_constr : evar_map -> env -> ?impls:internalization_env -> - constr_expr -> constr + constr_expr -> constr Univ.in_universe_context_set val interp_casted_constr : evar_map -> env -> ?impls:internalization_env -> - constr_expr -> types -> constr + constr_expr -> types -> constr Univ.in_universe_context_set val interp_type : evar_map -> env -> ?impls:internalization_env -> - constr_expr -> types + constr_expr -> types Univ.in_universe_context_set (** Main interpretation function expecting evars to be all resolved *) @@ -142,7 +142,7 @@ val interp_reference : ltac_sign -> reference -> glob_constr (** Interpret binders *) -val interp_binder : evar_map -> env -> Name.t -> constr_expr -> types +val interp_binder : evar_map -> env -> Name.t -> constr_expr -> types Univ.in_universe_context_set val interp_binder_evars : evar_map ref -> env -> Name.t -> constr_expr -> types @@ -153,6 +153,16 @@ val interp_context_evars : evar_map ref -> env -> local_binder list -> internalization_env * ((env * rel_context) * Impargs.manual_implicits) +(* val interp_context_gen : (env -> glob_constr -> unsafe_type_judgment Evd.in_evar_universe_context) -> *) +(* (env -> Evarutil.type_constraint -> glob_constr -> unsafe_judgment Evd.in_evar_universe_context) -> *) +(* ?global_level:bool -> ?impl_env:internalization_env -> *) +(* evar_map -> env -> local_binder list -> internalization_env * ((env * Evd.evar_universe_context * rel_context * sorts list) * Impargs.manual_implicits) *) + +(* val interp_context : ?global_level:bool -> ?impl_env:internalization_env -> *) +(* evar_map -> env -> local_binder list -> *) +(* internalization_env * *) +(* ((env * Evd.evar_universe_context * rel_context * sorts list) * Impargs.manual_implicits) *) + (** Locating references of constructions, possibly via a syntactic definition (these functions do not modify the glob file) *) diff --git a/interp/coqlib.ml b/interp/coqlib.ml index bf5d225b2..3df071aff 100644 --- a/interp/coqlib.ml +++ b/interp/coqlib.ml @@ -32,7 +32,7 @@ let find_reference locstr dir s = anomaly ~label:locstr (str "cannot find " ++ Libnames.pr_path sp) let coq_reference locstr dir s = find_reference locstr (coq::dir) s -let coq_constant locstr dir s = constr_of_global (coq_reference locstr dir s) +let coq_constant locstr dir s = Universes.constr_of_global (coq_reference locstr dir s) let gen_reference = coq_reference let gen_constant = coq_constant @@ -44,7 +44,7 @@ let has_suffix_in_dirs dirs ref = let global_of_extended q = try Some (global_of_extended_global q) with Not_found -> None -let gen_constant_in_modules locstr dirs s = +let gen_reference_in_modules locstr dirs s = let dirs = List.map make_dir dirs in let qualid = qualid_of_string s in let all = Nametab.locate_extended_all qualid in @@ -52,7 +52,7 @@ let gen_constant_in_modules locstr dirs s = let all = List.sort_uniquize RefOrdered_env.compare all in let these = List.filter (has_suffix_in_dirs dirs) all in match these with - | [x] -> constr_of_global x + | [x] -> x | [] -> anomaly ~label:locstr (str ("cannot find "^s^ " in module"^(if List.length dirs > 1 then "s " else " ")) ++ @@ -65,6 +65,9 @@ let gen_constant_in_modules locstr dirs s = str (" in module"^(if List.length dirs > 1 then "s " else " ")) ++ prlist_with_sep pr_comma pr_dirpath dirs) +let gen_constant_in_modules locstr dirs s = + Universes.constr_of_global (gen_reference_in_modules locstr dirs s) + (* For tactics/commands requiring vernacular libraries *) @@ -100,6 +103,10 @@ let logic_constant dir s = let d = "Logic"::dir in check_required_library (coq::d); gen_constant "Coqlib" d s +let logic_reference dir s = + let d = "Logic"::dir in + check_required_library ("Coq"::d); gen_reference "Coqlib" d s + let arith_dir = [coq;"Arith"] let arith_modules = [arith_dir] @@ -144,10 +151,14 @@ let make_con dir id = Globnames.encode_con dir (Id.of_string id) (** Identity *) -let id = make_con datatypes_module "id" -let type_of_id = make_con datatypes_module "ID" +let id = make_con datatypes_module "idProp" +let type_of_id = make_con datatypes_module "IDProp" -let _ = Termops.set_impossible_default_clause (mkConst id,mkConst type_of_id) +let _ = Termops.set_impossible_default_clause + (fun () -> + let c, ctx = Universes.fresh_global_instance (Global.env()) (ConstRef id) in + let (_, u) = destConst c in + (c,mkConstU (type_of_id,u)), ctx) (** Natural numbers *) let nat_kn = make_ind datatypes_module "nat" @@ -181,11 +192,11 @@ let jmeq_kn = make_ind jmeq_module "JMeq" let glob_jmeq = IndRef (jmeq_kn,0) type coq_sigma_data = { - proj1 : constr; - proj2 : constr; - elim : constr; - intro : constr; - typ : constr } + proj1 : global_reference; + proj2 : global_reference; + elim : global_reference; + intro : global_reference; + typ : global_reference } type coq_bool_data = { andb : constr; @@ -200,56 +211,58 @@ let build_bool_type () = let build_sigma_set () = anomaly (Pp.str "Use build_sigma_type") let build_sigma_type () = - { proj1 = init_constant ["Specif"] "projT1"; - proj2 = init_constant ["Specif"] "projT2"; - elim = init_constant ["Specif"] "sigT_rect"; - intro = init_constant ["Specif"] "existT"; - typ = init_constant ["Specif"] "sigT" } + { proj1 = init_reference ["Specif"] "projT1"; + proj2 = init_reference ["Specif"] "projT2"; + elim = init_reference ["Specif"] "sigT_rect"; + intro = init_reference ["Specif"] "existT"; + typ = init_reference ["Specif"] "sigT" } let build_sigma () = - { proj1 = init_constant ["Specif"] "proj1_sig"; - proj2 = init_constant ["Specif"] "proj2_sig"; - elim = init_constant ["Specif"] "sig_rect"; - intro = init_constant ["Specif"] "exist"; - typ = init_constant ["Specif"] "sig" } + { proj1 = init_reference ["Specif"] "proj1_sig"; + proj2 = init_reference ["Specif"] "proj2_sig"; + elim = init_reference ["Specif"] "sig_rect"; + intro = init_reference ["Specif"] "exist"; + typ = init_reference ["Specif"] "sig" } + let build_prod () = - { proj1 = init_constant ["Datatypes"] "fst"; - proj2 = init_constant ["Datatypes"] "snd"; - elim = init_constant ["Datatypes"] "prod_rec"; - intro = init_constant ["Datatypes"] "pair"; - typ = init_constant ["Datatypes"] "prod" } + { proj1 = init_reference ["Datatypes"] "fst"; + proj2 = init_reference ["Datatypes"] "snd"; + elim = init_reference ["Datatypes"] "prod_rec"; + intro = init_reference ["Datatypes"] "pair"; + typ = init_reference ["Datatypes"] "prod" } (* Equalities *) type coq_eq_data = { - eq : constr; - ind : constr; - refl : constr; - sym : constr; - trans: constr; - congr: constr } + eq : global_reference; + ind : global_reference; + refl : global_reference; + sym : global_reference; + trans: global_reference; + congr: global_reference } (* Data needed for discriminate and injection *) type coq_inversion_data = { - inv_eq : constr; (* : forall params, t -> Prop *) - inv_ind : constr; (* : forall params P y, eq params y -> P y *) - inv_congr: constr (* : forall params B (f:t->B) y, eq params y -> f c=f y *) + inv_eq : global_reference; (* : forall params, t -> Prop *) + inv_ind : global_reference; (* : forall params P y, eq params y -> P y *) + inv_congr: global_reference (* : forall params B (f:t->B) y, eq params y -> f c=f y *) } +let lazy_init_reference dir id = lazy (init_reference dir id) let lazy_init_constant dir id = lazy (init_constant dir id) -let lazy_logic_constant dir id = lazy (logic_constant dir id) +let lazy_logic_reference dir id = lazy (logic_reference dir id) (* Leibniz equality on Type *) -let coq_eq_eq = lazy_init_constant ["Logic"] "eq" -let coq_eq_refl = lazy_init_constant ["Logic"] "eq_refl" -let coq_eq_ind = lazy_init_constant ["Logic"] "eq_ind" -let coq_eq_congr = lazy_init_constant ["Logic"] "f_equal" -let coq_eq_sym = lazy_init_constant ["Logic"] "eq_sym" -let coq_eq_trans = lazy_init_constant ["Logic"] "eq_trans" -let coq_f_equal2 = lazy_init_constant ["Logic"] "f_equal2" +let coq_eq_eq = lazy_init_reference ["Logic"] "eq" +let coq_eq_refl = lazy_init_reference ["Logic"] "eq_refl" +let coq_eq_ind = lazy_init_reference ["Logic"] "eq_ind" +let coq_eq_congr = lazy_init_reference ["Logic"] "f_equal" +let coq_eq_sym = lazy_init_reference ["Logic"] "eq_sym" +let coq_eq_trans = lazy_init_reference ["Logic"] "eq_trans" +let coq_f_equal2 = lazy_init_reference ["Logic"] "f_equal2" let coq_eq_congr_canonical = - lazy_init_constant ["Logic"] "f_equal_canonical_form" + lazy_init_reference ["Logic"] "f_equal_canonical_form" let build_coq_eq_data () = let _ = check_required_library logic_module_name in { @@ -260,6 +273,9 @@ let build_coq_eq_data () = trans = Lazy.force coq_eq_trans; congr = Lazy.force coq_eq_congr } +let make_dirpath dir = + Names.make_dirpath (List.map id_of_string dir) + let build_coq_eq () = Lazy.force coq_eq_eq let build_coq_eq_refl () = Lazy.force coq_eq_refl let build_coq_eq_sym () = Lazy.force coq_eq_sym @@ -273,14 +289,15 @@ let build_coq_inversion_eq_data () = (* Heterogenous equality on Type *) -let coq_jmeq_eq = lazy_logic_constant ["JMeq"] "JMeq" -let coq_jmeq_refl = lazy_logic_constant ["JMeq"] "JMeq_refl" -let coq_jmeq_ind = lazy_logic_constant ["JMeq"] "JMeq_ind" -let coq_jmeq_sym = lazy_logic_constant ["JMeq"] "JMeq_sym" -let coq_jmeq_congr = lazy_logic_constant ["JMeq"] "JMeq_congr" -let coq_jmeq_trans = lazy_logic_constant ["JMeq"] "JMeq_trans" +let coq_jmeq_eq = lazy_logic_reference ["JMeq"] "JMeq" +let coq_jmeq_hom = lazy_logic_reference ["JMeq"] "JMeq_hom" +let coq_jmeq_refl = lazy_logic_reference ["JMeq"] "JMeq_refl" +let coq_jmeq_ind = lazy_logic_reference ["JMeq"] "JMeq_ind" +let coq_jmeq_sym = lazy_logic_reference ["JMeq"] "JMeq_sym" +let coq_jmeq_congr = lazy_logic_reference ["JMeq"] "JMeq_congr" +let coq_jmeq_trans = lazy_logic_reference ["JMeq"] "JMeq_trans" let coq_jmeq_congr_canonical = - lazy_logic_constant ["JMeq"] "JMeq_congr_canonical_form" + lazy_logic_reference ["JMeq"] "JMeq_congr_canonical_form" let build_coq_jmeq_data () = let _ = check_required_library jmeq_module_name in { @@ -291,14 +308,9 @@ let build_coq_jmeq_data () = trans = Lazy.force coq_jmeq_trans; congr = Lazy.force coq_jmeq_congr } -let join_jmeq_types eq = - mkLambda(Name (Id.of_string "A"),Termops.new_Type(), - mkLambda(Name (Id.of_string "x"),mkRel 1, - mkApp (eq,[|mkRel 2;mkRel 1;mkRel 2|]))) - let build_coq_inversion_jmeq_data () = let _ = check_required_library logic_module_name in { - inv_eq = join_jmeq_types (Lazy.force coq_jmeq_eq); + inv_eq = Lazy.force coq_jmeq_hom; inv_ind = Lazy.force coq_jmeq_ind; inv_congr = Lazy.force coq_jmeq_congr_canonical } @@ -308,13 +320,13 @@ let coq_sumbool = lazy_init_constant ["Specif"] "sumbool" let build_coq_sumbool () = Lazy.force coq_sumbool (* Equality on Type as a Type *) -let coq_identity_eq = lazy_init_constant ["Datatypes"] "identity" -let coq_identity_refl = lazy_init_constant ["Datatypes"] "identity_refl" -let coq_identity_ind = lazy_init_constant ["Datatypes"] "identity_ind" -let coq_identity_congr = lazy_init_constant ["Logic_Type"] "identity_congr" -let coq_identity_sym = lazy_init_constant ["Logic_Type"] "identity_sym" -let coq_identity_trans = lazy_init_constant ["Logic_Type"] "identity_trans" -let coq_identity_congr_canonical = lazy_init_constant ["Logic_Type"] "identity_congr_canonical_form" +let coq_identity_eq = lazy_init_reference ["Datatypes"] "identity" +let coq_identity_refl = lazy_init_reference ["Datatypes"] "identity_refl" +let coq_identity_ind = lazy_init_reference ["Datatypes"] "identity_ind" +let coq_identity_congr = lazy_init_reference ["Logic_Type"] "identity_congr" +let coq_identity_sym = lazy_init_reference ["Logic_Type"] "identity_sym" +let coq_identity_trans = lazy_init_reference ["Logic_Type"] "identity_trans" +let coq_identity_congr_canonical = lazy_init_reference ["Logic_Type"] "identity_congr_canonical_form" let build_coq_identity_data () = let _ = check_required_library datatypes_module_name in { @@ -333,9 +345,9 @@ let build_coq_inversion_identity_data () = inv_congr = Lazy.force coq_identity_congr_canonical } (* Equality to true *) -let coq_eq_true_eq = lazy_init_constant ["Datatypes"] "eq_true" -let coq_eq_true_ind = lazy_init_constant ["Datatypes"] "eq_true_ind" -let coq_eq_true_congr = lazy_init_constant ["Logic"] "eq_true_congr" +let coq_eq_true_eq = lazy_init_reference ["Datatypes"] "eq_true" +let coq_eq_true_ind = lazy_init_reference ["Datatypes"] "eq_true_ind" +let coq_eq_true_congr = lazy_init_reference ["Logic"] "eq_true_congr" let build_coq_inversion_eq_true_data () = let _ = check_required_library datatypes_module_name in diff --git a/interp/coqlib.mli b/interp/coqlib.mli index 9b0f8deb9..d253cf7dd 100644 --- a/interp/coqlib.mli +++ b/interp/coqlib.mli @@ -42,6 +42,7 @@ val gen_reference : message -> string list -> string -> global_reference (** Search in several modules (not prefixed by "Coq") *) val gen_constant_in_modules : string->string list list-> string -> constr +val gen_reference_in_modules : string->string list list-> string -> global_reference val arith_modules : string list list val zarith_base_modules : string list list val init_modules : string list list @@ -101,43 +102,49 @@ val build_bool_type : coq_bool_data delayed (** {6 For Equality tactics } *) type coq_sigma_data = { - proj1 : constr; - proj2 : constr; - elim : constr; - intro : constr; - typ : constr } + proj1 : global_reference; + proj2 : global_reference; + elim : global_reference; + intro : global_reference; + typ : global_reference } val build_sigma_set : coq_sigma_data delayed val build_sigma_type : coq_sigma_data delayed val build_sigma : coq_sigma_data delayed +(* val build_sigma_type_in : Environ.env -> coq_sigma_data Univ.in_universe_context_set *) +(* val build_sigma_in : Environ.env -> coq_sigma_data Univ.in_universe_context_set *) +(* val build_prod_in : Environ.env -> coq_sigma_data Univ.in_universe_context_set *) +(* val build_coq_eq_data_in : Environ.env -> coq_eq_data Univ.in_universe_context_set *) + (** Non-dependent pairs in Set from Datatypes *) val build_prod : coq_sigma_data delayed type coq_eq_data = { - eq : constr; - ind : constr; - refl : constr; - sym : constr; - trans: constr; - congr: constr } + eq : global_reference; + ind : global_reference; + refl : global_reference; + sym : global_reference; + trans: global_reference; + congr: global_reference } val build_coq_eq_data : coq_eq_data delayed + val build_coq_identity_data : coq_eq_data delayed val build_coq_jmeq_data : coq_eq_data delayed -val build_coq_eq : constr delayed (** = [(build_coq_eq_data()).eq] *) -val build_coq_eq_refl : constr delayed (** = [(build_coq_eq_data()).refl] *) -val build_coq_eq_sym : constr delayed (** = [(build_coq_eq_data()).sym] *) -val build_coq_f_equal2 : constr delayed +val build_coq_eq : global_reference delayed (** = [(build_coq_eq_data()).eq] *) +val build_coq_eq_refl : global_reference delayed (** = [(build_coq_eq_data()).refl] *) +val build_coq_eq_sym : global_reference delayed (** = [(build_coq_eq_data()).sym] *) +val build_coq_f_equal2 : global_reference delayed (** Data needed for discriminate and injection *) type coq_inversion_data = { - inv_eq : constr; (** : forall params, args -> Prop *) - inv_ind : constr; (** : forall params P (H : P params) args, eq params args + inv_eq : global_reference; (** : forall params, args -> Prop *) + inv_ind : global_reference; (** : forall params P (H : P params) args, eq params args -> P args *) - inv_congr: constr (** : forall params B (f:t->B) args, eq params args -> + inv_congr: global_reference (** : forall params B (f:t->B) args, eq params args -> f params = f args *) } diff --git a/interp/dumpglob.ml b/interp/dumpglob.ml index ca5b0eddd..80b5830fd 100644 --- a/interp/dumpglob.ml +++ b/interp/dumpglob.ml @@ -110,7 +110,7 @@ let type_of_global_ref gr = "var" ^ type_of_logical_kind (Decls.variable_kind v) | Globnames.IndRef ind -> let (mib,oib) = Inductive.lookup_mind_specif (Global.env ()) ind in - if mib.Declarations.mind_record then + if mib.Declarations.mind_record <> None then if mib.Declarations.mind_finite then "rec" else "corec" else if mib.Declarations.mind_finite then "ind" diff --git a/interp/implicit_quantifiers.ml b/interp/implicit_quantifiers.ml index 2d55a6b63..c69eb629d 100644 --- a/interp/implicit_quantifiers.ml +++ b/interp/implicit_quantifiers.ml @@ -90,8 +90,8 @@ let free_vars_of_constr_expr c ?(bound=Id.Set.empty) l = else l in let rec aux bdvars l c = match c with - | CRef (Ident (loc,id)) -> found loc id bdvars l - | CNotation (_, "{ _ : _ | _ }", (CRef (Ident (_, id)) :: _, [], [])) when not (Id.Set.mem id bdvars) -> + | CRef (Ident (loc,id),_) -> found loc id bdvars l + | CNotation (_, "{ _ : _ | _ }", (CRef (Ident (_, id),_) :: _, [], [])) when not (Id.Set.mem id bdvars) -> Topconstr.fold_constr_expr_with_binders (fun a l -> Id.Set.add a l) aux (Id.Set.add id bdvars) l c | c -> Topconstr.fold_constr_expr_with_binders (fun a l -> Id.Set.add a l) aux bdvars l c in aux bound l c @@ -127,6 +127,7 @@ let generalizable_vars_of_glob_constr ?(bound=Id.Set.empty) ?(allowed=Id.Set.emp else (id, loc) :: vs else vs | GApp (loc,f,args) -> List.fold_left (vars bound) vs (f::args) + | GProj (loc,p,c) -> vars bound vs c | GLambda (loc,na,_,ty,c) | GProd (loc,na,_,ty,c) | GLetIn (loc,na,ty,c) -> let vs' = vars bound vs ty in let bound' = add_name_to_ids bound na in @@ -241,19 +242,19 @@ let combine_params avoid fn applied needed = let combine_params_freevar = fun avoid (_, (na, _, _)) -> let id' = next_name_away_from na avoid in - (CRef (Ident (Loc.ghost, id')), Id.Set.add id' avoid) + (CRef (Ident (Loc.ghost, id'),None), Id.Set.add id' avoid) let destClassApp cl = match cl with - | CApp (loc, (None, CRef ref), l) -> loc, ref, List.map fst l - | CAppExpl (loc, (None, ref), l) -> loc, ref, l - | CRef ref -> loc_of_reference ref, ref, [] + | CApp (loc, (None, CRef (ref,_)), l) -> loc, ref, List.map fst l + | CAppExpl (loc, (None, ref,_), l) -> loc, ref, l + | CRef (ref,_) -> loc_of_reference ref, ref, [] | _ -> raise Not_found let destClassAppExpl cl = match cl with - | CApp (loc, (None, CRef ref), l) -> loc, ref, l - | CRef ref -> loc_of_reference ref, ref, [] + | CApp (loc, (None, CRef (ref,_)), l) -> loc, ref, l + | CRef (ref,_) -> loc_of_reference ref, ref, [] | _ -> raise Not_found let implicit_application env ?(allow_partial=true) f ty = @@ -285,7 +286,7 @@ let implicit_application env ?(allow_partial=true) f ty = end; let pars = List.rev (List.combine ci rd) in let args, avoid = combine_params avoid f par pars in - CAppExpl (loc, (None, id), args), avoid + CAppExpl (loc, (None, id, None), args), avoid in c, avoid let implicits_of_glob_constr ?(with_products=true) l = diff --git a/interp/modintern.ml b/interp/modintern.ml index 81d0a0f64..2d81194f2 100644 --- a/interp/modintern.ml +++ b/interp/modintern.ml @@ -61,7 +61,7 @@ let transl_with_decl env = function | CWith_Module ((_,fqid),qid) -> WithMod (fqid,lookup_module qid) | CWith_Definition ((_,fqid),c) -> - WithDef (fqid,interp_constr Evd.empty env c) + WithDef (fqid,fst (interp_constr Evd.empty env c)) (*FIXME*) let loc_of_module = function | CMident (loc,_) | CMapply (loc,_,_) | CMwith (loc,_,_) -> loc diff --git a/interp/notation.ml b/interp/notation.ml index 6e5ac5f33..6fd6001f4 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -258,12 +258,12 @@ let notations_key_table = ref (KeyMap.empty : notation_rule list KeyMap.t) let prim_token_key_table = ref KeyMap.empty let glob_prim_constr_key = function - | GApp (_,GRef (_,ref),_) | GRef (_,ref) -> RefKey (canonical_gr ref) + | GApp (_,GRef (_,ref,_),_) | GRef (_,ref,_) -> RefKey (canonical_gr ref) | _ -> Oth let glob_constr_keys = function - | GApp (_,GRef (_,ref),_) -> [RefKey (canonical_gr ref); Oth] - | GRef (_,ref) -> [RefKey (canonical_gr ref)] + | GApp (_,GRef (_,ref,_),_) -> [RefKey (canonical_gr ref); Oth] + | GRef (_,ref,_) -> [RefKey (canonical_gr ref)] | _ -> [Oth] let cases_pattern_key = function @@ -455,8 +455,8 @@ let interp_prim_token = let rec rcp_of_glob looked_for = function | GVar (loc,id) -> RCPatAtom (loc,Some id) | GHole (loc,_,_) -> RCPatAtom (loc,None) - | GRef (loc,g) -> looked_for g; RCPatCstr (loc, g,[],[]) - | GApp (loc,GRef (_,g),l) -> + | GRef (loc,g,_) -> looked_for g; RCPatCstr (loc, g,[],[]) + | GApp (loc,GRef (_,g,_),l) -> looked_for g; RCPatCstr (loc, g, List.map (rcp_of_glob looked_for) l,[]) | _ -> raise Not_found @@ -502,7 +502,7 @@ let uninterp_prim_token_ind_pattern ind args = if not b then raise Notation_ops.No_match; let args' = List.map (fun x -> snd (glob_constr_of_closed_cases_pattern x)) args in - let ref = GRef (Loc.ghost,ref) in + let ref = GRef (Loc.ghost,ref,None) in match numpr (GApp (Loc.ghost,ref,args')) with | None -> raise Notation_ops.No_match | Some n -> (sc,n) @@ -655,13 +655,13 @@ let rebuild_arguments_scope (req,r,l,_) = match req with | ArgsScopeNoDischarge -> assert false | ArgsScopeAuto -> - let scs,cls = compute_arguments_scope_full (Global.type_of_global r) in + let scs,cls = compute_arguments_scope_full (fst(Universes.type_of_global r)(*FIXME?*)) in (req,r,scs,cls) | ArgsScopeManual -> (* Add to the manually given scopes the one found automatically for the extra parameters of the section. Discard the classes of the manually given scopes to avoid further re-computations. *) - let l',cls = compute_arguments_scope_full (Global.type_of_global r) in + let l',cls = compute_arguments_scope_full (Global.type_of_global_unsafe r) in let nparams = List.length l' - List.length l in let l1 = List.firstn nparams l' in let cls1 = List.firstn nparams cls in @@ -705,7 +705,7 @@ let find_arguments_scope r = with Not_found -> [] let declare_ref_arguments_scope ref = - let t = Global.type_of_global ref in + let t = Global.type_of_global_unsafe ref in declare_arguments_scope_gen ArgsScopeAuto ref (compute_arguments_scope_full t) diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml index 12b256c45..4984bfc38 100644 --- a/interp/notation_ops.ml +++ b/interp/notation_ops.ml @@ -55,6 +55,7 @@ let ldots_var = Id.of_string ".." let glob_constr_of_notation_constr_with_binders loc g f e = function | NVar id -> GVar (loc,id) | NApp (a,args) -> GApp (loc,f e a, List.map (f e) args) + | NProj (p,c) -> GProj (loc,p,f e c) | NList (x,y,iter,tail,swap) -> let t = f e tail in let it = f e iter in let innerl = (ldots_var,t)::(if swap then [] else [x,GVar(loc,y)]) in @@ -106,7 +107,7 @@ let glob_constr_of_notation_constr_with_binders loc g f e = function | NSort x -> GSort (loc,x) | NHole (x, arg) -> GHole (loc, x, arg) | NPatVar n -> GPatVar (loc,(false,n)) - | NRef x -> GRef (loc,x) + | NRef x -> GRef (loc,x,None) let glob_constr_of_notation_constr loc x = let rec aux () x = @@ -146,9 +147,10 @@ let split_at_recursive_part c = let on_true_do b f c = if b then (f c; b) else b let compare_glob_constr f add t1 t2 = match t1,t2 with - | GRef (_,r1), GRef (_,r2) -> eq_gr r1 r2 + | GRef (_,r1,_), GRef (_,r2,_) -> eq_gr r1 r2 | GVar (_,v1), GVar (_,v2) -> on_true_do (Id.equal v1 v2) add (Name v1) | GApp (_,f1,l1), GApp (_,f2,l2) -> f f1 f2 && List.for_all2eq f l1 l2 + | GProj (_,p1,c1), GProj (_, p2, c2) -> eq_constant p1 p2 && f c1 c2 | GLambda (_,na1,bk1,ty1,c1), GLambda (_,na2,bk2,ty2,c2) when Name.equal na1 na2 && Constrexpr_ops.binding_kind_eq bk1 bk2 -> on_true_do (f ty1 ty2 && f c1 c2) add na1 @@ -164,7 +166,7 @@ let compare_glob_constr f add t1 t2 = match t1,t2 with | _,(GCases _ | GRec _ | GPatVar _ | GEvar _ | GLetTuple _ | GIf _ | GCast _) -> error "Unsupported construction in recursive notations." - | (GRef _ | GVar _ | GApp _ | GLambda _ | GProd _ + | (GRef _ | GVar _ | GApp _ | GProj _ | GLambda _ | GProd _ | GHole _ | GSort _ | GLetIn _), _ -> false @@ -259,6 +261,7 @@ let notation_constr_and_vars_of_glob_constr a = and aux' = function | GVar (_,id) -> add_id found id; NVar id | GApp (_,g,args) -> NApp (aux g, List.map aux args) + | GProj (_,p,c) -> NProj (p, aux c) | GLambda (_,na,bk,ty,c) -> add_name found na; NLambda (na,aux ty,aux c) | GProd (_,na,bk,ty,c) -> add_name found na; NProd (na,aux ty,aux c) | GLetIn (_,na,b,c) -> add_name found na; NLetIn (na,aux b,aux c) @@ -288,7 +291,7 @@ let notation_constr_and_vars_of_glob_constr a = | GCast (_,c,k) -> NCast (aux c,Miscops.map_cast_type aux k) | GSort (_,s) -> NSort s | GHole (_,w,arg) -> NHole (w, arg) - | GRef (_,r) -> NRef r + | GRef (_,r,_) -> NRef r | GPatVar (_,(_,n)) -> NPatVar n | GEvar _ -> error "Existential variables not allowed in notations." @@ -365,7 +368,7 @@ let rec subst_pat subst pat = match pat with | PatVar _ -> pat | PatCstr (loc,((kn,i),j),cpl,n) -> - let kn' = subst_ind subst kn + let kn' = subst_mind subst kn and cpl' = List.smartmap (subst_pat subst) cpl in if kn' == kn && cpl' == cpl then pat else PatCstr (loc,((kn',i),j),cpl',n) @@ -385,6 +388,12 @@ let rec subst_notation_constr subst bound raw = if r' == r && rl' == rl then raw else NApp(r',rl') + | NProj (p,c) -> + let p' = subst_constant subst p in + let c' = subst_notation_constr subst bound c in + if p == p' && c == c' then raw else + NProj (p',c') + | NList (id1,id2,r1,r2,b) -> let r1' = subst_notation_constr subst bound r1 and r2' = subst_notation_constr subst bound r2 in @@ -421,7 +430,7 @@ let rec subst_notation_constr subst bound raw = (fun (a,(n,signopt) as x) -> let a' = subst_notation_constr subst bound a in let signopt' = Option.map (fun ((indkn,i),nal as z) -> - let indkn' = subst_ind subst indkn in + let indkn' = subst_mind subst indkn in if indkn == indkn' then z else ((indkn',i),nal)) signopt in if a' == a && signopt' == signopt then x else (a',(n,signopt'))) rl @@ -658,7 +667,7 @@ let rec match_ inner u alp (tmetas,blmetas as metas) sigma a1 a2 = (* Matching compositionally *) | GVar (_,id1), NVar id2 when alpha_var id1 id2 alp -> sigma - | GRef (_,r1), NRef r2 when (eq_gr r1 r2) -> sigma + | GRef (_,r1,_), NRef r2 when (eq_gr r1 r2) -> sigma | GPatVar (_,(_,n1)), NPatVar n2 when Id.equal n1 n2 -> sigma | GApp (loc,f1,l1), NApp (f2,l2) -> let n1 = List.length l1 and n2 = List.length l2 in diff --git a/interp/topconstr.ml b/interp/topconstr.ml index cea506059..b043f3d42 100644 --- a/interp/topconstr.ml +++ b/interp/topconstr.ml @@ -101,7 +101,7 @@ let rec fold_local_binders g f n acc b = function f n acc b let fold_constr_expr_with_binders g f n acc = function - | CAppExpl (loc,(_,_),l) -> List.fold_left (f n) acc l + | CAppExpl (loc,(_,_,_),l) -> List.fold_left (f n) acc l | CApp (loc,(_,t),l) -> List.fold_left (f n) (f n acc t) (List.map fst l) | CProdN (_,l,b) | CLambdaN (_,l,b) -> fold_constr_expr_binders g f n acc b l | CLetIn (_,na,a,b) -> fold_constr_expr_binders g f n acc b [[na],default_binder_kind,a] @@ -141,7 +141,7 @@ let fold_constr_expr_with_binders g f n acc = function let free_vars_of_constr_expr c = let rec aux bdvars l = function - | CRef (Ident (_,id)) -> if Id.List.mem id bdvars then l else Id.Set.add id l + | CRef (Ident (_,id),_) -> if Id.List.mem id bdvars then l else Id.Set.add id l | c -> fold_constr_expr_with_binders (fun a l -> a::l) aux bdvars l c in aux [] Id.Set.empty c @@ -250,8 +250,8 @@ let map_constr_expr_with_binders g f e = function (* Used in constrintern *) let rec replace_vars_constr_expr l = function - | CRef (Ident (loc,id)) as x -> - (try CRef (Ident (loc,Id.Map.find id l)) with Not_found -> x) + | CRef (Ident (loc,id),us) as x -> + (try CRef (Ident (loc,Id.Map.find id l),us) with Not_found -> x) | c -> map_constr_expr_with_binders Id.Map.remove replace_vars_constr_expr l c diff --git a/intf/constrexpr.mli b/intf/constrexpr.mli index 64bbd1e83..af6aea164 100644 --- a/intf/constrexpr.mli +++ b/intf/constrexpr.mli @@ -62,13 +62,13 @@ and cases_pattern_notation_substitution = cases_pattern_expr list list (** for recursive notations *) type constr_expr = - | CRef of reference + | CRef of reference * Univ.universe_instance option | CFix of Loc.t * Id.t located * fix_expr list | CCoFix of Loc.t * Id.t located * cofix_expr list | CProdN of Loc.t * binder_expr list * constr_expr | CLambdaN of Loc.t * binder_expr list * constr_expr | CLetIn of Loc.t * Name.t located * constr_expr * constr_expr - | CAppExpl of Loc.t * (proj_flag * reference) * constr_expr list + | CAppExpl of Loc.t * (proj_flag * reference * Univ.universe_instance option) * constr_expr list | CApp of Loc.t * (proj_flag * constr_expr) * (constr_expr * explicitation located option) list | CRecord of Loc.t * constr_expr option * (reference * constr_expr) list diff --git a/intf/decl_kinds.mli b/intf/decl_kinds.mli index 7111fd055..2ed776c2d 100644 --- a/intf/decl_kinds.mli +++ b/intf/decl_kinds.mli @@ -12,6 +12,8 @@ type locality = Discharge | Local | Global type binding_kind = Explicit | Implicit +type polymorphic = bool + type theorem_kind = | Theorem | Lemma @@ -45,9 +47,9 @@ type assumption_object_kind = Definitional | Logical | Conjectural Logical | Hypothesis | Axiom *) -type assumption_kind = locality * assumption_object_kind +type assumption_kind = locality * polymorphic * assumption_object_kind -type definition_kind = locality * definition_object_kind +type definition_kind = locality * polymorphic * definition_object_kind (** Kinds used in proofs *) @@ -55,7 +57,7 @@ type goal_object_kind = | DefinitionBody of definition_object_kind | Proof of theorem_kind -type goal_kind = locality * goal_object_kind +type goal_kind = locality * polymorphic * goal_object_kind (** Kinds used in library *) diff --git a/intf/glob_term.mli b/intf/glob_term.mli index 1d200ca79..d07766e18 100644 --- a/intf/glob_term.mli +++ b/intf/glob_term.mli @@ -28,7 +28,7 @@ type cases_pattern = (** [PatCstr(p,C,l,x)] = "|'C' 'l' as 'x'" *) type glob_constr = - | GRef of (Loc.t * global_reference) + | GRef of (Loc.t * global_reference * Univ.universe_instance option) | GVar of (Loc.t * Id.t) | GEvar of Loc.t * existential_key * glob_constr list option | GPatVar of Loc.t * (bool * patvar) (** Used for patterns only *) @@ -39,7 +39,7 @@ type glob_constr = | GCases of Loc.t * case_style * glob_constr option * tomatch_tuples * cases_clauses (** [GCases(l,style,r,tur,cc)] = "match 'tur' return 'r' with 'cc'" (in [MatchStyle]) *) - + | GProj of Loc.t * projection * glob_constr | GLetTuple of Loc.t * Name.t list * (Name.t * glob_constr option) * glob_constr * glob_constr | GIf of Loc.t * glob_constr * (Name.t * glob_constr option) * glob_constr * glob_constr diff --git a/intf/notation_term.mli b/intf/notation_term.mli index daf605ab2..8bb43e96a 100644 --- a/intf/notation_term.mli +++ b/intf/notation_term.mli @@ -25,6 +25,7 @@ type notation_constr = | NVar of Id.t | NApp of notation_constr * notation_constr list | NHole of Evar_kinds.t * Genarg.glob_generic_argument option + | NProj of projection * notation_constr | NList of Id.t * Id.t * notation_constr * notation_constr * bool (** Part only in [glob_constr] *) | NLambda of Name.t * notation_constr * notation_constr diff --git a/intf/pattern.mli b/intf/pattern.mli index d0ccb2d9b..4fa5f418d 100644 --- a/intf/pattern.mli +++ b/intf/pattern.mli @@ -65,6 +65,7 @@ type constr_pattern = | PRel of int | PApp of constr_pattern * constr_pattern array | PSoApp of patvar * constr_pattern list + | PProj of projection * constr_pattern | PLambda of Name.t * constr_pattern * constr_pattern | PProd of Name.t * constr_pattern * constr_pattern | PLetIn of Name.t * constr_pattern * constr_pattern diff --git a/intf/vernacexpr.mli b/intf/vernacexpr.mli index 850f06f87..857f75ed6 100644 --- a/intf/vernacexpr.mli +++ b/intf/vernacexpr.mli @@ -289,7 +289,7 @@ type vernac_expr = (* Gallina *) | VernacDefinition of (locality option * definition_object_kind) * lident * definition_expr - | VernacStartTheoremProof of theorem_kind * + | VernacStartTheoremProof of theorem_kind * (lident option * (local_binder list * constr_expr * (lident option * recursion_order_expr) option)) list * bool | VernacEndProof of proof_end @@ -428,6 +428,7 @@ type vernac_expr = (* Flags *) | VernacProgram of vernac_expr + | VernacPolymorphic of bool * vernac_expr | VernacLocal of bool * vernac_expr and located_vernac_expr = Loc.t * vernac_expr diff --git a/kernel/cbytegen.ml b/kernel/cbytegen.ml index d0da84623..894f88710 100644 --- a/kernel/cbytegen.ml +++ b/kernel/cbytegen.ml @@ -353,7 +353,7 @@ let rec str_const c = | App(f,args) -> begin match kind_of_term f with - | Construct((kn,j),i) -> + | Construct(((kn,j),i),u) -> begin let oib = lookup_mind kn !global_env in let oip = oib.mind_packets.(j) in @@ -422,8 +422,8 @@ let rec str_const c = end | _ -> Bconstr c end - | Ind ind -> Bstrconst (Const_ind ind) - | Construct ((kn,j),i) -> + | Ind (ind,u) -> Bstrconst (Const_ind ind) + | Construct (((kn,j),i),u) -> begin (* spiwack: tries first to apply the run-time compilation behavior of the constructor, as in 2/ above *) @@ -487,11 +487,11 @@ let rec compile_fv reloc l sz cont = (* Compiling constants *) let rec get_allias env kn = - let tps = (lookup_constant kn env).const_body_code in - match Cemitcodes.force tps with - | BCallias kn' -> get_allias env kn' - | _ -> kn - + let cb = lookup_constant kn env in + let tps = cb.const_body_code in + (match Cemitcodes.force tps with + | BCallias kn' -> get_allias env kn' + | _ -> kn) (* Compiling expressions *) @@ -499,12 +499,19 @@ let rec compile_constr reloc c sz cont = match kind_of_term c with | Meta _ -> invalid_arg "Cbytegen.compile_constr : Meta" | Evar _ -> invalid_arg "Cbytegen.compile_constr : Evar" + | Proj (p,c) -> + (* compile_const reloc p [|c|] sz cont *) + let cb = lookup_constant p !global_env in + (* TODO: better representation of projections *) + let pb = Option.get cb.const_proj in + let args = Array.make pb.proj_npars mkProp in + compile_const reloc p Univ.Instance.empty (Array.append args [|c|]) sz cont | Cast(c,_,_) -> compile_constr reloc c sz cont | Rel i -> pos_rel i reloc sz :: cont | Var id -> pos_named id reloc :: cont - | Const kn -> compile_const reloc kn [||] sz cont + | Const (kn,u) -> compile_const reloc kn u [||] sz cont | Sort _ | Ind _ | Construct _ -> compile_str_cst reloc (str_const c) sz cont @@ -531,7 +538,7 @@ let rec compile_constr reloc c sz cont = begin match kind_of_term f with | Construct _ -> compile_str_cst reloc (str_const c) sz cont - | Const kn -> compile_const reloc kn args sz cont + | Const (kn,u) -> compile_const reloc kn u args sz cont | _ -> comp_app compile_constr compile_constr reloc f args sz cont end | Fix ((rec_args,init),(_,type_bodies,rec_bodies)) -> @@ -682,14 +689,14 @@ and compile_str_cst reloc sc sz cont = (* spiwack : compilation of constants with their arguments. Makes a special treatment with 31-bit integer addition *) and compile_const = - fun reloc-> fun kn -> fun args -> fun sz -> fun cont -> + fun reloc-> fun kn u -> fun args -> fun sz -> fun cont -> let nargs = Array.length args in (* spiwack: checks if there is a specific way to compile the constant if there is not, Not_found is raised, and the function falls back on its normal behavior *) try Retroknowledge.get_vm_compiling_info (!global_env).retroknowledge - (mkConst kn) reloc args sz cont + (mkConstU (kn,u)) reloc args sz cont with Not_found -> if Int.equal nargs 0 then Kgetglobal (get_allias !global_env kn) :: cont @@ -723,7 +730,7 @@ let compile_constant_body env = function match kind_of_term body with | Const kn' -> (* we use the canonical name of the constant*) - let con= constant_of_kn (canonical_con kn') in + let con= constant_of_kn (canonical_con (Univ.out_punivs kn')) in BCallias (get_allias env con) | _ -> let res = compile env body in @@ -751,7 +758,7 @@ let compile_structured_int31 fc args = Const_b0 (Array.fold_left (fun temp_i -> fun t -> match kind_of_term t with - | Construct (_,d) -> 2*temp_i+d-1 + | Construct ((_,d),_) -> 2*temp_i+d-1 | _ -> raise NotClosed) 0 args ) diff --git a/kernel/cemitcodes.ml b/kernel/cemitcodes.ml index 2b9ca425f..2de8ef2bf 100644 --- a/kernel/cemitcodes.ml +++ b/kernel/cemitcodes.ml @@ -320,16 +320,16 @@ let rec subst_strcst s sc = match sc with | Const_sorts _ | Const_b0 _ -> sc | Const_bn(tag,args) -> Const_bn(tag,Array.map (subst_strcst s) args) - | Const_ind(ind) -> let kn,i = ind in Const_ind((subst_ind s kn, i)) + | Const_ind(ind) -> let kn,i = ind in Const_ind((subst_mind s kn, i)) let subst_patch s (ri,pos) = match ri with | Reloc_annot a -> let (kn,i) = a.ci.ci_ind in - let ci = {a.ci with ci_ind = (subst_ind s kn,i)} in + let ci = {a.ci with ci_ind = (subst_mind s kn,i)} in (Reloc_annot {a with ci = ci},pos) | Reloc_const sc -> (Reloc_const (subst_strcst s sc), pos) - | Reloc_getglobal kn -> (Reloc_getglobal (fst (subst_con s kn)), pos) + | Reloc_getglobal kn -> (Reloc_getglobal (fst (subst_con_kn s kn)), pos) let subst_to_patch s (code,pl,fv) = code,List.rev_map (subst_patch s) pl,fv @@ -341,7 +341,7 @@ type body_code = let subst_body_code s = function | BCdefined tp -> BCdefined (subst_to_patch s tp) - | BCallias kn -> BCallias (fst (subst_con s kn)) + | BCallias kn -> BCallias (fst (subst_con_kn s kn)) | BCconstant -> BCconstant type to_patch_substituted = body_code substituted diff --git a/kernel/closure.ml b/kernel/closure.ml index 7b94ecfb8..fd3ab525e 100644 --- a/kernel/closure.ml +++ b/kernel/closure.ml @@ -206,32 +206,39 @@ let unfold_red kn = * instantiations (cbv or lazy) are. *) -type table_key = id_key +type table_key = constant puniverses tableKey +let eq_pconstant_key (c,u) (c',u') = + eq_constant_key c c' && Univ.Instance.eq u u' + module IdKeyHash = struct - type t = id_key - let equal = Names.eq_id_key open Hashset.Combine + type t = table_key + let equal = Names.eq_table_key eq_pconstant_key let hash = function - | ConstKey c -> combinesmall 1 (Constant.UserOrd.hash c) + | ConstKey (c, _) -> combinesmall 1 (Constant.UserOrd.hash c) | VarKey id -> combinesmall 2 (Id.hash id) | RelKey i -> combinesmall 3 (Int.hash i) end module KeyTable = Hashtbl.Make(IdKeyHash) -let eq_table_key = Names.eq_id_key +let eq_table_key = IdKeyHash.equal -type 'a infos = { - i_flags : reds; +type 'a infos_cache = { i_repr : 'a infos -> constr -> 'a; i_env : env; i_sigma : existential -> constr option; i_rels : constr option array; i_tab : 'a KeyTable.t } +and 'a infos = { + i_flags : reds; + i_cache : 'a infos_cache } + let info_flags info = info.i_flags +let info_env info = info.i_cache.i_env let rec assoc_defined id = function | [] -> raise Not_found @@ -239,34 +246,34 @@ let rec assoc_defined id = function | (id', Some c, _) :: ctxt -> if Id.equal id id' then c else assoc_defined id ctxt -let ref_value_cache info ref = +let ref_value_cache ({i_cache = cache} as infos) ref = try - Some (KeyTable.find info.i_tab ref) + Some (KeyTable.find cache.i_tab ref) with Not_found -> try let body = match ref with | RelKey n -> - let len = Array.length info.i_rels in + let len = Array.length cache.i_rels in let i = n - 1 in let () = if i < 0 || len <= i then raise Not_found in - begin match Array.unsafe_get info.i_rels i with + begin match Array.unsafe_get cache.i_rels i with | None -> raise Not_found | Some t -> lift n t end - | VarKey id -> assoc_defined id (named_context info.i_env) - | ConstKey cst -> constant_value info.i_env cst + | VarKey id -> assoc_defined id (named_context cache.i_env) + | ConstKey cst -> constant_value_in cache.i_env cst in - let v = info.i_repr info body in - KeyTable.add info.i_tab ref v; + let v = cache.i_repr infos body in + KeyTable.add cache.i_tab ref v; Some v with | Not_found (* List.assoc *) | NotEvaluableConst _ (* Const *) -> None -let evar_value info ev = - info.i_sigma ev +let evar_value cache ev = + cache.i_sigma ev let defined_rels flags env = (* if red_local_const (snd flags) then*) @@ -282,12 +289,13 @@ let defined_rels flags env = (* else (0,[])*) let create mk_cl flgs env evars = - { i_flags = flgs; - i_repr = mk_cl; - i_env = env; - i_sigma = evars; - i_rels = defined_rels flgs env; - i_tab = KeyTable.create 17 } + let cache = + { i_repr = mk_cl; + i_env = env; + i_sigma = evars; + i_rels = defined_rels flgs env; + i_tab = KeyTable.create 17 } + in { i_flags = flgs; i_cache = cache } (**********************************************************************) @@ -327,9 +335,10 @@ and fterm = | FAtom of constr (* Metas and Sorts *) | FCast of fconstr * cast_kind * fconstr | FFlex of table_key - | FInd of inductive - | FConstruct of constructor + | FInd of pinductive + | FConstruct of pconstructor | FApp of fconstr * fconstr array + | FProj of constant * fconstr | FFix of fixpoint * fconstr subs | FCoFix of cofixpoint * fconstr subs | FCases of case_info * fconstr * fconstr * fconstr array @@ -362,6 +371,7 @@ let update v1 no t = type stack_member = | Zapp of fconstr array | Zcase of case_info * fconstr * fconstr array + | Zproj of int * int * constant | Zfix of fconstr * stack | Zshift of int | Zupdate of fconstr @@ -494,6 +504,9 @@ let rec compact_constr (lg, subs as s) c k = let (s, f') = compact_constr s f k in let (s, v') = compact_vect s v k in if f==f' && v==v' then s, c else s, mkApp(f',v') + | Proj (p,t) -> + let (s, t') = compact_constr s t k in + if t'==t then s, c else s, mkProj (p,t') | Lambda(n,a,b) -> let (s, a') = compact_constr s a k in let (s, b') = compact_constr s b (k+1) in @@ -559,7 +572,7 @@ let mk_clos e t = | Meta _ | Sort _ -> { norm = Norm; term = FAtom t } | Ind kn -> { norm = Norm; term = FInd kn } | Construct kn -> { norm = Cstr; term = FConstruct kn } - | (CoFix _|Lambda _|Fix _|Prod _|Evar _|App _|Case _|Cast _|LetIn _) -> + | (CoFix _|Lambda _|Fix _|Prod _|Evar _|App _|Case _|Cast _|LetIn _|Proj _) -> {norm = Red; term = FCLOS(t,e)} let mk_clos_vect env v = CArray.Fun1.map mk_clos env v @@ -578,6 +591,9 @@ let mk_clos_deep clos_fun env t = | App (f,v) -> { norm = Red; term = FApp (clos_fun env f, CArray.Fun1.map clos_fun env v) } + | Proj (p,c) -> + { norm = Red; + term = FProj (p, clos_fun env c) } | Case (ci,p,c,v) -> { norm = Red; term = FCases (ci, clos_fun env p, clos_fun env c, @@ -609,9 +625,9 @@ let rec to_constr constr_fun lfts v = | FAtom c -> exliftn lfts c | FCast (a,k,b) -> mkCast (constr_fun lfts a, k, constr_fun lfts b) - | FFlex (ConstKey op) -> mkConst op - | FInd op -> mkInd op - | FConstruct op -> mkConstruct op + | FFlex (ConstKey op) -> mkConstU op + | FInd op -> mkIndU op + | FConstruct op -> mkConstructU op | FCases (ci,p,c,ve) -> mkCase (ci, constr_fun lfts p, constr_fun lfts c, @@ -633,6 +649,9 @@ let rec to_constr constr_fun lfts v = | FApp (f,ve) -> mkApp (constr_fun lfts f, CArray.Fun1.map constr_fun lfts ve) + | FProj (p,c) -> + mkProj (p,constr_fun lfts c) + | FLambda _ -> let (na,ty,bd) = destFLambda mk_clos2 v in mkLambda (na, constr_fun lfts ty, @@ -688,6 +707,8 @@ let rec zip m stk rem = match stk with | Zcase(ci,p,br)::s -> let t = FCases(ci, p, m, br) in zip {norm=neutr m.norm; term=t} s rem +| Zproj (i,j,cst) :: s -> + zip {norm=neutr m.norm; term=FProj (cst,m)} s rem | Zfix(fx,par)::s -> zip fx par ((Zapp [|m|] :: s) :: rem) | Zshift(n)::s -> @@ -774,7 +795,7 @@ let rec get_args n tys f e stk = (* Eta expansion: add a reference to implicit surrounding lambda at end of stack *) let rec eta_expand_stack = function - | (Zapp _ | Zfix _ | Zcase _ | Zshift _ | Zupdate _ as e) :: s -> + | (Zapp _ | Zfix _ | Zcase _ | Zshift _ | Zupdate _ | Zproj _ as e) :: s -> e :: eta_expand_stack s | [] -> [Zshift 1; Zapp [|{norm=Norm; term= FRel 1}|]] @@ -808,6 +829,64 @@ let rec drop_parameters depth n argstk = | _ -> assert false (* strip_update_shift_app only produces Zapp and Zshift items *) +let rec get_parameters depth n argstk = + match argstk with + Zapp args::s -> + let q = Array.length args in + if n > q then Array.append args (get_parameters depth (n-q) s) + else if Int.equal n q then [||] + else Array.sub args 0 n + | Zshift(k)::s -> + get_parameters (depth-k) n s + | [] -> (* we know that n < stack_args_size(argstk) (if well-typed term) *) + if Int.equal n 0 then [||] + else raise Not_found (* Trying to eta-expand a partial application..., should do + eta expansion first? *) + | _ -> assert false + (* strip_update_shift_app only produces Zapp and Zshift items *) + +let eta_expand_ind_stack env lft (ind,u) m s (lft, h) = + let mib = lookup_mind (fst ind) env in + match mib.Declarations.mind_record with + | None -> raise Not_found + | Some (exp,_) -> + let pars = mib.Declarations.mind_nparams in + let h' = fapp_stack h in + let (depth, args, _) = strip_update_shift_app m s in + let paramargs = get_parameters depth pars args in + let subs = subs_cons (Array.append paramargs [|h'|], subs_id 0) in + let fexp = mk_clos subs exp in + (lft, (fexp, [])) + +let eta_expand_ind_stacks env ind m s h = + let mib = lookup_mind (fst ind) env in + match mib.Declarations.mind_record with + | Some (exp,projs) when Array.length projs > 0 -> + let pars = mib.Declarations.mind_nparams in + let h' = fapp_stack h in + let (depth, args, _) = strip_update_shift_app m s in + let primitive = Environ.is_projection projs.(0) env in + if primitive then + let s' = drop_parameters depth pars args in + (* Construct, pars1 .. parsm :: arg1...argn :: s ~= (t, []) -> + arg1..argn :: s ~= (proj1 t...projn t) s + *) + let hstack = Array.map (fun p -> { norm = Red; + term = FProj (p, h') }) projs in + s', [Zapp hstack] + else raise Not_found (* disallow eta-exp for non-primitive records *) + | _ -> raise Not_found + +let rec project_nth_arg n argstk = + match argstk with + | Zapp args :: s -> + let q = Array.length args in + if n >= q then project_nth_arg (n - q) s + else (* n < q *) args.(n) + | _ -> assert false + (* After drop_parameters we have a purely applicative stack *) + + (* Iota reduction: expansion of a fixpoint. * Given a fixpoint and a substitution, returns the corresponding * fixpoint body, and the substitution in which it should be @@ -832,39 +911,48 @@ let contract_fix_vect fix = in (subs_cons(Array.init nfix make_body, env), thisbody) - (*********************************************************************) (* A machine that inspects the head of a term until it finds an atom or a subterm that may produce a redex (abstraction, constructor, cofix, letin, constant), or a neutral term (product, inductive) *) -let rec knh m stk = +let rec knh info m stk = match m.term with - | FLIFT(k,a) -> knh a (zshift k stk) - | FCLOS(t,e) -> knht e t (zupdate m stk) + | FLIFT(k,a) -> knh info a (zshift k stk) + | FCLOS(t,e) -> knht info e t (zupdate m stk) | FLOCKED -> assert false - | FApp(a,b) -> knh a (append_stack b (zupdate m stk)) - | FCases(ci,p,t,br) -> knh t (Zcase(ci,p,br)::zupdate m stk) + | FApp(a,b) -> knh info a (append_stack b (zupdate m stk)) + | FCases(ci,p,t,br) -> knh info t (Zcase(ci,p,br)::zupdate m stk) | FFix(((ri,n),(_,_,_)),_) -> (match get_nth_arg m ri.(n) stk with - (Some(pars,arg),stk') -> knh arg (Zfix(m,pars)::stk') + (Some(pars,arg),stk') -> knh info arg (Zfix(m,pars)::stk') | (None, stk') -> (m,stk')) - | FCast(t,_,_) -> knh t stk + | FCast(t,_,_) -> knh info t stk + | FProj (p,c) -> + if red_set info.i_flags (fCONST p) then + (match try Some (lookup_projection p (info_env info)) with Not_found -> None with + | None -> (m, stk) + | Some pb -> + knh info c (Zproj (pb.Declarations.proj_npars, pb.Declarations.proj_arg, p) + :: zupdate m stk)) + else (m,stk) + (* cases where knh stops *) | (FFlex _|FLetIn _|FConstruct _|FEvar _| FCoFix _|FLambda _|FRel _|FAtom _|FInd _|FProd _) -> (m, stk) (* The same for pure terms *) -and knht e t stk = +and knht info e t stk = match kind_of_term t with | App(a,b) -> - knht e a (append_stack (mk_clos_vect e b) stk) + knht info e a (append_stack (mk_clos_vect e b) stk) | Case(ci,p,t,br) -> - knht e t (Zcase(ci, mk_clos e p, mk_clos_vect e br)::stk) - | Fix _ -> knh (mk_clos2 e t) stk - | Cast(a,_,_) -> knht e a stk - | Rel n -> knh (clos_rel e n) stk + knht info e t (Zcase(ci, mk_clos e p, mk_clos_vect e br)::stk) + | Fix _ -> knh info (mk_clos2 e t) stk + | Cast(a,_,_) -> knht info e a stk + | Rel n -> knh info (clos_rel e n) stk + | Proj (p,c) -> knh info (mk_clos2 e t) stk | (Lambda _|Prod _|Construct _|CoFix _|Ind _| LetIn _|Const _|Var _|Evar _|Meta _|Sort _) -> (mk_clos2 e t, stk) @@ -879,8 +967,8 @@ let rec knr info m stk = (match get_args n tys f e stk with Inl e', s -> knit info e' f s | Inr lam, s -> (lam,s)) - | FFlex(ConstKey kn) when red_set info.i_flags (fCONST kn) -> - (match ref_value_cache info (ConstKey kn) with + | FFlex(ConstKey (kn,_ as c)) when red_set info.i_flags (fCONST kn) -> + (match ref_value_cache info (ConstKey c) with Some v -> kni info v stk | None -> (set_norm m; (m,stk))) | FFlex(VarKey id) when red_set info.i_flags (fVAR id) -> @@ -891,7 +979,7 @@ let rec knr info m stk = (match ref_value_cache info (RelKey k) with Some v -> kni info v stk | None -> (set_norm m; (m,stk))) - | FConstruct(ind,c) when red_set info.i_flags fIOTA -> + | FConstruct((ind,c),u) when red_set info.i_flags fIOTA -> (match strip_update_shift_app m stk with (depth, args, Zcase(ci,_,br)::s) -> assert (ci.ci_npar>=0); @@ -902,6 +990,10 @@ let rec knr info m stk = let stk' = par @ append_stack [|rarg|] s in let (fxe,fxbd) = contract_fix_vect fx.term in knit info fxe fxbd stk' + | (depth, args, Zproj (n, m, cst)::s) -> + let rargs = drop_parameters depth n args in + let rarg = project_nth_arg m rargs in + kni info rarg s | (_,args,s) -> (m,args@s)) | FCoFix _ when red_set info.i_flags fIOTA -> (match strip_update_shift_app m stk with @@ -912,17 +1004,17 @@ let rec knr info m stk = | FLetIn (_,v,_,bd,e) when red_set info.i_flags fZETA -> knit info (subs_cons([|v|],e)) bd stk | FEvar(ev,env) -> - (match evar_value info ev with + (match evar_value info.i_cache ev with Some c -> knit info env c stk | None -> (m,stk)) | _ -> (m,stk) (* Computes the weak head normal form of a term *) and kni info m stk = - let (hm,s) = knh m stk in + let (hm,s) = knh info m stk in knr info hm s and knit info e t stk = - let (ht,s) = knht e t stk in + let (ht,s) = knht info e t stk in knr info ht s let kh info v stk = fapp_stack(kni info v stk) @@ -937,6 +1029,9 @@ let rec zip_term zfun m stk = | Zcase(ci,p,br)::s -> let t = mkCase(ci, zfun p, m, Array.map zfun br) in zip_term zfun t s + | Zproj(_,_,p)::s -> + let t = mkProj (p, m) in + zip_term zfun t s | Zfix(fx,par)::s -> let h = mkApp(zip_term zfun (zfun fx) par,[|m|]) in zip_term zfun h s @@ -985,6 +1080,8 @@ and norm_head info m = mkFix(n,(na, CArray.Fun1.map kl info ftys, CArray.Fun1.map kl info fbds)) | FEvar((i,args),env) -> mkEvar(i, Array.map (fun a -> kl info (mk_clos env a)) args) + | FProj (p,c) -> + mkProj (p, kl info c) | t -> term_of_fconstr m (* Initialization and then normalization *) @@ -1009,6 +1106,20 @@ type clos_infos = fconstr infos let create_clos_infos ?(evars=fun _ -> None) flgs env = create (fun _ -> inject) flgs env evars -let oracle_of_infos { i_env } = Environ.oracle i_env - -let unfold_reference = ref_value_cache +let oracle_of_infos infos = Environ.oracle infos.i_cache.i_env + +let infos_with_reds infos reds = + { infos with i_flags = reds } + +let unfold_reference info key = + match key with + | ConstKey (kn,_) -> + if red_set info.i_flags (fCONST kn) then + ref_value_cache info key + else None + | VarKey i -> + if red_set info.i_flags (fVAR i) then + ref_value_cache info key + else None + | _ -> ref_value_cache info key + diff --git a/kernel/closure.mli b/kernel/closure.mli index 19baedf27..ee35e7d49 100644 --- a/kernel/closure.mli +++ b/kernel/closure.mli @@ -80,14 +80,20 @@ val unfold_side_red : reds val unfold_red : evaluable_global_reference -> reds (***********************************************************************) -type table_key = id_key +type table_key = constant puniverses tableKey + +type 'a infos_cache +type 'a infos = { + i_flags : reds; + i_cache : 'a infos_cache } -type 'a infos val ref_value_cache: 'a infos -> table_key -> 'a option -val info_flags: 'a infos -> reds val create: ('a infos -> constr -> 'a) -> reds -> env -> (existential -> constr option) -> 'a infos -val evar_value : 'a infos -> existential -> constr option +val evar_value : 'a infos_cache -> existential -> constr option + +val info_env : 'a infos -> env +val info_flags: 'a infos -> reds (*********************************************************************** s Lazy reduction. *) @@ -104,9 +110,10 @@ type fterm = | FAtom of constr (** Metas and Sorts *) | FCast of fconstr * cast_kind * fconstr | FFlex of table_key - | FInd of inductive - | FConstruct of constructor + | FInd of inductive puniverses + | FConstruct of constructor puniverses | FApp of fconstr * fconstr array + | FProj of constant * fconstr | FFix of fixpoint * fconstr subs | FCoFix of cofixpoint * fconstr subs | FCases of case_info * fconstr * fconstr * fconstr array @@ -126,6 +133,7 @@ type fterm = type stack_member = | Zapp of fconstr array | Zcase of case_info * fconstr * fconstr array + | Zproj of int * int * constant | Zfix of fconstr * stack | Zshift of int | Zupdate of fconstr @@ -159,11 +167,13 @@ val destFLambda : (fconstr subs -> constr -> fconstr) -> fconstr -> Name.t * fconstr * fconstr (** Global and local constant cache *) -type clos_infos +type clos_infos = fconstr infos val create_clos_infos : ?evars:(existential->constr option) -> reds -> env -> clos_infos val oracle_of_infos : clos_infos -> Conv_oracle.oracle +val infos_with_reds : clos_infos -> reds -> clos_infos + (** Reduction function *) (** [norm_val] is for strong normalization *) @@ -177,6 +187,12 @@ val whd_val : clos_infos -> fconstr -> constr val whd_stack : clos_infos -> fconstr -> stack -> fconstr * stack +val eta_expand_ind_stack : env -> lift -> pinductive -> fconstr -> stack -> + (lift * (fconstr * stack)) -> lift * (fconstr * stack) + +val eta_expand_ind_stacks : env -> inductive -> fconstr -> stack -> + (fconstr * stack) -> stack * stack + (** Conversion auxiliary functions to do step by step normalisation *) (** [unfold_reference] unfolds references in a [fconstr] *) diff --git a/kernel/constr.ml b/kernel/constr.ml index e9e21d30d..89c138a08 100644 --- a/kernel/constr.ml +++ b/kernel/constr.ml @@ -25,7 +25,7 @@ open Util open Names - +open Univ type existential_key = Evar.t type metavariable = int @@ -61,6 +61,10 @@ type ('constr, 'types) pfixpoint = (int array * int) * ('constr, 'types) prec_declaration type ('constr, 'types) pcofixpoint = int * ('constr, 'types) prec_declaration +type 'a puniverses = 'a Univ.puniverses +type pconstant = constant puniverses +type pinductive = inductive puniverses +type pconstructor = constructor puniverses (* [Var] is used for named variables and [Rel] for variables as de Bruijn indices. *) @@ -75,13 +79,13 @@ type ('constr, 'types) kind_of_term = | Lambda of Name.t * 'types * 'constr | LetIn of Name.t * 'constr * 'types * 'constr | App of 'constr * 'constr array - | Const of constant - | Ind of inductive - | Construct of constructor + | Const of pconstant + | Ind of pinductive + | Construct of pconstructor | Case of case_info * 'constr * 'constr * 'constr array | Fix of ('constr, 'types) pfixpoint | CoFix of ('constr, 'types) pcofixpoint - + | Proj of constant * 'constr (* constr is the fixpoint of the previous type. Requires option -rectypes of the Caml compiler to be set *) type t = (t,t) kind_of_term @@ -139,19 +143,29 @@ let mkApp (f, a) = | App (g, cl) -> App (g, Array.append cl a) | _ -> App (f, a) +let out_punivs (a, _) = a +let map_puniverses f (x,u) = (f x, u) +let in_punivs a = (a, Univ.Instance.empty) + (* Constructs a constant *) -let mkConst c = Const c +let mkConst c = Const (in_punivs c) +let mkConstU c = Const c + +(* Constructs an applied projection *) +let mkProj (p,c) = Proj (p,c) (* Constructs an existential variable *) let mkEvar e = Evar e (* Constructs the ith (co)inductive type of the block named kn *) -let mkInd m = Ind m +let mkInd m = Ind (in_punivs m) +let mkIndU m = Ind m (* Constructs the jth constructor of the ith (co)inductive type of the - block named kn. The array of terms correspond to the variables - introduced in the section *) -let mkConstruct c = Construct c + block named kn. *) +let mkConstruct c = Construct (in_punivs c) +let mkConstructU c = Construct c +let mkConstructUi ((ind,u),i) = Construct ((ind,i),u) (* Constructs the term <p>Case c of c1 | c2 .. | cn end *) let mkCase (ci, p, c, ac) = Case (ci, p, c, ac) @@ -225,6 +239,7 @@ let fold f acc c = match kind c with | Lambda (_,t,c) -> f (f acc t) c | LetIn (_,b,t,c) -> f (f (f acc b) t) c | App (c,l) -> Array.fold_left f (f acc c) l + | Proj (p,c) -> f acc c | Evar (_,l) -> Array.fold_left f acc l | Case (_,p,c,bl) -> Array.fold_left f (f (f acc p) c) bl | Fix (_,(lna,tl,bl)) -> @@ -244,6 +259,7 @@ let iter f c = match kind c with | Lambda (_,t,c) -> f t; f c | LetIn (_,b,t,c) -> f b; f t; f c | App (c,l) -> f c; Array.iter f l + | Proj (p,c) -> f c | Evar (_,l) -> Array.iter f l | Case (_,p,c,bl) -> f p; f c; Array.iter f bl | Fix (_,(_,tl,bl)) -> Array.iter f tl; Array.iter f bl @@ -265,6 +281,7 @@ let iter_with_binders g f n c = match kind c with | App (c,l) -> f n c; CArray.Fun1.iter f n l | Evar (_,l) -> CArray.Fun1.iter f n l | Case (_,p,c,bl) -> f n p; f n c; CArray.Fun1.iter f n bl + | Proj (p,c) -> f n c | Fix (_,(_,tl,bl)) -> CArray.Fun1.iter f n tl; CArray.Fun1.iter f (iterate g (Array.length tl) n) bl @@ -305,6 +322,10 @@ let map f c = match kind c with let l' = Array.smartmap f l in if b'==b && l'==l then c else mkApp (b', l') + | Proj (p,t) -> + let t' = f t in + if t' == t then c + else mkProj (p, t') | Evar (e,l) -> let l' = Array.smartmap f l in if l'==l then c @@ -413,6 +434,10 @@ let map_with_binders g f l c0 = match kind c0 with let al' = CArray.Fun1.smartmap f l al in if c' == c && al' == al then c0 else mkApp (c', al') + | Proj (p, t) -> + let t' = f l t in + if t' == t then c0 + else mkProj (p, t') | Evar (e, al) -> let al' = CArray.Fun1.smartmap f l al in if al' == al then c0 @@ -435,13 +460,13 @@ let map_with_binders g f l c0 = match kind c0 with let bl' = CArray.Fun1.smartmap f l' bl in mkCoFix (ln,(lna,tl',bl')) -(* [compare f c1 c2] compare [c1] and [c2] using [f] to compare - the immediate subterms of [c1] of [c2] if needed; Cast's, +(* [compare_head_gen u s f c1 c2] compare [c1] and [c2] using [f] to compare + the immediate subterms of [c1] of [c2] if needed, [u] to compare universe + instances and [s] to compare sorts; Cast's, application associativity, binders name and Cases annotations are not taken into account *) - -let compare_head f t1 t2 = +let compare_head_gen eq_universes eq_sorts f t1 t2 = match kind t1, kind t2 with | Rel n1, Rel n2 -> Int.equal n1 n2 | Meta m1, Meta m2 -> Int.equal m1 m2 @@ -458,9 +483,10 @@ let compare_head f t1 t2 = Int.equal (Array.length l1) (Array.length l2) && f c1 c2 && Array.equal f l1 l2 | Evar (e1,l1), Evar (e2,l2) -> Evar.equal e1 e2 && Array.equal f l1 l2 - | Const c1, Const c2 -> eq_constant c1 c2 - | Ind c1, Ind c2 -> eq_ind c1 c2 - | Construct c1, Construct c2 -> eq_constructor c1 c2 + | Proj (p1,c1), Proj (p2,c2) -> eq_constant p1 p2 && f c1 c2 + | Const (c1,u1), Const (c2,u2) -> eq_constant c1 c2 && eq_universes true u1 u2 + | Ind (c1,u1), Ind (c2,u2) -> eq_ind c1 c2 && eq_universes false u1 u2 + | Construct (c1,u1), Construct (c2,u2) -> eq_constructor c1 c2 && eq_universes false u1 u2 | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) -> f p1 p2 && f c1 c2 && Array.equal f bl1 bl2 | Fix ((ln1, i1),(_,tl1,bl1)), Fix ((ln2, i2),(_,tl2,bl2)) -> @@ -470,6 +496,44 @@ let compare_head f t1 t2 = Int.equal ln1 ln2 && Array.equal f tl1 tl2 && Array.equal f bl1 bl2 | _ -> false +let compare_head = compare_head_gen (fun _ -> Univ.Instance.eq) Sorts.equal + +(* [compare_head_gen_leq u s sl eq leq c1 c2] compare [c1] and [c2] using [eq] to compare + the immediate subterms of [c1] of [c2] for conversion if needed, [leq] for cumulativity, + [u] to compare universe instances and [s] to compare sorts; Cast's, + application associativity, binders name and Cases annotations are + not taken into account *) + +let compare_head_gen_leq eq_universes eq_sorts leq_sorts eq leq t1 t2 = + match kind t1, kind t2 with + | Rel n1, Rel n2 -> Int.equal n1 n2 + | Meta m1, Meta m2 -> Int.equal m1 m2 + | Var id1, Var id2 -> Int.equal (id_ord id1 id2) 0 + | Sort s1, Sort s2 -> leq_sorts s1 s2 + | Cast (c1,_,_), _ -> leq c1 t2 + | _, Cast (c2,_,_) -> leq t1 c2 + | Prod (_,t1,c1), Prod (_,t2,c2) -> eq t1 t2 && leq c1 c2 + | Lambda (_,t1,c1), Lambda (_,t2,c2) -> eq t1 t2 && eq c1 c2 + | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) -> eq b1 b2 && eq t1 t2 && leq c1 c2 + | App (Cast(c1, _, _),l1), _ -> leq (mkApp (c1,l1)) t2 + | _, App (Cast (c2, _, _),l2) -> leq t1 (mkApp (c2,l2)) + | App (c1,l1), App (c2,l2) -> + Int.equal (Array.length l1) (Array.length l2) && + eq c1 c2 && Array.equal eq l1 l2 + | Proj (p1,c1), Proj (p2,c2) -> eq_constant p1 p2 && eq c1 c2 + | Evar (e1,l1), Evar (e2,l2) -> Evar.equal e1 e2 && Array.equal eq l1 l2 + | Const (c1,u1), Const (c2,u2) -> eq_constant c1 c2 && eq_universes true u1 u2 + | Ind (c1,u1), Ind (c2,u2) -> eq_ind c1 c2 && eq_universes false u1 u2 + | Construct (c1,u1), Construct (c2,u2) -> eq_constructor c1 c2 && eq_universes false u1 u2 + | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) -> + eq p1 p2 && eq c1 c2 && Array.equal eq bl1 bl2 + | Fix ((ln1, i1),(_,tl1,bl1)), Fix ((ln2, i2),(_,tl2,bl2)) -> + Int.equal i1 i2 && Array.equal Int.equal ln1 ln2 + && Array.equal eq tl1 tl2 && Array.equal eq bl1 bl2 + | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) -> + Int.equal ln1 ln2 && Array.equal eq tl1 tl2 && Array.equal eq bl1 bl2 + | _ -> false + (*******************************) (* alpha conversion functions *) (*******************************) @@ -477,10 +541,81 @@ let compare_head f t1 t2 = (* alpha conversion : ignore print names and casts *) let rec eq_constr m n = - (m == n) || compare_head eq_constr m n + (m == n) || compare_head_gen (fun _ -> Univ.Instance.eq) Sorts.equal eq_constr m n + +(** Strict equality of universe instances. *) +let compare_constr = compare_head_gen (fun _ -> Univ.Instance.eq) Sorts.equal let equal m n = eq_constr m n (* to avoid tracing a recursive fun *) +let eq_constr_univs univs m n = + if m == n then true + else + let eq_universes _ = Univ.Instance.check_eq univs in + let eq_sorts s1 s2 = Univ.check_eq univs (Sorts.univ_of_sort s1) (Sorts.univ_of_sort s2) in + let rec eq_constr' m n = + m == n || compare_head_gen eq_universes eq_sorts eq_constr' m n + in compare_head_gen eq_universes eq_sorts eq_constr' m n + +let leq_constr_univs univs m n = + if m == n then true + else + let eq_universes _ = Univ.Instance.check_eq univs in + let eq_sorts s1 s2 = Univ.check_eq univs (Sorts.univ_of_sort s1) (Sorts.univ_of_sort s2) in + let leq_sorts s1 s2 = Univ.check_leq univs (Sorts.univ_of_sort s1) (Sorts.univ_of_sort s2) in + let rec eq_constr' m n = + m == n || compare_head_gen eq_universes eq_sorts eq_constr' m n + in + let rec compare_leq m n = + compare_head_gen_leq eq_universes eq_sorts leq_sorts eq_constr' leq_constr' m n + and leq_constr' m n = m == n || compare_leq m n in + compare_leq m n + +let eq_constr_universes m n = + if m == n then true, UniverseConstraints.empty + else + let cstrs = ref UniverseConstraints.empty in + let eq_universes strict l l' = + cstrs := Univ.enforce_eq_instances_univs strict l l' !cstrs; true in + let eq_sorts s1 s2 = + cstrs := Univ.UniverseConstraints.add + (Sorts.univ_of_sort s1, Univ.UEq, Sorts.univ_of_sort s2) !cstrs; + true + in + let rec eq_constr' m n = + m == n || compare_head_gen eq_universes eq_sorts eq_constr' m n + in + let res = compare_head_gen eq_universes eq_sorts eq_constr' m n in + res, !cstrs + +let leq_constr_universes m n = + if m == n then true, UniverseConstraints.empty + else + let cstrs = ref UniverseConstraints.empty in + let eq_universes strict l l' = + cstrs := Univ.enforce_eq_instances_univs strict l l' !cstrs; true in + let eq_sorts s1 s2 = + cstrs := Univ.UniverseConstraints.add + (Sorts.univ_of_sort s1,Univ.UEq,Sorts.univ_of_sort s2) !cstrs; true + in + let leq_sorts s1 s2 = + cstrs := Univ.UniverseConstraints.add + (Sorts.univ_of_sort s1,Univ.ULe,Sorts.univ_of_sort s2) !cstrs; true + in + let rec eq_constr' m n = + m == n || compare_head_gen eq_universes eq_sorts eq_constr' m n + in + let rec compare_leq m n = + compare_head_gen_leq eq_universes eq_sorts leq_sorts eq_constr' leq_constr' m n + and leq_constr' m n = m == n || compare_leq m n in + let res = compare_leq m n in + res, !cstrs + +let always_true _ _ = true + +let rec eq_constr_nounivs m n = + (m == n) || compare_head_gen (fun _ -> always_true) always_true eq_constr_nounivs m n + (** We only use this function over blocks! *) let tag t = Obj.tag (Obj.repr t) @@ -509,11 +644,12 @@ let constr_ord_int f t1 t2 = | App (Cast(c1,_,_),l1), _ -> f (mkApp (c1,l1)) t2 | _, App (Cast(c2, _,_),l2) -> f t1 (mkApp (c2,l2)) | App (c1,l1), App (c2,l2) -> (f =? (Array.compare f)) c1 c2 l1 l2 + | Proj (p1,c1), Proj (p2,c2) -> (con_ord =? f) p1 p2 c1 c2 | Evar (e1,l1), Evar (e2,l2) -> (Evar.compare =? (Array.compare f)) e1 e2 l1 l2 - | Const c1, Const c2 -> con_ord c1 c2 - | Ind ind1, Ind ind2 -> ind_ord ind1 ind2 - | Construct ct1, Construct ct2 -> constructor_ord ct1 ct2 + | Const (c1,u1), Const (c2,u2) -> con_ord c1 c2 + | Ind (ind1, u1), Ind (ind2, u2) -> ind_ord ind1 ind2 + | Construct (ct1,u1), Construct (ct2,u2) -> constructor_ord ct1 ct2 | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) -> ((f =? f) ==? (Array.compare f)) p1 p2 c1 c2 bl1 bl2 | Fix (ln1,(_,tl1,bl1)), Fix (ln2,(_,tl2,bl2)) -> @@ -587,12 +723,14 @@ let hasheq t1 t2 = | Lambda (n1,t1,c1), Lambda (n2,t2,c2) -> n1 == n2 && t1 == t2 && c1 == c2 | LetIn (n1,b1,t1,c1), LetIn (n2,b2,t2,c2) -> n1 == n2 && b1 == b2 && t1 == t2 && c1 == c2 + | Proj (c1,t1), Proj (c2,t2) -> c1 == c2 && t1 == t2 | App (c1,l1), App (c2,l2) -> c1 == c2 && array_eqeq l1 l2 | Evar (e1,l1), Evar (e2,l2) -> Evar.equal e1 e2 && array_eqeq l1 l2 - | Const c1, Const c2 -> c1 == c2 - | Ind (sp1,i1), Ind (sp2,i2) -> sp1 == sp2 && Int.equal i1 i2 - | Construct ((sp1,i1),j1), Construct ((sp2,i2),j2) -> - sp1 == sp2 && Int.equal i1 i2 && Int.equal j1 j2 + | Const (c1,u1), Const (c2,u2) -> c1 == c2 && Univ.Instance.eqeq u1 u2 + | Ind ((sp1,i1),u1), Ind ((sp2,i2),u2) -> + sp1 == sp2 && Int.equal i1 i2 && Univ.Instance.eqeq u1 u2 + | Construct (((sp1,i1),j1),u1), Construct (((sp2,i2),j2),u2) -> + sp1 == sp2 && Int.equal i1 i2 && Int.equal j1 j2 && Univ.Instance.eqeq u1 u2 | Case (ci1,p1,c1,bl1), Case (ci2,p2,c2,bl2) -> ci1 == ci2 && p1 == p2 && c1 == c2 && array_eqeq bl1 bl2 | Fix ((ln1, i1),(lna1,tl1,bl1)), Fix ((ln2, i2),(lna2,tl2,bl2)) -> @@ -631,6 +769,8 @@ let hash_cast_kind = function | DEFAULTcast -> 2 | REVERTcast -> 3 +let hash_instance = Univ.Instance.hcons + (* [hashcons hash_consing_functions constr] computes an hash-consed representation for [constr] using [hash_consing_functions] on leaves. *) @@ -665,12 +805,16 @@ let hashcons (sh_sort,sh_ci,sh_construct,sh_ind,sh_con,sh_na,sh_id) = | Evar (e,l) -> let l, hl = hash_term_array l in (Evar (e,l), combinesmall 8 (combine (Evar.hash e) hl)) - | Const c -> - (Const (sh_con c), combinesmall 9 (Constant.hash c)) - | Ind ind -> - (Ind (sh_ind ind), combinesmall 10 (ind_hash ind)) - | Construct c -> - (Construct (sh_construct c), combinesmall 11 (constructor_hash c)) + | Proj (p,c) -> + let c, hc = sh_rec c in + let p' = sh_con p in + (Proj (p', c), combinesmall 17 (Hashtbl.hash p')) (** FIXME *) + | Const (c,u) -> + (Const (sh_con c, hash_instance u), combinesmall 9 (Constant.hash c)) + | Ind (ind, u) -> + (Ind (sh_ind ind, hash_instance u), combinesmall 10 (ind_hash ind)) + | Construct (c, u) -> + (Construct (sh_construct c, hash_instance u), combinesmall 11 (constructor_hash c)) | Case (ci,p,c,bl) -> let p, hp = sh_rec p and c, hc = sh_rec c in @@ -742,13 +886,15 @@ let rec hash t = | App (Cast(c, _, _),l) -> hash (mkApp (c,l)) | App (c,l) -> combinesmall 7 (combine (hash_term_array l) (hash c)) + | Proj (p,c) -> + combinesmall 17 (combine (Hashtbl.hash p) (hash c)) | Evar (e,l) -> combinesmall 8 (combine (Evar.hash e) (hash_term_array l)) - | Const c -> + | Const (c, _) -> combinesmall 9 (Constant.hash c) - | Ind ind -> + | Ind (ind, _) -> combinesmall 10 (ind_hash ind) - | Construct c -> + | Construct (c, _) -> combinesmall 11 (constructor_hash c) | Case (_ , p, c, bl) -> combinesmall 12 (combine3 (hash c) (hash p) (hash_term_array bl)) @@ -799,8 +945,32 @@ module Hcaseinfo = Hashcons.Make(CaseinfoHash) let case_info_hash = CaseinfoHash.hash +module Hsorts = + Hashcons.Make( + struct + open Sorts + + type t = Sorts.t + type u = universe -> universe + let hashcons huniv = function + Prop c -> Prop c + | Type u -> Type (huniv u) + let equal s1 s2 = + s1 == s2 || + match (s1,s2) with + (Prop c1, Prop c2) -> c1 == c2 + | (Type u1, Type u2) -> u1 == u2 + |_ -> false + let hash = Hashtbl.hash + end) + +let hcons_sorts = Hashcons.simple_hcons Hsorts.generate hcons_univ let hcons_caseinfo = Hashcons.simple_hcons Hcaseinfo.generate hcons_ind +let hcons_pconstruct (c,u) = (hcons_construct c, Univ.Instance.hcons u) +let hcons_pind (i,u) = (hcons_ind i, Univ.Instance.hcons u) +let hcons_pcon (c,u) = (hcons_con c, Univ.Instance.hcons u) + let hcons = hashcons (Sorts.hcons, diff --git a/kernel/constr.mli b/kernel/constr.mli index 82a2de094..be6250257 100644 --- a/kernel/constr.mli +++ b/kernel/constr.mli @@ -8,6 +8,14 @@ open Names +(** {6 Value under universe substitution } *) +type 'a puniverses = 'a Univ.puniverses + +(** {6 Simply type aliases } *) +type pconstant = constant puniverses +type pinductive = inductive puniverses +type pconstructor = constructor puniverses + (** {6 Existential variables } *) type existential_key = Evar.t @@ -88,20 +96,26 @@ val mkLetIn : Name.t * constr * types * constr -> constr {% $(f~t_1~\dots~t_n)$ %}. *) val mkApp : constr * constr array -> constr -(** Constructs a constant - The array of terms correspond to the variables introduced in the section *) +val map_puniverses : ('a -> 'b) -> 'a puniverses -> 'b puniverses + +(** Constructs a constant *) val mkConst : constant -> constr +val mkConstU : pconstant -> constr + +(** Constructs a projection application *) +val mkProj : (constant * constr) -> constr (** Inductive types *) -(** Constructs the ith (co)inductive type of the block named kn - The array of terms correspond to the variables introduced in the section *) +(** Constructs the ith (co)inductive type of the block named kn *) val mkInd : inductive -> constr +val mkIndU : pinductive -> constr (** Constructs the jth constructor of the ith (co)inductive type of the - block named kn. The array of terms correspond to the variables - introduced in the section *) + block named kn. *) val mkConstruct : constructor -> constr +val mkConstructU : pconstructor -> constr +val mkConstructUi : pinductive * int -> constr (** Constructs a destructor of inductive type. @@ -170,12 +184,13 @@ type ('constr, 'types) kind_of_term = | Lambda of Name.t * 'types * 'constr | LetIn of Name.t * 'constr * 'types * 'constr | App of 'constr * 'constr array - | Const of constant - | Ind of inductive - | Construct of constructor + | Const of constant puniverses + | Ind of inductive puniverses + | Construct of constructor puniverses | Case of case_info * 'constr * 'constr * 'constr array | Fix of ('constr, 'types) pfixpoint | CoFix of ('constr, 'types) pcofixpoint + | Proj of constant * 'constr (** User view of [constr]. For [App], it is ensured there is at least one argument and the function is not itself an applicative @@ -187,6 +202,26 @@ val kind : constr -> (constr, types) kind_of_term and application grouping *) val equal : constr -> constr -> bool +(** [eq_constr_univs a b] [true, c] if [a] equals [b] modulo alpha, casts, + application grouping and the universe equalities in [c]. *) +val eq_constr_univs : constr Univ.check_function + +(** [leq_constr_univs a b] [true, c] if [a] is convertible to [b] modulo + alpha, casts, application grouping and the universe inequalities in [c]. *) +val leq_constr_univs : constr Univ.check_function + +(** [eq_constr_universes a b] [true, c] if [a] equals [b] modulo alpha, casts, + application grouping and the universe equalities in [c]. *) +val eq_constr_universes : constr -> constr -> bool Univ.universe_constrained + +(** [leq_constr_universes a b] [true, c] if [a] is convertible to [b] modulo + alpha, casts, application grouping and the universe inequalities in [c]. *) +val leq_constr_universes : constr -> constr -> bool Univ.universe_constrained + +(** [eq_constr_univs a b] [true, c] if [a] equals [b] modulo alpha, casts, + application grouping and ignoring universe instances. *) +val eq_constr_nounivs : constr -> constr -> bool + (** Total ordering compatible with [equal] *) val compare : constr -> constr -> int diff --git a/kernel/conv_oracle.mli b/kernel/conv_oracle.mli index cd8cd2cf7..ae501ce87 100644 --- a/kernel/conv_oracle.mli +++ b/kernel/conv_oracle.mli @@ -16,7 +16,7 @@ val empty : oracle If [oracle_order kn1 kn2] is true, then unfold kn1 first. Note: the oracle does not introduce incompleteness, it only tries to postpone unfolding of "opaque" constants. *) -val oracle_order : oracle -> bool -> 'a tableKey -> 'a tableKey -> bool +val oracle_order : oracle -> bool -> constant tableKey -> constant tableKey -> bool (** Priority for the expansion of constant in the conversion test. * Higher levels means that the expansion is less prioritary. @@ -29,14 +29,14 @@ val transparent : level (** Check whether a level is transparent *) val is_transparent : level -> bool -val get_strategy : oracle -> 'a tableKey -> level +val get_strategy : oracle -> constant tableKey -> level (** Sets the level of a constant. * Level of RelKey constant cannot be set. *) -val set_strategy : oracle -> 'a tableKey -> level -> oracle +val set_strategy : oracle -> constant tableKey -> level -> oracle (** Fold over the non-transparent levels of the oracle. Order unspecified. *) -val fold_strategy : (unit tableKey -> level -> 'a -> 'a) -> oracle -> 'a -> 'a +val fold_strategy : (constant tableKey -> level -> 'a -> 'a) -> oracle -> 'a -> 'a val get_transp_state : oracle -> transparent_state diff --git a/kernel/cooking.ml b/kernel/cooking.ml index dbe188bd4..4bae6de66 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -19,6 +19,7 @@ open Names open Term open Declarations open Environ +open Univ (*s Cooking the constants. *) @@ -56,27 +57,36 @@ end module RefTable = Hashtbl.Make(RefHash) +let instantiate_my_gr gr u = + match gr with + | ConstRef c -> mkConstU (c, u) + | IndRef i -> mkIndU (i, u) + | ConstructRef c -> mkConstructU (c, u) + let share cache r (cstl,knl) = try RefTable.find cache r with Not_found -> - let f,l = + let f,(u,l) = match r with | IndRef (kn,i) -> - mkInd (pop_mind kn,i), Mindmap.find kn knl + IndRef (pop_mind kn,i), Mindmap.find kn knl | ConstructRef ((kn,i),j) -> - mkConstruct ((pop_mind kn,i),j), Mindmap.find kn knl + ConstructRef ((pop_mind kn,i),j), Mindmap.find kn knl | ConstRef cst -> - mkConst (pop_con cst), Cmap.find cst cstl in - let c = mkApp (f, Array.map mkVar l) in + ConstRef (pop_con cst), Cmap.find cst cstl in + let c = (f, (u, Array.map mkVar l)) in RefTable.add cache r c; c +let share_univs cache r u l = + let r', (u', args) = share cache r l in + mkApp (instantiate_my_gr r' (Instance.append u' u), args) + let update_case_info cache ci modlist = try let ind, n = - match kind_of_term (share cache (IndRef ci.ci_ind) modlist) with - | App (f,l) -> (destInd f, Array.length l) - | Ind ind -> ind, 0 + match share cache (IndRef ci.ci_ind) modlist with + | (IndRef f,(u,l)) -> (f, Array.length l) | _ -> assert false in { ci with ci_ind = ind; ci_npar = ci.ci_npar + n } with Not_found -> @@ -86,31 +96,43 @@ let is_empty_modlist (cm, mm) = Cmap.is_empty cm && Mindmap.is_empty mm let expmod_constr cache modlist c = - let share = share cache in + let share_univs = share_univs cache in let update_case_info = update_case_info cache in let rec substrec c = match kind_of_term c with | Case (ci,p,t,br) -> map_constr substrec (mkCase (update_case_info ci modlist,p,t,br)) - | Ind ind -> + | Ind (ind,u) -> (try - share (IndRef ind) modlist + share_univs (IndRef ind) u modlist with | Not_found -> map_constr substrec c) - | Construct cstr -> + | Construct (cstr,u) -> (try - share (ConstructRef cstr) modlist + share_univs (ConstructRef cstr) u modlist with | Not_found -> map_constr substrec c) - | Const cst -> + | Const (cst,u) -> (try - share (ConstRef cst) modlist + share_univs (ConstRef cst) u modlist with | Not_found -> map_constr substrec c) + | Proj (p, c') -> + (try + let p' = share_univs (ConstRef p) Univ.Instance.empty modlist in + match kind_of_term p' with + | Const (p',_) -> mkProj (p', substrec c') + | App (f, args) -> + (match kind_of_term f with + | Const (p', _) -> mkProj (p', substrec c') + | _ -> assert false) + | _ -> assert false + with Not_found -> map_constr substrec c) + | _ -> map_constr substrec c in @@ -127,7 +149,8 @@ type recipe = { from : constant_body; info : Opaqueproof.cooking_info } type inline = bool type result = - constant_def * constant_type * Univ.constraints * inline + constant_def * constant_type * projection_body option * + bool * constant_universes * inline * Context.section_context option let on_body ml hy f = function @@ -142,15 +165,17 @@ let constr_of_def = function | Def cs -> Mod_subst.force_constr cs | OpaqueDef lc -> Opaqueproof.force_proof lc + let cook_constr { Opaqueproof.modlist ; abstract } c = let cache = RefTable.create 13 in - let hyps = Context.map_named_context (expmod_constr cache modlist) abstract in + let hyps = Context.map_named_context (expmod_constr cache modlist) (fst abstract) in abstract_constant_body (expmod_constr cache modlist c) hyps let cook_constant env { from = cb; info = { Opaqueproof.modlist; abstract } } = let cache = RefTable.create 13 in + let abstract, abs_ctx = abstract in let hyps = Context.map_named_context (expmod_constr cache modlist) abstract in - let body = on_body modlist hyps + let body = on_body modlist (hyps, abs_ctx) (fun c -> abstract_constant_body (expmod_constr cache modlist c) hyps) cb.const_body in @@ -158,18 +183,43 @@ let cook_constant env { from = cb; info = { Opaqueproof.modlist; abstract } } = Context.fold_named_context (fun (h,_,_) hyps -> List.filter (fun (id,_,_) -> not (Id.equal id h)) hyps) hyps ~init:cb.const_hyps in - let typ = match cb.const_type with - | NonPolymorphicType t -> - let typ = - abstract_constant_type (expmod_constr cache modlist t) hyps in - NonPolymorphicType typ - | PolymorphicArity (ctx,s) -> - let t = mkArity (ctx,Type s.poly_level) in - let typ = - abstract_constant_type (expmod_constr cache modlist t) hyps in - let j = make_judge (constr_of_def body) typ in - Typeops.make_polymorphic_if_constant_for_ind env j + + (* let typ = match cb.const_type with *) + (* | NonPolymorphicType t -> *) + (* let typ = *) + (* abstract_constant_type (expmod_constr cache r.d_modlist t) hyps in *) + (* NonPolymorphicType typ *) + (* | PolymorphicArity (ctx,s) -> *) + (* let t = mkArity (ctx,Type s.poly_level) in *) + (* let typ = *) + (* abstract_constant_type (expmod_constr cache r.d_modlist t) hyps in *) + (* let j = make_judge (constr_of_def body) typ in *) + (* Typeops.make_polymorphic_if_constant_for_ind env j *) + (* in *) + let typ = + abstract_constant_type (expmod_constr cache modlist cb.const_type) hyps in - (body, typ, cb.const_constraints, cb.const_inline_code, Some const_hyps) + let projection pb = + let c' = abstract_constant_body (expmod_constr cache modlist pb.proj_body) hyps in + let ((mind, _), _), n' = + try + let c' = share_univs cache (IndRef (pb.proj_ind,0)) Univ.Instance.empty modlist in + match kind_of_term c' with + | App (f,l) -> (destInd f, Array.length l) + | Ind ind -> ind, 0 + | _ -> assert false + with Not_found -> (((pb.proj_ind,0),Univ.Instance.empty), 0) + in + let ctx, ty' = decompose_prod_n (n' + pb.proj_npars + 1) typ in + { proj_ind = mind; proj_npars = pb.proj_npars + n'; proj_arg = pb.proj_arg; + proj_type = ty'; proj_body = c' } + in + let univs = Future.from_val (UContext.union abs_ctx (Future.force cb.const_universes)) in + (body, typ, Option.map projection cb.const_proj, + cb.const_polymorphic, univs, cb.const_inline_code, + Some const_hyps) + +(* let cook_constant_key = Profile.declare_profile "cook_constant" *) +(* let cook_constant = Profile.profile2 cook_constant_key cook_constant *) let expmod_constr modlist c = expmod_constr (RefTable.create 13) modlist c diff --git a/kernel/cooking.mli b/kernel/cooking.mli index 030e88829..489360af7 100644 --- a/kernel/cooking.mli +++ b/kernel/cooking.mli @@ -17,7 +17,8 @@ type recipe = { from : constant_body; info : Opaqueproof.cooking_info } type inline = bool type result = - constant_def * constant_type * Univ.constraints * inline + constant_def * constant_type * projection_body option * + bool * constant_universes * inline * Context.section_context option val cook_constant : env -> recipe -> result diff --git a/kernel/declarations.mli b/kernel/declarations.mli index 1e94e243c..f3cb41f32 100644 --- a/kernel/declarations.mli +++ b/kernel/declarations.mli @@ -18,14 +18,7 @@ type engagement = ImpredicativeSet (** {6 Representation of constants (Definition/Axiom) } *) -type polymorphic_arity = { - poly_param_levels : Univ.universe option list; - poly_level : Univ.universe; -} - -type constant_type = - | NonPolymorphicType of types - | PolymorphicArity of rel_context * polymorphic_arity +type constant_type = types (** Inlining level of parameters at functor applications. None means no inlining *) @@ -35,11 +28,24 @@ type inline = int option (** A constant can have no body (axiom/parameter), or a transparent body, or an opaque one *) +(** Projections are a particular kind of constant: + always transparent. *) + +type projection_body = { + proj_ind : mutual_inductive; + proj_npars : int; + proj_arg : int; + proj_type : types; (* Type under params *) + proj_body : constr; (* For compatibility, the match version *) +} + type constant_def = | Undef of inline | Def of constr Mod_subst.substituted | OpaqueDef of Opaqueproof.opaque +type constant_universes = Univ.universe_context Future.computation + (* some contraints are in constant_constraints, some other may be in * the OpaueDef *) type constant_body = { @@ -47,7 +53,9 @@ type constant_body = { const_body : constant_def; const_type : constant_type; const_body_code : Cemitcodes.to_patch_substituted; - const_constraints : Univ.constraints; + const_polymorphic : bool; (** Is it polymorphic or not *) + const_universes : constant_universes; + const_proj : projection_body option; const_inline_code : bool } type side_effect = @@ -71,15 +79,11 @@ type wf_paths = recarg Rtree.t v} *) -type monomorphic_inductive_arity = { - mind_user_arity : constr; +type inductive_arity = { + mind_user_arity : types; mind_sort : sorts; } -type inductive_arity = -| Monomorphic of monomorphic_inductive_arity -| Polymorphic of polymorphic_arity - type one_inductive_body = { (** {8 Primitive datas } *) @@ -87,7 +91,7 @@ type one_inductive_body = { mind_arity_ctxt : rel_context; (** Arity context of [Ii] with parameters: [forall params, Ui] *) - mind_arity : inductive_arity; (** Arity sort and original user arity if monomorphic *) + mind_arity : inductive_arity; (** Arity sort and original user arity *) mind_consnames : Id.t array; (** Names of the constructors: [cij] *) @@ -129,7 +133,9 @@ type mutual_inductive_body = { mind_packets : one_inductive_body array; (** The component of the mutual inductive block *) - mind_record : bool; (** Whether the inductive type has been declared as a record *) + mind_record : (constr * constant array) option; + (** Whether the inductive type has been declared as a record, + In that case we get its canonical eta-expansion and list of projections. *) mind_finite : bool; (** Whether the type is inductive or coinductive *) @@ -143,7 +149,9 @@ type mutual_inductive_body = { mind_params_ctxt : rel_context; (** The context of parameters (includes let-in declaration) *) - mind_constraints : Univ.constraints; (** Universes constraints enforced by the inductive declaration *) + mind_polymorphic : bool; (** Is it polymorphic or not *) + + mind_universes : Univ.universe_context; (** Local universe variables and constraints *) } diff --git a/kernel/declareops.ml b/kernel/declareops.ml index 1b67de0ea..0e4b80495 100644 --- a/kernel/declareops.ml +++ b/kernel/declareops.ml @@ -20,8 +20,9 @@ let body_of_constant cb = match cb.const_body with | Def c -> Some (force_constr c) | OpaqueDef o -> Some (Opaqueproof.force_proof o) -let constraints_of_constant cb = Univ.union_constraints cb.const_constraints - (match cb.const_body with +let constraints_of_constant cb = Univ.Constraint.union + (Univ.UContext.constraints (Future.force cb.const_universes)) + (match cb.const_body with | Undef _ -> Univ.empty_constraint | Def c -> Univ.empty_constraint | OpaqueDef o -> Opaqueproof.force_constraints o) @@ -43,36 +44,48 @@ let subst_rel_declaration sub (id,copt,t as x) = let subst_rel_context sub = List.smartmap (subst_rel_declaration sub) -let subst_const_type sub arity = match arity with - | NonPolymorphicType s -> - let s' = subst_mps sub s in - if s==s' then arity else NonPolymorphicType s' - | PolymorphicArity (ctx,s) -> - let ctx' = subst_rel_context sub ctx in - if ctx==ctx' then arity else PolymorphicArity (ctx',s) +(* let subst_const_type sub arity = match arity with *) +(* | NonPolymorphicType s -> *) +(* let s' = subst_mps sub s in *) +(* if s==s' then arity else NonPolymorphicType s' *) +(* | PolymorphicArity (ctx,s) -> *) +(* let ctx' = subst_rel_context sub ctx in *) +(* if ctx==ctx' then arity else PolymorphicArity (ctx',s) *) + +let subst_const_type sub arity = + if is_empty_subst sub then arity + else subst_mps sub arity (** No need here to check for physical equality after substitution, at least for Def due to the delayed substitution [subst_constr_subst]. *) - let subst_const_def sub def = match def with | Undef _ -> def | Def c -> Def (subst_constr sub c) | OpaqueDef o -> OpaqueDef (Opaqueproof.subst_opaque sub o) +let subst_const_proj sub pb = + { pb with proj_ind = subst_mind sub pb.proj_ind; + proj_type = subst_mps sub pb.proj_type; + proj_body = subst_const_type sub pb.proj_body } + let subst_const_body sub cb = assert (List.is_empty cb.const_hyps); (* we're outside sections *) if is_empty_subst sub then cb else let body' = subst_const_def sub cb.const_body in let type' = subst_const_type sub cb.const_type in - if body' == cb.const_body && type' == cb.const_type then cb + let proj' = Option.smartmap (subst_const_proj sub) cb.const_proj in + if body' == cb.const_body && type' == cb.const_type + && proj' == cb.const_proj then cb else { const_hyps = []; const_body = body'; const_type = type'; + const_proj = proj'; const_body_code = Cemitcodes.subst_to_patch_subst sub cb.const_body_code; - const_constraints = cb.const_constraints; + const_polymorphic = cb.const_polymorphic; + const_universes = cb.const_universes; const_inline_code = cb.const_inline_code } (** {7 Hash-consing of constants } *) @@ -89,16 +102,7 @@ let hcons_rel_decl ((n,oc,t) as d) = let hcons_rel_context l = List.smartmap hcons_rel_decl l -let hcons_polyarity ar = - { poly_param_levels = - List.smartmap (Option.smartmap Univ.hcons_univ) ar.poly_param_levels; - poly_level = Univ.hcons_univ ar.poly_level } - -let hcons_const_type = function - | NonPolymorphicType t -> - NonPolymorphicType (Term.hcons_constr t) - | PolymorphicArity (ctx,s) -> - PolymorphicArity (hcons_rel_context ctx, hcons_polyarity s) +let hcons_const_type t = Term.hcons_constr t let hcons_const_def = function | Undef inl -> Undef inl @@ -111,7 +115,11 @@ let hcons_const_body cb = { cb with const_body = hcons_const_def cb.const_body; const_type = hcons_const_type cb.const_type; - const_constraints = Univ.hcons_constraints cb.const_constraints; } + const_universes = + if Future.is_val cb.const_universes then + Future.from_val + (Univ.hcons_universe_context (Future.force cb.const_universes)) + else (* FIXME: Why not? *) cb.const_universes } (** {6 Inductive types } *) @@ -124,10 +132,10 @@ let eq_recarg r1 r2 = match r1, r2 with let subst_recarg sub r = match r with | Norec -> r | Mrec (kn,i) -> - let kn' = subst_ind sub kn in + let kn' = subst_mind sub kn in if kn==kn' then r else Mrec (kn',i) | Imbr (kn,i) -> - let kn' = subst_ind sub kn in + let kn' = subst_mind sub kn in if kn==kn' then r else Imbr (kn',i) let mk_norec = Rtree.mk_node Norec [||] @@ -156,63 +164,108 @@ let subst_wf_paths sub p = Rtree.smartmap (subst_recarg sub) p (** {7 Substitution of inductive declarations } *) -let subst_indarity sub ar = match ar with - | Monomorphic s -> - let uar' = subst_mps sub s.mind_user_arity in - if uar' == s.mind_user_arity then ar - else Monomorphic { mind_user_arity = uar'; mind_sort = s.mind_sort } - | Polymorphic _ -> ar - -let subst_mind_packet sub mip = - let { mind_nf_lc = nf; - mind_user_lc = user; - mind_arity_ctxt = ctxt; - mind_arity = ar; - mind_recargs = ra } = mip - in - let nf' = Array.smartmap (subst_mps sub) nf in - let user' = - (* maintain sharing of [mind_user_lc] and [mind_nf_lc] *) - if user==nf then nf' - else Array.smartmap (subst_mps sub) user - in - let ctxt' = subst_rel_context sub ctxt in - let ar' = subst_indarity sub ar in - let ra' = subst_wf_paths sub ra in - if nf==nf' && user==user' && ctxt==ctxt' && ar==ar' && ra==ra' - then mip - else - { mip with - mind_nf_lc = nf'; - mind_user_lc = user'; - mind_arity_ctxt = ctxt'; - mind_arity = ar'; - mind_recargs = ra' } - -let subst_mind sub mib = - assert (List.is_empty mib.mind_hyps); (* we're outside sections *) - if is_empty_subst sub then mib - else - let params = mib.mind_params_ctxt in - let params' = Context.map_rel_context (subst_mps sub) params in - let packets = mib.mind_packets in - let packets' = Array.smartmap (subst_mind_packet sub) packets in - if params==params' && packets==packets' then mib - else - { mib with - mind_params_ctxt = params'; - mind_packets = packets' } - -(** {6 Hash-consing of inductive declarations } *) - -(** Just as for constants, this hash-consing is quite partial *) - -let hcons_indarity = function - | Monomorphic a -> - Monomorphic - { mind_user_arity = Term.hcons_constr a.mind_user_arity; - mind_sort = Term.hcons_sorts a.mind_sort } - | Polymorphic a -> Polymorphic (hcons_polyarity a) +(* OLD POLYMORPHISM *) +(* let subst_indarity sub ar = match ar with *) +(* | Monomorphic s -> *) +(* let uar' = subst_mps sub s.mind_user_arity in *) +(* if uar' == s.mind_user_arity then ar *) +(* else Monomorphic { mind_user_arity = uar'; mind_sort = s.mind_sort } *) +(* | Polymorphic _ -> ar *) + +(* let subst_mind_packet sub mip = *) +(* let { mind_nf_lc = nf; *) +(* mind_user_lc = user; *) +(* mind_arity_ctxt = ctxt; *) +(* mind_arity = ar; *) +(* mind_recargs = ra } = mip *) +(* in *) +(* let nf' = Array.smartmap (subst_mps sub) nf in *) +(* let user' = *) +(* (\* maintain sharing of [mind_user_lc] and [mind_nf_lc] *\) *) +(* if user==nf then nf' *) +(* else Array.smartmap (subst_mps sub) user *) +(* in *) +(* let ctxt' = subst_rel_context sub ctxt in *) +(* let ar' = subst_indarity sub ar in *) +(* let ra' = subst_wf_paths sub ra in *) +(* if nf==nf' && user==user' && ctxt==ctxt' && ar==ar' && ra==ra' *) +(* then mip *) +(* else *) +(* { mip with *) +(* mind_nf_lc = nf'; *) +(* mind_user_lc = user'; *) +(* mind_arity_ctxt = ctxt'; *) +(* mind_arity = ar'; *) +(* mind_recargs = ra' } *) + +(* let subst_mind sub mib = *) +(* assert (List.is_empty mib.mind_hyps); (\* we're outside sections *\) *) +(* if is_empty_subst sub then mib *) +(* else *) +(* let params = mib.mind_params_ctxt in *) +(* let params' = Context.map_rel_context (subst_mps sub) params in *) +(* let packets = mib.mind_packets in *) +(* let packets' = Array.smartmap (subst_mind_packet sub) packets in *) +(* if params==params' && packets==packets' then mib *) +(* else *) +(* { mib with *) +(* mind_params_ctxt = params'; *) +(* mind_packets = packets'; *) +(* mind_native_name = ref NotLinked } *) + +(* (\** {6 Hash-consing of inductive declarations } *\) *) + +(* (\** Just as for constants, this hash-consing is quite partial *\) *) + +(* let hcons_indarity = function *) +(* | Monomorphic a -> *) +(* Monomorphic *) +(* { mind_user_arity = Term.hcons_constr a.mind_user_arity; *) +(* mind_sort = Term.hcons_sorts a.mind_sort } *) +(* | Polymorphic a -> Polymorphic (hcons_polyarity a) *) + +(** Substitution of inductive declarations *) + +let subst_indarity sub s = + { mind_user_arity = subst_mps sub s.mind_user_arity; + mind_sort = s.mind_sort; + } + +let subst_mind_packet sub mbp = + { mind_consnames = mbp.mind_consnames; + mind_consnrealdecls = mbp.mind_consnrealdecls; + mind_consnrealargs = mbp.mind_consnrealargs; + mind_typename = mbp.mind_typename; + mind_nf_lc = Array.smartmap (subst_mps sub) mbp.mind_nf_lc; + mind_arity_ctxt = subst_rel_context sub mbp.mind_arity_ctxt; + mind_arity = subst_indarity sub mbp.mind_arity; + mind_user_lc = Array.smartmap (subst_mps sub) mbp.mind_user_lc; + mind_nrealargs = mbp.mind_nrealargs; + mind_nrealargs_ctxt = mbp.mind_nrealargs_ctxt; + mind_kelim = mbp.mind_kelim; + mind_recargs = subst_wf_paths sub mbp.mind_recargs (*wf_paths*); + mind_nb_constant = mbp.mind_nb_constant; + mind_nb_args = mbp.mind_nb_args; + mind_reloc_tbl = mbp.mind_reloc_tbl } + +let subst_mind_body sub mib = + { mind_record = mib.mind_record ; + mind_finite = mib.mind_finite ; + mind_ntypes = mib.mind_ntypes ; + mind_hyps = (match mib.mind_hyps with [] -> [] | _ -> assert false); + mind_nparams = mib.mind_nparams; + mind_nparams_rec = mib.mind_nparams_rec; + mind_params_ctxt = + Context.map_rel_context (subst_mps sub) mib.mind_params_ctxt; + mind_packets = Array.smartmap (subst_mind_packet sub) mib.mind_packets ; + mind_polymorphic = mib.mind_polymorphic; + mind_universes = mib.mind_universes } + +(** Hash-consing of inductive declarations *) + +let hcons_indarity a = + { mind_user_arity = Term.hcons_constr a.mind_user_arity; + mind_sort = Term.hcons_sorts a.mind_sort } let hcons_mind_packet oib = let user = Array.smartmap Term.hcons_types oib.mind_user_lc in @@ -231,11 +284,12 @@ let hcons_mind mib = { mib with mind_packets = Array.smartmap hcons_mind_packet mib.mind_packets; mind_params_ctxt = hcons_rel_context mib.mind_params_ctxt; - mind_constraints = Univ.hcons_constraints mib.mind_constraints } + mind_universes = Univ.hcons_universe_context mib.mind_universes } (** {6 Stm machinery } *) let join_constant_body cb = + ignore(Future.join cb.const_universes); match cb.const_body with | OpaqueDef o -> Opaqueproof.join_opaque o | _ -> () diff --git a/kernel/declareops.mli b/kernel/declareops.mli index 800b167ab..0c5f3584e 100644 --- a/kernel/declareops.mli +++ b/kernel/declareops.mli @@ -57,7 +57,7 @@ val recarg_length : wf_paths -> int -> int val subst_wf_paths : substitution -> wf_paths -> wf_paths -val subst_mind : substitution -> mutual_inductive_body -> mutual_inductive_body +val subst_mind_body : substitution -> mutual_inductive_body -> mutual_inductive_body val join_constant_body : constant_body -> unit diff --git a/kernel/entries.mli b/kernel/entries.mli index 73efc7372..24e029bc0 100644 --- a/kernel/entries.mli +++ b/kernel/entries.mli @@ -44,12 +44,16 @@ type mutual_inductive_entry = { mind_entry_record : bool; mind_entry_finite : bool; mind_entry_params : (Id.t * local_entry) list; - mind_entry_inds : one_inductive_entry list } + mind_entry_inds : one_inductive_entry list; + mind_entry_polymorphic : bool; + mind_entry_universes : Univ.universe_context } (** {6 Constants (Definition/Axiom) } *) type proof_output = constr * Declareops.side_effects type const_entry_body = proof_output Future.computation +type projection = mutual_inductive * int * int * types + type definition_entry = { const_entry_body : const_entry_body; (* List of sectoin variables *) @@ -57,12 +61,16 @@ type definition_entry = { (* State id on which the completion of type checking is reported *) const_entry_feedback : Stateid.t option; const_entry_type : types option; + const_entry_polymorphic : bool; + const_entry_universes : Univ.universe_context; + const_entry_proj : projection option; const_entry_opaque : bool; const_entry_inline_code : bool } type inline = int option (* inlining level, None for no inlining *) -type parameter_entry = Context.section_context option * types * inline +type parameter_entry = + Context.section_context option * bool * types Univ.in_universe_context * inline type constant_entry = | DefinitionEntry of definition_entry diff --git a/kernel/environ.ml b/kernel/environ.ml index d306599ad..323d6fcea 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -26,7 +26,6 @@ open Names open Term open Context open Vars -open Univ open Declarations open Pre_env @@ -46,6 +45,12 @@ let empty_named_context_val = empty_named_context_val let empty_env = empty_env let engagement env = env.env_stratification.env_engagement + +let is_impredicative_set env = + match engagement env with + | Some ImpredicativeSet -> true + | _ -> false + let universes env = env.env_stratification.env_universes let named_context env = env.env_named_context let named_context_val env = env.env_named_context,env.env_named_vals @@ -160,6 +165,30 @@ let fold_named_context f env ~init = let fold_named_context_reverse f ~init env = Context.fold_named_context_reverse f ~init:init (named_context env) + +(* Universe constraints *) + +let add_constraints c env = + if Univ.Constraint.is_empty c then + env + else + let s = env.env_stratification in + { env with env_stratification = + { s with env_universes = Univ.merge_constraints c s.env_universes } } + +let check_constraints c env = + Univ.check_constraints c env.env_stratification.env_universes + +let set_engagement c env = (* Unsafe *) + { env with env_stratification = + { env.env_stratification with env_engagement = Some c } } + +let push_constraints_to_env (_,univs) env = + add_constraints univs env + +let push_context ctx env = add_constraints (Univ.UContext.constraints ctx) env +let push_context_set ctx env = add_constraints (Univ.ContextSet.constraints ctx) env + (* Global constants *) let lookup_constant = lookup_constant @@ -177,30 +206,113 @@ let add_constant_key kn cb linkinfo env = let add_constant kn cb env = add_constant_key kn cb (no_link_info ()) env +let universes_of cb = + Future.force cb.const_universes + +let universes_and_subst_of cb u = + let univs = universes_of cb in + let subst = Univ.make_universe_subst u univs in + subst, Univ.instantiate_univ_context subst univs + (* constant_type gives the type of a constant *) -let constant_type env kn = +let constant_type env (kn,u) = let cb = lookup_constant kn env in - cb.const_type + if cb.const_polymorphic then + let subst, csts = universes_and_subst_of cb u in + (subst_univs_constr subst cb.const_type, csts) + else cb.const_type, Univ.Constraint.empty -type const_evaluation_result = NoBody | Opaque +let constant_type_in_ctx env kn = + let cb = lookup_constant kn env in + cb.const_type, Future.force cb.const_universes + +let constant_context env kn = + let cb = lookup_constant kn env in + if cb.const_polymorphic then Future.force cb.const_universes + else Univ.UContext.empty + +type const_evaluation_result = NoBody | Opaque | IsProj exception NotEvaluableConst of const_evaluation_result -let constant_value env kn = +let constant_value env (kn,u) = + let cb = lookup_constant kn env in + if cb.const_proj = None then + match cb.const_body with + | Def l_body -> + if cb.const_polymorphic then + let subst, csts = universes_and_subst_of cb u in + (subst_univs_constr subst (Mod_subst.force_constr l_body), csts) + else Mod_subst.force_constr l_body, Univ.Constraint.empty + | OpaqueDef _ -> raise (NotEvaluableConst Opaque) + | Undef _ -> raise (NotEvaluableConst NoBody) + else raise (NotEvaluableConst IsProj) + +let constant_opt_value env cst = + try Some (constant_value env cst) + with NotEvaluableConst _ -> None + +let constant_value_and_type env (kn, u) = + let cb = lookup_constant kn env in + if cb.const_polymorphic then + let subst, cst = universes_and_subst_of cb u in + let b' = match cb.const_body with + | Def l_body -> Some (subst_univs_constr subst (Mod_subst.force_constr l_body)) + | OpaqueDef _ -> None + | Undef _ -> None + in b', subst_univs_constr subst cb.const_type, cst + else + let b' = match cb.const_body with + | Def l_body -> Some (Mod_subst.force_constr l_body) + | OpaqueDef _ -> None + | Undef _ -> None + in b', cb.const_type, Univ.Constraint.empty + +(* These functions should be called under the invariant that [env] + already contains the constraints corresponding to the constant + application. *) + +(* constant_type gives the type of a constant *) +let constant_type_in env (kn,u) = + let cb = lookup_constant kn env in + if cb.const_polymorphic then + let subst = Univ.make_universe_subst u (Future.force cb.const_universes) in + subst_univs_constr subst cb.const_type + else cb.const_type + +let constant_value_in env (kn,u) = let cb = lookup_constant kn env in match cb.const_body with - | Def l_body -> Mod_subst.force_constr l_body + | Def l_body -> + let b = Mod_subst.force_constr l_body in + if cb.const_polymorphic then + let subst = Univ.make_universe_subst u (Future.force cb.const_universes) in + subst_univs_constr subst b + else b | OpaqueDef _ -> raise (NotEvaluableConst Opaque) | Undef _ -> raise (NotEvaluableConst NoBody) -let constant_opt_value env cst = - try Some (constant_value env cst) +let constant_opt_value_in env cst = + try Some (constant_value_in env cst) with NotEvaluableConst _ -> None (* A global const is evaluable if it is defined and not opaque *) -let evaluable_constant cst env = - try let _ = constant_value env cst in true - with NotEvaluableConst _ -> false +let evaluable_constant kn env = + let cb = lookup_constant kn env in + match cb.const_body with + | Def _ -> true + | OpaqueDef _ -> false + | Undef _ -> false + +let lookup_projection cst env = + match (lookup_constant cst env).const_proj with + | Some pb -> pb + | None -> anomaly (Pp.str "lookup_projection: constant is not a projection") + +let is_projection cst env = + match (lookup_constant cst env).const_proj with + | Some _ -> true + | None -> false (* Mutual Inductives *) let lookup_mind = lookup_mind @@ -215,21 +327,10 @@ let add_mind_key kn mind_key env = let add_mind kn mib env = let li = no_link_info () in add_mind_key kn (mib, li) env -(* Universe constraints *) - -let add_constraints c env = - if is_empty_constraint c then - env - else - let s = env.env_stratification in - { env with env_stratification = - { s with env_universes = merge_constraints c s.env_universes } } +(* Lookup of section variables *) -let set_engagement c env = (* Unsafe *) - { env with env_stratification = - { env.env_stratification with env_engagement = Some c } } +let constant_body_hyps cb = cb.const_hyps -(* Lookup of section variables *) let lookup_constant_variables c env = let cmap = lookup_constant c env in Context.vars_of_named_context cmap.const_hyps @@ -246,9 +347,10 @@ let lookup_constructor_variables (ind,_) env = let vars_of_global env constr = match kind_of_term constr with Var id -> Id.Set.singleton id - | Const kn -> lookup_constant_variables kn env - | Ind ind -> lookup_inductive_variables ind env - | Construct cstr -> lookup_constructor_variables cstr env + | Const (kn, _) -> lookup_constant_variables kn env + | Ind (ind, _) -> lookup_inductive_variables ind env + | Construct (cstr, _) -> lookup_constructor_variables cstr env + (** FIXME: is Proj missing? *) | _ -> raise Not_found let global_vars_set env constr = @@ -423,7 +525,7 @@ let unregister env field = is abstract, and that the only function which add elements to the retroknowledge is Environ.register which enforces this shape *) (match kind_of_term (retroknowledge find env field) with - | Ind i31t -> let i31c = mkConstruct (i31t, 1) in + | Ind i31t -> let i31c = mkConstructUi (i31t, 1) in {env with retroknowledge = remove (retroknowledge clear_info env i31c) field} | _ -> assert false) @@ -487,7 +589,7 @@ let register = let add_int31_before_match rk grp v = let rk = add_vm_before_match_info rk v Cbytegen.int31_escape_before_match in match kind_of_term (Retroknowledge.find rk (KInt31 (grp,Int31Bits))) with - | Ind i31bit_type -> + | Ind (i31bit_type,_) -> add_native_before_match_info rk v (Nativelambda.before_match_int31 i31bit_type) | _ -> anomaly ~label:"Environ.register" (Pp.str "Int31Bits should be an inductive type") @@ -498,13 +600,13 @@ fun env field value -> operators to the reactive retroknowledge. *) let add_int31_binop_from_const op prim = match kind_of_term value with - | Const kn -> retroknowledge add_int31_op env value 2 + | Const (kn,_) -> retroknowledge add_int31_op env value 2 op prim kn | _ -> anomaly ~label:"Environ.register" (Pp.str "should be a constant") in let add_int31_unop_from_const op prim = match kind_of_term value with - | Const kn -> retroknowledge add_int31_op env value 1 + | Const (kn,_) -> retroknowledge add_int31_op env value 1 op prim kn | _ -> anomaly ~label:"Environ.register" (Pp.str "should be a constant") in @@ -516,9 +618,9 @@ fun env field value -> match field with | KInt31 (grp, Int31Type) -> (match kind_of_term (Retroknowledge.find rk (KInt31 (grp,Int31Bits))) with - | Ind i31bit_type -> + | Ind (i31bit_type,_) -> (match kind_of_term value with - | Ind i31t -> + | Ind (i31t,_) -> Retroknowledge.add_vm_decompile_constant_info rk value (constr_of_int31 i31t i31bit_type) | _ -> anomaly ~label:"Environ.register" (Pp.str "should be an inductive type")) @@ -530,7 +632,7 @@ fun env field value -> match field with | KInt31 (grp, Int31Type) -> let i31c = match kind_of_term value with - | Ind i31t -> mkConstruct (i31t, 1) + | Ind i31t -> mkConstructUi (i31t, 1) | _ -> anomaly ~label:"Environ.register" (Pp.str "should be an inductive type") in add_int31_decompilation_from_type @@ -554,7 +656,7 @@ fun env field value -> Primitives.Int31mulc | KInt31 (_, Int31Div21) -> (* this is a ternary operation *) (match kind_of_term value with - | Const kn -> + | Const (kn,u) -> retroknowledge add_int31_op env value 3 Cbytecodes.Kdiv21int31 Primitives.Int31div21 kn | _ -> anomaly ~label:"Environ.register" (Pp.str "should be a constant")) @@ -562,7 +664,7 @@ fun env field value -> Primitives.Int31div | KInt31 (_, Int31AddMulDiv) -> (* this is a ternary operation *) (match kind_of_term value with - | Const kn -> + | Const (kn,u) -> retroknowledge add_int31_op env value 3 Cbytecodes.Kaddmuldivint31 Primitives.Int31addmuldiv kn | _ -> anomaly ~label:"Environ.register" (Pp.str "should be a constant")) diff --git a/kernel/environ.mli b/kernel/environ.mli index 652cd59bf..fb5d79718 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -10,6 +10,7 @@ open Names open Term open Context open Declarations +open Univ (** Unsafe environments. We define here a datatype for environments. Since typing is not yet defined, it is not possible to check the @@ -47,6 +48,7 @@ val named_context_val : env -> named_context_val val engagement : env -> engagement option +val is_impredicative_set : env -> bool (** is the local context empty *) val empty_context : env -> bool @@ -125,17 +127,36 @@ val add_constant_key : constant -> constant_body -> Pre_env.link_info ref -> val lookup_constant : constant -> env -> constant_body val evaluable_constant : constant -> env -> bool +val lookup_projection : Names.projection -> env -> projection_body +val is_projection : constant -> env -> bool + (** {6 ... } *) (** [constant_value env c] raises [NotEvaluableConst Opaque] if [c] is opaque and [NotEvaluableConst NoBody] if it has no - body and [Not_found] if it does not exist in [env] *) + body and [NotEvaluableConst IsProj] if [c] is a projection + and [Not_found] if it does not exist in [env] *) -type const_evaluation_result = NoBody | Opaque +type const_evaluation_result = NoBody | Opaque | IsProj exception NotEvaluableConst of const_evaluation_result -val constant_value : env -> constant -> constr -val constant_type : env -> constant -> constant_type -val constant_opt_value : env -> constant -> constr option +val constant_value : env -> constant puniverses -> constr constrained +val constant_type : env -> constant puniverses -> types constrained +val constant_type_in_ctx : env -> constant -> types Univ.in_universe_context + +val constant_opt_value : env -> constant puniverses -> (constr * Univ.constraints) option +val constant_value_and_type : env -> constant puniverses -> + types option * constr * Univ.constraints +(** The universe context associated to the constant, empty if not + polymorphic *) +val constant_context : env -> constant -> Univ.universe_context + +(* These functions should be called under the invariant that [env] + already contains the constraints corresponding to the constant + application. *) +val constant_value_in : env -> constant puniverses -> constr +val constant_type_in : env -> constant puniverses -> types +val constant_opt_value_in : env -> constant puniverses -> constr option + (** {5 Inductive types } *) val add_mind_key : mutual_inductive -> Pre_env.mind_key -> env -> env @@ -157,8 +178,17 @@ val lookup_modtype : module_path -> env -> module_type_body (** {5 Universe constraints } *) +(** Add universe constraints to the environment. + @raises UniverseInconsistency +*) val add_constraints : Univ.constraints -> env -> env +(** Check constraints are satifiable in the environment. *) +val check_constraints : Univ.constraints -> env -> bool +val push_context : Univ.universe_context -> env -> env +val push_context_set : Univ.universe_context_set -> env -> env +val push_constraints_to_env : 'a Univ.constrained -> env -> env + val set_engagement : engagement -> env -> env (** {6 Sets of referred section variables } diff --git a/kernel/fast_typeops.ml b/kernel/fast_typeops.ml new file mode 100644 index 000000000..b441e02a3 --- /dev/null +++ b/kernel/fast_typeops.ml @@ -0,0 +1,475 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Errors +open Util +open Names +open Univ +open Term +open Vars +open Context +open Declarations +open Environ +open Entries +open Reduction +open Inductive +open Type_errors + +let conv_leq l2r env x y = default_conv CUMUL ~l2r env x y + +let conv_leq_vecti env v1 v2 = + Array.fold_left2_i + (fun i _ t1 t2 -> + try conv_leq false env t1 t2 + with NotConvertible -> raise (NotConvertibleVect i)) + () + v1 + v2 + +let check_constraints cst env = + if Environ.check_constraints cst env then () + else error_unsatisfied_constraints env cst + +(* This should be a type (a priori without intension to be an assumption) *) +let type_judgment env c t = + match kind_of_term(whd_betadeltaiota env t) with + | Sort s -> {utj_val = c; utj_type = s } + | _ -> error_not_type env (make_judge c t) + +let check_type env c t = + match kind_of_term(whd_betadeltaiota env t) with + | Sort s -> s + | _ -> error_not_type env (make_judge c t) + +(* This should be a type intended to be assumed. The error message is *) +(* not as useful as for [type_judgment]. *) +let assumption_of_judgment env t ty = + try let _ = check_type env t ty in t + with TypeError _ -> + error_assumption env (make_judge t ty) + +(************************************************) +(* Incremental typing rules: builds a typing judgement given the *) +(* judgements for the subterms. *) + +(*s Type of sorts *) + +(* Prop and Set *) + +let judge_of_prop = mkSort type1_sort +let judge_of_set = judge_of_prop + +let judge_of_prop_contents _ = judge_of_prop + +(* Type of Type(i). *) + +let judge_of_type u = + let uu = Universe.super u in + mkType uu + +(*s Type of a de Bruijn index. *) + +let judge_of_relative env n = + try + let (_,_,typ) = lookup_rel n env in + lift n typ + with Not_found -> + error_unbound_rel env n + +(* Type of variables *) +let judge_of_variable env id = + try named_type id env + with Not_found -> + error_unbound_var env id + +(* Management of context of variables. *) + +(* Checks if a context of variables can be instantiated by the + variables of the current env *) +(* TODO: check order? *) +let check_hyps_inclusion env f c sign = + Context.fold_named_context + (fun (id,_,ty1) () -> + try + let ty2 = named_type id env in + if not (eq_constr ty2 ty1) then raise Exit + with Not_found | Exit -> + error_reference_variables env id (f c)) + sign + ~init:() + +(* Instantiation of terms on real arguments. *) + +(* Make a type polymorphic if an arity *) + +(* Type of constants *) + +let type_of_constant env cst = constant_type env cst +let type_of_constant_in env cst = constant_type_in env cst +let type_of_constant_knowing_parameters env t _ = t + +let judge_of_constant env (kn,u as cst) = + let cb = lookup_constant kn env in + let () = check_hyps_inclusion env mkConstU cst cb.const_hyps in + let ty, cu = type_of_constant env cst in + let () = check_constraints cu env in + ty + +let type_of_projection env (cst,u) = + let cb = lookup_constant cst env in + match cb.const_proj with + | Some pb -> + if cb.const_polymorphic then + let mib,_ = lookup_mind_specif env (pb.proj_ind,0) in + let subst = make_inductive_subst mib u in + Vars.subst_univs_constr subst pb.proj_type + else pb.proj_type + | None -> raise (Invalid_argument "type_of_projection: not a projection") + + +(* Type of a lambda-abstraction. *) + +(* [judge_of_abstraction env name var j] implements the rule + + env, name:typ |- j.uj_val:j.uj_type env, |- (name:typ)j.uj_type : s + ----------------------------------------------------------------------- + env |- [name:typ]j.uj_val : (name:typ)j.uj_type + + Since all products are defined in the Calculus of Inductive Constructions + and no upper constraint exists on the sort $s$, we don't need to compute $s$ +*) + +let judge_of_abstraction env name var ty = + mkProd (name, var, ty) + +(* Type of let-in. *) + +let judge_of_letin env name defj typj j = + subst1 defj j + +(* Type of an application. *) + +let make_judgev c t = + Array.map2 make_judge c t + +let judge_of_apply env func funt argsv argstv = + let len = Array.length argsv in + let rec apply_rec i typ = + if Int.equal i len then typ + else + (match kind_of_term (whd_betadeltaiota env typ) with + | Prod (_,c1,c2) -> + let arg = argsv.(i) and argt = argstv.(i) in + (try + let () = conv_leq false env argt c1 in + apply_rec (i+1) (subst1 arg c2) + with NotConvertible -> + error_cant_apply_bad_type env + (i+1,c1,argt) + (make_judge func funt) + (make_judgev argsv argstv)) + + | _ -> + error_cant_apply_not_functional env + (make_judge func funt) + (make_judgev argsv argstv)) + in apply_rec 0 funt + +(* Type of product *) + +let sort_of_product env domsort rangsort = + match (domsort, rangsort) with + (* Product rule (s,Prop,Prop) *) + | (_, Prop Null) -> rangsort + (* Product rule (Prop/Set,Set,Set) *) + | (Prop _, Prop Pos) -> rangsort + (* Product rule (Type,Set,?) *) + | (Type u1, Prop Pos) -> + begin match engagement env with + | Some ImpredicativeSet -> + (* Rule is (Type,Set,Set) in the Set-impredicative calculus *) + rangsort + | _ -> + (* Rule is (Type_i,Set,Type_i) in the Set-predicative calculus *) + Type (Universe.sup Universe.type0 u1) + end + (* Product rule (Prop,Type_i,Type_i) *) + | (Prop Pos, Type u2) -> Type (Universe.sup Universe.type0 u2) + (* Product rule (Prop,Type_i,Type_i) *) + | (Prop Null, Type _) -> rangsort + (* Product rule (Type_i,Type_i,Type_i) *) + | (Type u1, Type u2) -> Type (Universe.sup u1 u2) + +(* [judge_of_product env name (typ1,s1) (typ2,s2)] implements the rule + + env |- typ1:s1 env, name:typ1 |- typ2 : s2 + ------------------------------------------------------------------------- + s' >= (s1,s2), env |- (name:typ)j.uj_val : s' + + where j.uj_type is convertible to a sort s2 +*) +let judge_of_product env name s1 s2 = + let s = sort_of_product env s1 s2 in + mkSort s + +(* Type of a type cast *) + +(* [judge_of_cast env (c,typ1) (typ2,s)] implements the rule + + env |- c:typ1 env |- typ2:s env |- typ1 <= typ2 + --------------------------------------------------------------------- + env |- c:typ2 +*) + +let judge_of_cast env c ct k expected_type = + try + match k with + | VMcast -> + vm_conv CUMUL env ct expected_type + | DEFAULTcast -> + default_conv ~l2r:false CUMUL env ct expected_type + | REVERTcast -> + default_conv ~l2r:true CUMUL env ct expected_type + | NATIVEcast -> + let sigma = Nativelambda.empty_evars in + native_conv CUMUL sigma env ct expected_type + with NotConvertible -> + error_actual_type env (make_judge c ct) expected_type + +(* Inductive types. *) + +(* The type is parametric over the uniform parameters whose conclusion + is in Type; to enforce the internal constraints between the + parameters and the instances of Type occurring in the type of the + constructors, we use the level variables _statically_ assigned to + the conclusions of the parameters as mediators: e.g. if a parameter + has conclusion Type(alpha), static constraints of the form alpha<=v + exist between alpha and the Type's occurring in the constructor + types; when the parameters is finally instantiated by a term of + conclusion Type(u), then the constraints u<=alpha is computed in + the App case of execute; from this constraints, the expected + dynamic constraints of the form u<=v are enforced *) + +(* let judge_of_inductive_knowing_parameters env ind jl = *) +(* let c = mkInd ind in *) +(* let (mib,mip) = lookup_mind_specif env ind in *) +(* check_args env c mib.mind_hyps; *) +(* let paramstyp = Array.map (fun j -> j.uj_type) jl in *) +(* let t = in *) +(* make_judge c t *) + +let judge_of_inductive env (ind,u as indu) = + let (mib,mip) = lookup_mind_specif env ind in + check_hyps_inclusion env mkIndU indu mib.mind_hyps; + let t,cst = Inductive.constrained_type_of_inductive env ((mib,mip),u) in + check_constraints cst env; + t + +(* Constructors. *) + +let judge_of_constructor env (c,u as cu) = + let _ = + let ((kn,_),_) = c in + let mib = lookup_mind kn env in + check_hyps_inclusion env mkConstructU cu mib.mind_hyps in + let specif = lookup_mind_specif env (inductive_of_constructor c) in + let t,cst = constrained_type_of_constructor cu specif in + let () = check_constraints cst env in + t + +(* Case. *) + +let check_branch_types env (ind,u) c ct lft explft = + try conv_leq_vecti env lft explft + with + NotConvertibleVect i -> + error_ill_formed_branch env c ((ind,i+1),u) lft.(i) explft.(i) + | Invalid_argument _ -> + error_number_branches env (make_judge c ct) (Array.length explft) + +let judge_of_case env ci p pt c ct lf lft = + let (pind, _ as indspec) = + try find_rectype env ct + with Not_found -> error_case_not_inductive env (make_judge c ct) in + let _ = check_case_info env pind ci in + let (bty,rslty) = + type_case_branches env indspec (make_judge p pt) c in + let () = check_branch_types env pind c ct lft bty in + rslty + +let judge_of_projection env p c ct = + let pb = lookup_projection p env in + let (ind,u), args = + try find_rectype env ct + with Not_found -> error_case_not_inductive env (make_judge c ct) + in + assert(eq_mind pb.proj_ind (fst ind)); + let usubst = make_inductive_subst (fst (lookup_mind_specif env ind)) u in + let ty = Vars.subst_univs_constr usubst pb.Declarations.proj_type in + substl (c :: List.rev args) ty + + +(* Fixpoints. *) + +(* Checks the type of a general (co)fixpoint, i.e. without checking *) +(* the specific guard condition. *) + +let type_fixpoint env lna lar vdef vdeft = + let lt = Array.length vdeft in + assert (Int.equal (Array.length lar) lt); + try + conv_leq_vecti env vdeft (Array.map (fun ty -> lift lt ty) lar) + with NotConvertibleVect i -> + error_ill_typed_rec_body env i lna (make_judgev vdef vdeft) lar + +(************************************************************************) +(************************************************************************) + +(* The typing machine. *) + (* ATTENTION : faudra faire le typage du contexte des Const, + Ind et Constructsi un jour cela devient des constructions + arbitraires et non plus des variables *) +let rec execute env cstr = + match kind_of_term cstr with + (* Atomic terms *) + | Sort (Prop c) -> + judge_of_prop_contents c + + | Sort (Type u) -> + judge_of_type u + + | Rel n -> + judge_of_relative env n + + | Var id -> + judge_of_variable env id + + | Const c -> + judge_of_constant env c + + | Proj (p, c) -> + let ct = execute env c in + judge_of_projection env p c ct + + (* Lambda calculus operators *) + | App (f,args) -> + let argst = execute_array env args in + let ft = execute env f in + judge_of_apply env f ft args argst + + | Lambda (name,c1,c2) -> + let _ = execute_is_type env c1 in + let env1 = push_rel (name,None,c1) env in + let c2t = execute env1 c2 in + judge_of_abstraction env name c1 c2t + + | Prod (name,c1,c2) -> + let vars = execute_is_type env c1 in + let env1 = push_rel (name,None,c1) env in + let vars' = execute_is_type env1 c2 in + judge_of_product env name vars vars' + + | LetIn (name,c1,c2,c3) -> + let c1t = execute env c1 in + let _c2s = execute_is_type env c2 in + let _ = judge_of_cast env c1 c1t DEFAULTcast c2 in + let env1 = push_rel (name,Some c1,c2) env in + let c3t = execute env1 c3 in + subst1 c1 c3t + + | Cast (c,k,t) -> + let ct = execute env c in + let _ts = execute_type env t in + let _ = judge_of_cast env c ct k t in + t + + (* Inductive types *) + | Ind ind -> + judge_of_inductive env ind + + | Construct c -> + judge_of_constructor env c + + | Case (ci,p,c,lf) -> + let ct = execute env c in + let pt = execute env p in + let lft = execute_array env lf in + judge_of_case env ci p pt c ct lf lft + + | Fix ((vn,i as vni),recdef) -> + let (fix_ty,recdef') = execute_recdef env recdef i in + let fix = (vni,recdef') in + check_fix env fix; fix_ty + + | CoFix (i,recdef) -> + let (fix_ty,recdef') = execute_recdef env recdef i in + let cofix = (i,recdef') in + check_cofix env cofix; fix_ty + + (* Partial proofs: unsupported by the kernel *) + | Meta _ -> + anomaly (Pp.str "the kernel does not support metavariables") + + | Evar _ -> + anomaly (Pp.str "the kernel does not support existential variables") + +and execute_is_type env constr = + let t = execute env constr in + check_type env constr t + +and execute_type env constr = + let t = execute env constr in + type_judgment env constr t + +and execute_recdef env (names,lar,vdef) i = + let lart = execute_array env lar in + let lara = Array.map2 (assumption_of_judgment env) lar lart in + let env1 = push_rec_types (names,lara,vdef) env in + let vdeft = execute_array env1 vdef in + let () = type_fixpoint env1 names lara vdef vdeft in + (lara.(i),(names,lara,vdef)) + +and execute_array env = Array.map (execute env) + +(* Derived functions *) +let infer env constr = + let t = execute env constr in + make_judge constr t + +(* let infer_key = Profile.declare_profile "Fast_infer" *) +(* let infer = Profile.profile2 infer_key infer *) + +let infer_type env constr = + execute_type env constr + +let infer_v env cv = + let jv = execute_array env cv in + make_judgev cv jv + +(* Typing of several terms. *) + +let infer_local_decl env id = function + | LocalDef c -> + let t = execute env c in + (Name id, Some c, t) + | LocalAssum c -> + let t = execute env c in + (Name id, None, assumption_of_judgment env c t) + +let infer_local_decls env decls = + let rec inferec env = function + | (id, d) :: l -> + let (env, l) = inferec env l in + let d = infer_local_decl env id d in + (push_rel d env, add_rel_decl d l) + | [] -> (env, empty_rel_context) in + inferec env decls + +(* Exported typing functions *) + +let typing env c = infer env c diff --git a/kernel/fast_typeops.mli b/kernel/fast_typeops.mli new file mode 100644 index 000000000..7ff5577cb --- /dev/null +++ b/kernel/fast_typeops.mli @@ -0,0 +1,28 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Names +open Univ +open Term +open Context +open Environ +open Entries +open Declarations + +(** {6 Typing functions (not yet tagged as safe) } + + They return unsafe judgments that are "in context" of a set of + (local) universe variables (the ones that appear in the term) + and associated constraints. In case of polymorphic definitions, + these variables and constraints will be generalized. + *) + + +val infer : env -> constr -> unsafe_judgment +val infer_v : env -> constr array -> unsafe_judgment array +val infer_type : env -> types -> unsafe_type_judgment diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index 2defb66f4..0ac6a4e4a 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -20,6 +20,15 @@ open Environ open Reduction open Typeops open Entries +open Pp + +(* Tell if indices (aka real arguments) contribute to size of inductive type *) +(* If yes, this is compatible with the univalent model *) + +let indices_matter = ref false + +let enforce_indices_matter () = indices_matter := true +let is_indices_matter () = !indices_matter (* Same as noccur_between but may perform reductions. Could be refined more... *) @@ -107,26 +116,22 @@ let is_logic_constr infos = List.for_all (fun (logic,small) -> logic) infos *) let is_unit constrsinfos = match constrsinfos with (* One info = One constructor *) - | [constrinfos] -> is_logic_constr constrinfos + | [level] -> is_type0m_univ level | [] -> (* type without constructors *) true | _ -> false -let rec infos_and_sort env t = - let t = whd_betadeltaiota env t in - match kind_of_term t with - | Prod (name,c1,c2) -> - let (varj,_) = infer_type env c1 in +let infos_and_sort env ctx t = + let rec aux env ctx t max = + let t = whd_betadeltaiota env t in + match kind_of_term t with + | Prod (name,c1,c2) -> + let varj = infer_type env c1 in let env1 = Environ.push_rel (name,None,varj.utj_val) env in - let logic = is_logic_type varj in - let small = Term.is_small varj.utj_type in - (logic,small) :: (infos_and_sort env1 c2) - | _ when is_constructor_head t -> [] - | _ -> (* don't fail if not positive, it is tested later *) [] - -let small_unit constrsinfos = - let issmall = List.for_all is_small constrsinfos - and isunit = is_unit constrsinfos in - issmall, isunit + let max = Universe.sup max (univ_of_sort varj.utj_type) in + aux env1 ctx c2 max + | _ when is_constructor_head t -> max + | _ -> (* don't fail if not positive, it is tested later *) max + in aux env ctx t Universe.type0m (* Computing the levels of polymorphic inductive types @@ -148,40 +153,52 @@ let small_unit constrsinfos = w1,w2,w3 <= u3 *) -let extract_level (_,_,_,lc,lev) = +let extract_level (_,_,lc,(_,lev)) = (* Enforce that the level is not in Prop if more than one constructor *) - if Array.length lc >= 2 then sup type0_univ lev else lev + (* if Array.length lc >= 2 then sup type0_univ lev else lev *) + lev let inductive_levels arities inds = - let levels = Array.map pi3 arities in let cstrs_levels = Array.map extract_level inds in (* Take the transitive closure of the system of constructors *) (* level constraints and remove the recursive dependencies *) - solve_constraints_system levels cstrs_levels + cstrs_levels (* This (re)computes informations relevant to extraction and the sort of an arity or type constructor; we do not to recompute universes constraints *) -let constraint_list_union = - List.fold_left union_constraints empty_constraint +let context_set_list_union = + List.fold_left ContextSet.union ContextSet.empty -let infer_constructor_packet env_ar_par params lc = +let infer_constructor_packet env_ar_par ctx params lc = (* type-check the constructors *) - let jlc,cstl = List.split (List.map (infer_type env_ar_par) lc) in - let cst = constraint_list_union cstl in + let jlc = List.map (infer_type env_ar_par) lc in let jlc = Array.of_list jlc in (* generalize the constructor over the parameters *) let lc'' = Array.map (fun j -> it_mkProd_or_LetIn j.utj_val params) jlc in - (* compute the max of the sorts of the products of the constructor type *) - let level = max_inductive_sort (Array.map (fun j -> j.utj_type) jlc) in - (* compute *) - let info = small_unit (List.map (infos_and_sort env_ar_par) lc) in - - (info,lc'',level,cst) + (* compute the max of the sorts of the products of the constructors types *) + let levels = List.map (infos_and_sort env_ar_par ctx) lc in + let level = List.fold_left (fun max l -> Universe.sup max l) Universe.type0m levels in + (lc'',(is_unit levels,level)) + +(* If indices matter *) +let cumulate_arity_large_levels env sign = + fst (List.fold_right + (fun (_,_,t as d) (lev,env) -> + let tj = infer_type env t in + let u = univ_of_sort tj.utj_type in + (Universe.sup u lev, push_rel d env)) + sign (Universe.type0m,env)) + +let is_impredicative env u = + is_type0m_univ u || (is_type0_univ u && engagement env = Some ImpredicativeSet) (* Type-check an inductive definition. Does not check positivity conditions. *) -let typecheck_inductive env mie = +(* TODO check that we don't overgeneralize construcors/inductive arities with + universes that are absent from them. Is it possible? +*) +let typecheck_inductive env ctx mie = let () = match mie.mind_entry_inds with | [] -> anomaly (Pp.str "empty inductive types declaration") | _ -> () @@ -189,116 +206,103 @@ let typecheck_inductive env mie = (* Check unicity of names *) mind_check_names mie; (* Params are typed-checked here *) - let env_params, params, cst1 = infer_local_decls env mie.mind_entry_params in + let env' = push_context ctx env in + let (env_params, params) = infer_local_decls env' mie.mind_entry_params in (* We first type arity of each inductive definition *) (* This allows to build the environment of arities and to share *) (* the set of constraints *) - let cst, env_arities, rev_arity_list = + let env_arities, rev_arity_list = List.fold_left - (fun (cst,env_ar,l) ind -> + (fun (env_ar,l) ind -> (* Arities (without params) are typed-checked here *) - let arity, cst2 = infer_type env_params ind.mind_entry_arity in + let arity = + if isArity ind.mind_entry_arity then + let (ctx,s) = destArity ind.mind_entry_arity in + match s with + | Type u when Univ.universe_level u = None -> + (** We have an algebraic universe as the conclusion of the arity, + typecheck the dummy Π ctx, Prop and do a special case for the conclusion. + *) + let proparity = infer_type env_params (mkArity (ctx, prop_sort)) in + let (cctx, _) = destArity proparity.utj_val in + (* Any universe is well-formed, we don't need to check [s] here *) + mkArity (cctx, s) + | _ -> let arity = infer_type env_params ind.mind_entry_arity in + arity.utj_val + else let arity = infer_type env_params ind.mind_entry_arity in + arity.utj_val + in + let (sign, deflev) = dest_arity env_params arity in + let inflev = + (* The level of the inductive includes levels of indices if + in indices_matter mode *) + if !indices_matter + then Some (cumulate_arity_large_levels env_params sign) + else None + in (* We do not need to generate the universe of full_arity; if later, after the validation of the inductive definition, full_arity is used as argument or subject to cast, an upper universe will be generated *) - let full_arity = it_mkProd_or_LetIn arity.utj_val params in - let cst = union_constraints cst cst2 in + let full_arity = it_mkProd_or_LetIn arity params in let id = ind.mind_entry_typename in let env_ar' = - push_rel (Name id, None, full_arity) - (add_constraints cst2 env_ar) in - let lev = - (* Decide that if the conclusion is not explicitly Type *) - (* then the inductive type is not polymorphic *) - match kind_of_term ((strip_prod_assum arity.utj_val)) with - | Sort (Type u) -> Some u - | _ -> None in - (cst,env_ar',(id,full_arity,lev)::l)) - (cst1,env,[]) + push_rel (Name id, None, full_arity) env_ar in + (* (add_constraints cst2 env_ar) in *) + (env_ar', (id,full_arity,sign @ params,deflev,inflev)::l)) + (env',[]) mie.mind_entry_inds in let arity_list = List.rev rev_arity_list in (* builds the typing context "Gamma, I1:A1, ... In:An, params" *) - let env_ar_par = - push_rel_context params (add_constraints cst1 env_arities) in + let env_ar_par = push_rel_context params env_arities in (* Now, we type the constructors (without params) *) - let inds,cst = + let inds = List.fold_right2 - (fun ind arity_data (inds,cst) -> - let (info,lc',cstrs_univ,cst') = - infer_constructor_packet env_ar_par params ind.mind_entry_lc in + (fun ind arity_data inds -> + let (lc',cstrs_univ) = + infer_constructor_packet env_ar_par ContextSet.empty + params ind.mind_entry_lc in let consnames = ind.mind_entry_consnames in - let ind' = (arity_data,consnames,info,lc',cstrs_univ) in - (ind'::inds, union_constraints cst cst')) + let ind' = (arity_data,consnames,lc',cstrs_univ) in + ind'::inds) mie.mind_entry_inds arity_list - ([],cst) in + ([]) in let inds = Array.of_list inds in - let arities = Array.of_list arity_list in - let has_some_univ u = function - | Some v when Universe.equal u v -> true - | _ -> false - in - let remove_some_univ u = function - | Some v when Universe.equal u v -> None - | x -> x - in - let fold l (_, b, p) = match b with - | None -> - (* Parameter contributes to polymorphism only if explicit Type *) - let c = strip_prod_assum p in - (* Add Type levels to the ordered list of parameters contributing to *) - (* polymorphism unless there is aliasing (i.e. non distinct levels) *) - begin match kind_of_term c with - | Sort (Type u) -> - if List.exists (has_some_univ u) l then - None :: List.map (remove_some_univ u) l - else - Some u :: l - | _ -> - None :: l - end - | _ -> l - in - let param_ccls = List.fold_left fold [] params in (* Compute/check the sorts of the inductive types *) - let ind_min_levels = inductive_levels arities inds in - let inds, cst = - Array.fold_map2' (fun ((id,full_arity,ar_level),cn,info,lc,_) lev cst -> - let sign, s = - try dest_arity env full_arity - with NotArity -> raise (InductiveError (NotAnArity (env, full_arity))) + + let inds = + Array.map (fun ((id,full_arity,sign,def_level,inf_level),cn,lc,(is_unit,clev)) -> + let defu = Term.univ_of_sort def_level in + let infu = + (** Inferred level, with parameters and constructors. *) + match inf_level with + | Some alev -> Universe.sup clev alev + | None -> clev + in + let is_natural = + check_leq (universes env') infu defu && + not (is_type0m_univ defu && not is_unit) in - let status,cst = match s with - | Type u when ar_level != None (* Explicitly polymorphic *) - && no_upper_constraints u cst -> - (* The polymorphic level is a function of the level of the *) - (* conclusions of the parameters *) - (* We enforce [u >= lev] in case [lev] has a strict upper *) - (* constraints over [u] *) - Inr (param_ccls, lev), enforce_leq lev u cst - | Type u (* Not an explicit occurrence of Type *) -> - Inl (info,full_arity,s), enforce_leq lev u cst - | Prop Pos when - begin match engagement env with - | Some ImpredicativeSet -> false - | _ -> true - end -> - (* Predicative set: check that the content is indeed predicative *) - if not (is_type0m_univ lev) && not (is_type0_univ lev) then - raise (InductiveError LargeNonPropInductiveNotInType); - Inl (info,full_arity,s), cst - | Prop _ -> - Inl (info,full_arity,s), cst in - (id,cn,lc,(sign,status)),cst) - inds ind_min_levels cst in - - (env_arities, params, inds, cst) + let _ = + (** Impredicative sort, always allow *) + if is_impredicative env defu then () + else (** Predicative case: the inferred level must be lower or equal to the + declared level. *) + if not is_natural then + anomaly ~label:"check_inductive" + (Pp.str"Incorrect universe " ++ + Universe.pr defu ++ Pp.str " declared for inductive type, inferred level is " + ++ Universe.pr infu) + in + (id,cn,lc,(sign,(not is_natural,full_arity,defu)))) + inds + in (env_arities, params, inds) (************************************************************************) (************************************************************************) @@ -387,7 +391,7 @@ if Int.equal nmr 0 then 0 else in find 0 (n-1) (lpar,List.rev hyps) let lambda_implicit_lift n a = - let level = UniverseLevel.make (DirPath.make [Id.of_string "implicit"]) 0 in + let level = Level.make (DirPath.make [Id.of_string "implicit"]) 0 in let implicit_sort = mkType (Universe.make level) in let lambda_implicit a = mkLambda (Anonymous, implicit_sort, a) in iterate lambda_implicit n (lift n a) @@ -413,12 +417,13 @@ let abstract_mind_lc env ntyps npars lc = let ienv_push_var (env, n, ntypes, lra) (x,a,ra) = (push_rel (x,None,a) env, n+1, ntypes, (Norec,ra)::lra) -let ienv_push_inductive (env, n, ntypes, ra_env) (mi,lpar) = +let ienv_push_inductive (env, n, ntypes, ra_env) ((mi,u),lpar) = let auxntyp = 1 in - let specif = lookup_mind_specif env mi in + let specif = (lookup_mind_specif env mi, u) in + let ty = type_of_inductive env specif in let env' = push_rel (Anonymous,None, - hnf_prod_applist env (type_of_inductive env specif) lpar) env in + hnf_prod_applist env ty lpar) env in let ra_env' = (Imbr mi,(Rtree.mk_rec_calls 1).(0)) :: List.map (fun (r,t) -> (r,Rtree.lift 1 t)) ra_env in @@ -476,7 +481,7 @@ let check_positivity_one (env,_,ntypes,_ as ienv) hyps (_,i as ind) nargs lcname else failwith_non_pos_list n ntypes (x::largs) (* accesses to the environment are not factorised, but is it worth? *) - and check_positive_nested (env,n,ntypes,ra_env as ienv) nmr (mi, largs) = + and check_positive_nested (env,n,ntypes,ra_env as ienv) nmr ((mi,u), largs) = let (mib,mip) = lookup_mind_specif env mi in let auxnpar = mib.mind_nparams_rec in let nonrecpar = mib.mind_nparams - auxnpar in @@ -495,7 +500,7 @@ let check_positivity_one (env,_,ntypes,_ as ienv) hyps (_,i as ind) nargs lcname let auxlcvect = abstract_mind_lc env auxntyp auxnpar mip.mind_nf_lc in (* Extends the environment with a variable corresponding to the inductive def *) - let (env',_,_,_ as ienv') = ienv_push_inductive ienv (mi,lpar) in + let (env',_,_,_ as ienv') = ienv_push_inductive ienv ((mi,u),lpar) in (* Parameters expressed in env' *) let lpar' = List.map (lift auxntyp) lpar in let irecargs_nmr = @@ -586,40 +591,72 @@ let all_sorts = [InProp;InSet;InType] let small_sorts = [InProp;InSet] let logical_sorts = [InProp] -let allowed_sorts issmall isunit s = - match family_of_sort s with - (* Type: all elimination allowed *) - | InType -> all_sorts - - (* Small Set is predicative: all elimination allowed *) - | InSet when issmall -> all_sorts - - (* Large Set is necessarily impredicative: forbids large elimination *) - | InSet -> small_sorts - - (* Unitary/empty Prop: elimination to all sorts are realizable *) - (* unless the type is large. If it is large, forbids large elimination *) - (* which otherwise allows to simulate the inconsistent system Type:Type *) - | InProp when isunit -> if issmall then all_sorts else small_sorts - - (* Other propositions: elimination only to Prop *) - | InProp -> logical_sorts +let allowed_sorts is_smashed s = + if not is_smashed + then (** Naturally in the defined sort. + If [s] is Prop, it must be small and unitary. + Unsmashed, predicative Type and Set: all elimination allowed + as well. *) + all_sorts + else + match family_of_sort s with + (* Type: all elimination allowed: above and below *) + | InType -> all_sorts + (* Smashed Set is necessarily impredicative: forbids large elimination *) + | InSet -> small_sorts + (* Smashed to Prop, no informative eliminations allowed *) + | InProp -> logical_sorts + +(* Previous comment: *) +(* Unitary/empty Prop: elimination to all sorts are realizable *) +(* unless the type is large. If it is large, forbids large elimination *) +(* which otherwise allows to simulate the inconsistent system Type:Type. *) +(* -> this is now handled by is_smashed: *) +(* - all_sorts in case of small, unitary Prop (not smashed) *) +(* - logical_sorts in case of large, unitary Prop (smashed) *) let fold_inductive_blocks f = - let concl = function - | Inr _ -> mkSet (* dummy *) - | Inl (_,ar,_) -> ar - in - Array.fold_left (fun acc (_,_,lc,(arsign,ar)) -> - f (Array.fold_left f acc lc) (it_mkProd_or_LetIn (concl ar) arsign)) + Array.fold_left (fun acc (_,_,lc,(arsign,ar)) -> + f (Array.fold_left f acc lc) (it_mkProd_or_LetIn (pi2 ar) arsign)) let used_section_variables env inds = let ids = fold_inductive_blocks (fun l c -> Id.Set.union (Environ.global_vars_set env c) l) Id.Set.empty inds in keep_hyps env ids - -let build_inductive env env_ar params isrecord isfinite inds nmr recargs cst = +let lift_decl n d = + map_rel_declaration (lift n) d + +let rel_vect n m = Array.init m (fun i -> mkRel(n+m-i)) +let rel_list n m = Array.to_list (rel_vect n m) +let rel_appvect n m = rel_vect n (List.length m) + +exception UndefinableExpansion + +(** From a rel context describing the constructor arguments, + build an expansion function. + The term built is expecting to be substituted first by + a substitution of the form [params, x : ind params] *) +let compute_expansion ((kn, _ as ind), u) params ctx = + let mp, dp, l = repr_mind kn in + let make_proj id = Constant.make1 (KerName.make mp dp (Label.of_id id)) in + let rec projections acc (na, b, t) = + match b with + | Some c -> acc + | None -> + match na with + | Name id -> make_proj id :: acc + | Anonymous -> raise UndefinableExpansion + in + let projs = List.fold_left projections [] ctx in + let projarr = Array.of_list projs in + let exp = + mkApp (mkConstructU ((ind, 1),u), + Array.append (rel_appvect 1 params) + (Array.map (fun p -> mkProj (p, mkRel 1)) projarr)) + in exp, projarr + +let build_inductive env p ctx env_ar params kn isrecord isfinite inds nmr recargs = let ntypes = Array.length inds in (* Compute the set of used section variables *) let hyps = used_section_variables env inds in @@ -637,18 +674,13 @@ let build_inductive env env_ar params isrecord isfinite inds nmr recargs cst = Array.map (fun (d,_) -> rel_context_nhyps d - rel_context_nhyps params) splayed_lc in (* Elimination sorts *) - let arkind,kelim = match ar_kind with - | Inr (param_levels,lev) -> - Polymorphic { - poly_param_levels = param_levels; - poly_level = lev; - }, all_sorts - | Inl ((issmall,isunit),ar,s) -> - let kelim = allowed_sorts issmall isunit s in - Monomorphic { - mind_user_arity = ar; - mind_sort = s; - }, kelim in + let arkind,kelim = + let (info,ar,defs) = ar_kind in + let s = sort_of_univ defs in + let kelim = allowed_sorts info s in + { mind_user_arity = ar; + mind_sort = s; + }, kelim in (* Assigning VM tags to constructors *) let nconst, nblock = ref 0, ref 0 in let transf num = @@ -681,6 +713,19 @@ let build_inductive env env_ar params isrecord isfinite inds nmr recargs cst = mind_reloc_tbl = rtbl; } in let packets = Array.map2 build_one_packet inds recargs in + let isrecord = + let pkt = packets.(0) in + if isrecord (* || (Array.length pkt.mind_consnames = 1 && *) + (* inductive_sort_family pkt <> InProp) *) then + let rctx, _ = decompose_prod_assum pkt.mind_nf_lc.(0) in + let u = if p then Univ.UContext.instance ctx else Univ.Instance.empty in + try + let exp = compute_expansion ((kn, 0), u) params + (List.firstn pkt.mind_consnrealdecls.(0) rctx) + in Some exp + with UndefinableExpansion -> None + else None + in (* Build the mutual inductive *) { mind_record = isrecord; mind_ntypes = ntypes; @@ -690,7 +735,8 @@ let build_inductive env env_ar params isrecord isfinite inds nmr recargs cst = mind_nparams_rec = nmr; mind_params_ctxt = params; mind_packets = packets; - mind_constraints = cst + mind_polymorphic = p; + mind_universes = ctx; } (************************************************************************) @@ -698,9 +744,14 @@ let build_inductive env env_ar params isrecord isfinite inds nmr recargs cst = let check_inductive env kn mie = (* First type-check the inductive definition *) - let (env_ar, params, inds, cst) = typecheck_inductive env mie in + let env = push_context mie.mind_entry_universes env in + let (env_ar, params, inds) = + typecheck_inductive env mie.mind_entry_universes mie + in (* Then check positivity conditions *) let (nmr,recargs) = check_positivity kn env_ar params inds in (* Build the inductive packets *) - build_inductive env env_ar params mie.mind_entry_record mie.mind_entry_finite - inds nmr recargs cst + build_inductive env mie.mind_entry_polymorphic + mie.mind_entry_universes + env_ar params kn mie.mind_entry_record mie.mind_entry_finite + inds nmr recargs diff --git a/kernel/indtypes.mli b/kernel/indtypes.mli index 016a1a5b5..8730a3045 100644 --- a/kernel/indtypes.mli +++ b/kernel/indtypes.mli @@ -34,5 +34,12 @@ exception InductiveError of inductive_error (** The following function does checks on inductive declarations. *) -val check_inductive : - env -> mutual_inductive -> mutual_inductive_entry -> mutual_inductive_body +val check_inductive : env -> mutual_inductive -> mutual_inductive_entry -> mutual_inductive_body + +(** The following enforces a system compatible with the univalent model *) + +val enforce_indices_matter : unit -> unit +val is_indices_matter : unit -> bool + +val compute_expansion : pinductive -> + Context.rel_context -> Context.rel_context -> (constr * constant array) diff --git a/kernel/inductive.ml b/kernel/inductive.ml index 2b2caaf3b..e57b0b4ad 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -19,6 +19,9 @@ open Environ open Reduction open Type_errors +type pinductive = inductive puniverses +type pconstructor = constructor puniverses + type mind_specif = mutual_inductive_body * one_inductive_body (* raise Not_found if not an inductive type *) @@ -38,31 +41,55 @@ let find_inductive env c = let (t, l) = decompose_app (whd_betadeltaiota env c) in match kind_of_term t with | Ind ind - when (fst (lookup_mind_specif env ind)).mind_finite -> (ind, l) + when (fst (lookup_mind_specif env (out_punivs ind))).mind_finite -> (ind, l) | _ -> raise Not_found let find_coinductive env c = let (t, l) = decompose_app (whd_betadeltaiota env c) in match kind_of_term t with | Ind ind - when not (fst (lookup_mind_specif env ind)).mind_finite -> (ind, l) + when not (fst (lookup_mind_specif env (out_punivs ind))).mind_finite -> (ind, l) | _ -> raise Not_found let inductive_params (mib,_) = mib.mind_nparams +let make_inductive_subst mib u = + if mib.mind_polymorphic then + make_universe_subst u mib.mind_universes + else Univ.empty_subst + +let inductive_params_ctxt (mib,u) = + let subst = make_inductive_subst mib u in + Vars.subst_univs_context subst mib.mind_params_ctxt + +let inductive_instance mib = + if mib.mind_polymorphic then + UContext.instance mib.mind_universes + else Instance.empty + +let inductive_context mib = + if mib.mind_polymorphic then + mib.mind_universes + else UContext.empty + +let instantiate_inductive_constraints mib subst = + if mib.mind_polymorphic then + instantiate_univ_context subst mib.mind_universes + else Constraint.empty + (************************************************************************) (* Build the substitution that replaces Rels by the appropriate *) (* inductives *) -let ind_subst mind mib = +let ind_subst mind mib u = let ntypes = mib.mind_ntypes in - let make_Ik k = mkInd (mind,ntypes-k-1) in + let make_Ik k = mkIndU ((mind,ntypes-k-1),u) in List.init ntypes make_Ik (* Instantiate inductives in constructor type *) -let constructor_instantiate mind mib c = - let s = ind_subst mind mib in - substl s c +let constructor_instantiate mind u subst mib c = + let s = ind_subst mind mib u in + substl s (subst_univs_constr subst c) let instantiate_params full t args sign = let fail () = @@ -81,13 +108,16 @@ let instantiate_params full t args sign = let () = if not (List.is_empty rem_args) then fail () in substl subs ty -let full_inductive_instantiate mib params sign = +let full_inductive_instantiate mib u params sign = let dummy = prop_sort in let t = mkArity (sign,dummy) in - fst (destArity (instantiate_params true t params mib.mind_params_ctxt)) + let subst = make_inductive_subst mib u in + let ar = fst (destArity (instantiate_params true t params mib.mind_params_ctxt)) in + Vars.subst_univs_context subst ar -let full_constructor_instantiate ((mind,_),(mib,_),params) = - let inst_ind = constructor_instantiate mind mib in +let full_constructor_instantiate ((mind,_),u,(mib,_),params) = + let subst = make_inductive_subst mib u in + let inst_ind = constructor_instantiate mind u subst mib in (fun t -> instantiate_params true (inst_ind t) params mib.mind_params_ctxt) @@ -119,122 +149,85 @@ Remark: Set (predicative) is encoded as Type(0) let sort_as_univ = function | Type u -> u -| Prop Null -> type0m_univ -| Prop Pos -> type0_univ +| Prop Null -> Universe.type0m +| Prop Pos -> Universe.type0 let cons_subst u su subst = try - (u, sup su (List.assoc_f Universe.equal u subst)) :: - List.remove_assoc_f Universe.equal u subst + (u, Universe.sup su (List.assoc_f Universe.eq u subst)) :: + List.remove_assoc_f Universe.eq u subst with Not_found -> (u, su) :: subst -let actualize_decl_level env lev t = - let sign,s = dest_arity env t in - mkArity (sign,lev) - -let polymorphism_on_non_applied_parameters = false - -(* Bind expected levels of parameters to actual levels *) -(* Propagate the new levels in the signature *) -let rec make_subst env = function - | (_,Some _,_ as t)::sign, exp, args -> - let ctx,subst = make_subst env (sign, exp, args) in - t::ctx, subst - | d::sign, None::exp, args -> - let args = match args with _::args -> args | [] -> [] in - let ctx,subst = make_subst env (sign, exp, args) in - d::ctx, subst - | d::sign, Some u::exp, a::args -> - (* We recover the level of the argument, but we don't change the *) - (* level in the corresponding type in the arity; this level in the *) - (* arity is a global level which, at typing time, will be enforce *) - (* to be greater than the level of the argument; this is probably *) - (* a useless extra constraint *) - let s = sort_as_univ (snd (dest_arity env (Lazy.force a))) in - let ctx,subst = make_subst env (sign, exp, args) in - d::ctx, cons_subst u s subst - | (na,None,t as d)::sign, Some u::exp, [] -> - (* No more argument here: we instantiate the type with a fresh level *) - (* which is first propagated to the corresponding premise in the arity *) - (* (actualize_decl_level), then to the conclusion of the arity (via *) - (* the substitution) *) - let ctx,subst = make_subst env (sign, exp, []) in - if polymorphism_on_non_applied_parameters then - let s = fresh_local_univ () in - let t = actualize_decl_level env (Type s) t in - (na,None,t)::ctx, cons_subst u s subst - else - d::ctx, subst - | sign, [], _ -> - (* Uniform parameters are exhausted *) - sign,[] - | [], _, _ -> - assert false - -let instantiate_universes env ctx ar argsorts = - let args = Array.to_list argsorts in - let ctx,subst = make_subst env (ctx,ar.poly_param_levels,args) in - let level = subst_large_constraints subst ar.poly_level in - ctx, - (* Singleton type not containing types are interpretable in Prop *) - if is_type0m_univ level then prop_sort - (* Non singleton type not containing types are interpretable in Set *) - else if is_type0_univ level then set_sort - (* This is a Type with constraints *) - else Type level - exception SingletonInductiveBecomesProp of Id.t -let type_of_inductive_knowing_parameters ?(polyprop=true) env mip paramtyps = - match mip.mind_arity with - | Monomorphic s -> - s.mind_user_arity - | Polymorphic ar -> - let ctx = List.rev mip.mind_arity_ctxt in - let ctx,s = instantiate_universes env ctx ar paramtyps in - (* The Ocaml extraction cannot handle (yet?) "Prop-polymorphism", i.e. - the situation where a non-Prop singleton inductive becomes Prop - when applied to Prop params *) - if not polyprop && not (is_type0m_univ ar.poly_level) && is_prop_sort s - then raise (SingletonInductiveBecomesProp mip.mind_typename); - mkArity (List.rev ctx,s) - -(* Type of a (non applied) inductive type *) - -let type_of_inductive env (_,mip) = - type_of_inductive_knowing_parameters env mip [||] +(* Type of an inductive type *) + +let type_of_inductive_gen env ((mib,mip),u) = + let subst = make_inductive_subst mib u in + (subst_univs_constr subst mip.mind_arity.mind_user_arity, subst) + +let type_of_inductive env pind = + fst (type_of_inductive_gen env pind) + +let constrained_type_of_inductive env ((mib,mip),u as pind) = + let ty, subst = type_of_inductive_gen env pind in + let cst = instantiate_inductive_constraints mib subst in + (ty, cst) + +let type_of_inductive_knowing_parameters env ?(polyprop=false) mip args = + type_of_inductive env mip (* The max of an array of universes *) let cumulate_constructor_univ u = function | Prop Null -> u - | Prop Pos -> sup type0_univ u - | Type u' -> sup u u' + | Prop Pos -> Universe.sup Universe.type0 u + | Type u' -> Universe.sup u u' let max_inductive_sort = - Array.fold_left cumulate_constructor_univ type0m_univ + Array.fold_left cumulate_constructor_univ Universe.type0m (************************************************************************) (* Type of a constructor *) -let type_of_constructor cstr (mib,mip) = +let type_of_constructor_subst cstr u subst (mib,mip) = let ind = inductive_of_constructor cstr in let specif = mip.mind_user_lc in let i = index_of_constructor cstr in let nconstr = Array.length mip.mind_consnames in if i > nconstr then error "Not enough constructors in the type."; - constructor_instantiate (fst ind) mib specif.(i-1) + let c = constructor_instantiate (fst ind) u subst mib specif.(i-1) in + c + +let type_of_constructor_gen (cstr,u) (mib,mip as mspec) = + let subst = make_inductive_subst mib u in + type_of_constructor_subst cstr u subst mspec, subst -let arities_of_specif kn (mib,mip) = +let type_of_constructor cstru mspec = + fst (type_of_constructor_gen cstru mspec) + +let type_of_constructor_in_ctx cstr (mib,mip as mspec) = + let u = UContext.instance mib.mind_universes in + let c = type_of_constructor_gen (cstr, u) mspec in + (fst c, mib.mind_universes) + +let constrained_type_of_constructor (cstr,u as cstru) (mib,mip as ind) = + let ty, subst = type_of_constructor_gen cstru ind in + let cst = instantiate_inductive_constraints mib subst in + (ty, cst) + +let arities_of_specif (kn,u) (mib,mip) = let specif = mip.mind_nf_lc in - Array.map (constructor_instantiate kn mib) specif + let subst = make_inductive_subst mib u in + Array.map (constructor_instantiate kn u subst mib) specif let arities_of_constructors ind specif = - arities_of_specif (fst ind) specif + arities_of_specif (fst (fst ind), snd ind) specif -let type_of_constructors ind (mib,mip) = +let type_of_constructors (ind,u) (mib,mip) = let specif = mip.mind_user_lc in - Array.map (constructor_instantiate (fst ind) mib) specif + let subst = make_inductive_subst mib u in + Array.map (constructor_instantiate (fst ind) u subst mib) specif (************************************************************************) @@ -255,16 +248,14 @@ let local_rels ctxt = (* Get type of inductive, with parameters instantiated *) let inductive_sort_family mip = - match mip.mind_arity with - | Monomorphic s -> family_of_sort s.mind_sort - | Polymorphic _ -> InType + family_of_sort mip.mind_arity.mind_sort let mind_arity mip = mip.mind_arity_ctxt, inductive_sort_family mip -let get_instantiated_arity (mib,mip) params = +let get_instantiated_arity (ind,u) (mib,mip) params = let sign, s = mind_arity mip in - full_inductive_instantiate mib params sign, s + full_inductive_instantiate mib u params sign, s let elim_sorts (_,mip) = mip.mind_kelim @@ -279,7 +270,7 @@ let extended_rel_list n hyps = let build_dependent_inductive ind (_,mip) params = let realargs,_ = List.chop mip.mind_nrealargs_ctxt mip.mind_arity_ctxt in applist - (mkInd ind, + (mkIndU ind, List.map (lift mip.mind_nrealargs_ctxt) params @ extended_rel_list 0 realargs) @@ -295,15 +286,15 @@ let check_allowed_sort ksort specif = raise (LocalArity (Some(ksort,s,error_elim_explain ksort s))) let is_correct_arity env c pj ind specif params = - let arsign,_ = get_instantiated_arity specif params in - let rec srec env pt ar u = + let arsign,_ = get_instantiated_arity ind specif params in + let rec srec env pt ar = let pt' = whd_betadeltaiota env pt in match kind_of_term pt', ar with | Prod (na1,a1,t), (_,None,a1')::ar' -> - let univ = + let () = try conv env a1 a1' with NotConvertible -> raise (LocalArity None) in - srec (push_rel (na1,None,a1) env) t ar' (union_constraints u univ) + srec (push_rel (na1,None,a1) env) t ar' (* The last Prod domain is the type of the scrutinee *) | Prod (na1,a1,a2), [] -> (* whnf of t was not needed here! *) let env' = push_rel (na1,None,a1) env in @@ -311,17 +302,16 @@ let is_correct_arity env c pj ind specif params = | Sort s -> family_of_sort s | _ -> raise (LocalArity None) in let dep_ind = build_dependent_inductive ind specif params in - let univ = + let _ = try conv env a1 dep_ind with NotConvertible -> raise (LocalArity None) in - check_allowed_sort ksort specif; - union_constraints u univ + check_allowed_sort ksort specif | _, (_,Some _,_ as d)::ar' -> - srec (push_rel d env) (lift 1 pt') ar' u + srec (push_rel d env) (lift 1 pt') ar' | _ -> raise (LocalArity None) in - try srec env pj.uj_type (List.rev arsign) empty_constraint + try srec env pj.uj_type (List.rev arsign) with LocalArity kinds -> error_elim_arity env ind (elim_sorts specif) c pj kinds @@ -331,16 +321,16 @@ let is_correct_arity env c pj ind specif params = (* [p] is the predicate, [i] is the constructor number (starting from 0), and [cty] is the type of the constructor (params not instantiated) *) -let build_branches_type ind (_,mip as specif) params p = +let build_branches_type (ind,u) (_,mip as specif) params p = let build_one_branch i cty = - let typi = full_constructor_instantiate (ind,specif,params) cty in + let typi = full_constructor_instantiate (ind,u,specif,params) cty in let (args,ccl) = decompose_prod_assum typi in let nargs = rel_context_length args in let (_,allargs) = decompose_app ccl in let (lparams,vargs) = List.chop (inductive_params specif) allargs in let cargs = let cstr = ith_constructor_of_inductive ind (i+1) in - let dep_cstr = applist (mkConstruct cstr,lparams@(local_rels args)) in + let dep_cstr = applist (mkConstructU (cstr,u),lparams@(local_rels args)) in vargs @ [dep_cstr] in let base = beta_appvect (lift nargs p) (Array.of_list cargs) in it_mkProd_or_LetIn base args in @@ -348,31 +338,31 @@ let build_branches_type ind (_,mip as specif) params p = (* [p] is the predicate, [c] is the match object, [realargs] is the list of real args of the inductive type *) -let build_case_type n p c realargs = - whd_betaiota (betazeta_appvect (n+1) p (Array.of_list (realargs@[c]))) +let build_case_type env n p c realargs = + whd_betaiota env (betazeta_appvect (n+1) p (Array.of_list (realargs@[c]))) -let type_case_branches env (ind,largs) pj c = - let specif = lookup_mind_specif env ind in +let type_case_branches env (pind,largs) pj c = + let specif = lookup_mind_specif env (fst pind) in let nparams = inductive_params specif in let (params,realargs) = List.chop nparams largs in let p = pj.uj_val in - let univ = is_correct_arity env c pj ind specif params in - let lc = build_branches_type ind specif params p in - let ty = build_case_type (snd specif).mind_nrealargs_ctxt p c realargs in - (lc, ty, univ) + let () = is_correct_arity env c pj pind specif params in + let lc = build_branches_type pind specif params p in + let ty = build_case_type env (snd specif).mind_nrealargs_ctxt p c realargs in + (lc, ty) (************************************************************************) (* Checking the case annotation is relevent *) -let check_case_info env indsp ci = +let check_case_info env (indsp,u) ci = let (mib,mip) = lookup_mind_specif env indsp in if not (eq_ind indsp ci.ci_ind) || not (Int.equal mib.mind_nparams ci.ci_npar) || not (Array.equal Int.equal mip.mind_consnrealdecls ci.ci_cstr_ndecls) || not (Array.equal Int.equal mip.mind_consnrealargs ci.ci_cstr_nargs) - then raise (TypeError(env,WrongCaseInfo(indsp,ci))) + then raise (TypeError(env,WrongCaseInfo((indsp,u),ci))) (************************************************************************) (************************************************************************) @@ -450,7 +440,7 @@ type guard_env = genv : subterm_spec Lazy.t list; } -let make_renv env recarg (kn,tyi) = +let make_renv env recarg ((kn,tyi),u) = let mib = Environ.lookup_mind kn env in let mind_recvec = Array.map (fun mip -> mip.mind_recargs) mib.mind_packets in @@ -552,7 +542,6 @@ let rec subterm_specif renv stack t = let f,l = decompose_app (whd_betadeltaiota renv.env t) in match kind_of_term f with | Rel k -> subterm_var k renv - | Case (ci,p,c,lbr) -> let stack' = push_stack_closures renv l stack in if not (check_inductive_codomain renv.env p) then Not_subterm @@ -581,7 +570,7 @@ let rec subterm_specif renv stack t = with Not_found -> None in (match oind with None -> Not_subterm (* happens if fix is polymorphic *) - | Some ind -> + | Some (ind, _) -> let nbfix = Array.length typarray in let recargs = lookup_subterms renv.env ind in (* pushing the fixpoints *) @@ -668,7 +657,7 @@ let check_one_fix renv recpos def = (* if [t] does not make recursive calls, it is guarded: *) if noccur_with_meta renv.rel_min nfi t then () else - let (f,l) = decompose_app (whd_betaiotazeta t) in + let (f,l) = decompose_app (whd_betaiotazeta renv.env t) in match kind_of_term f with | Rel p -> (* Test if [p] is a fixpoint (recursive call) *) @@ -739,11 +728,11 @@ let check_one_fix renv recpos def = else check_rec_call renv' [] body) bodies - | Const kn -> + | Const (kn,u as cu) -> if evaluable_constant kn renv.env then try List.iter (check_rec_call renv []) l with (FixGuardError _ ) -> - let value = (applist(constant_value renv.env kn, l)) in + let value = (applist(constant_value_in renv.env cu, l)) in check_rec_call renv stack value else List.iter (check_rec_call renv []) l @@ -785,6 +774,8 @@ let check_one_fix renv recpos def = | (Evar _ | Meta _) -> () | (App _ | LetIn _ | Cast _) -> assert false (* beta zeta reduction *) + + | Proj (p, c) -> check_rec_call renv [] c and check_nested_fix_body renv decr recArgsDecrArg body = if Int.equal decr 0 then @@ -888,7 +879,7 @@ let check_one_cofix env nbfix def deftype = else if not(List.for_all (noccur_with_meta n nbfix) args) then raise (CoFixGuardError (env,NestedRecursiveOccurrences)) - | Construct (_,i as cstr_kn) -> + | Construct ((_,i as cstr_kn),u) -> let lra = vlra.(i-1) in let mI = inductive_of_constructor cstr_kn in let (mib,mip) = lookup_mind_specif env mI in @@ -947,7 +938,7 @@ let check_one_cofix env nbfix def deftype = | _ -> raise (CoFixGuardError (env,NotGuardedForm t)) in - let (mind, _) = codomain_is_coind env deftype in + let ((mind, _),_) = codomain_is_coind env deftype in let vlra = lookup_subterms env mind in check_rec_call env false 1 (dest_subterms vlra) def diff --git a/kernel/inductive.mli b/kernel/inductive.mli index d9841085e..c4a7452f0 100644 --- a/kernel/inductive.mli +++ b/kernel/inductive.mli @@ -7,9 +7,9 @@ (************************************************************************) open Names -open Univ open Term open Context +open Univ open Declarations open Environ @@ -21,9 +21,9 @@ open Environ only a coinductive type. They raise [Not_found] if not convertible to a recursive type. *) -val find_rectype : env -> types -> inductive * constr list -val find_inductive : env -> types -> inductive * constr list -val find_coinductive : env -> types -> inductive * constr list +val find_rectype : env -> types -> pinductive * constr list +val find_inductive : env -> types -> pinductive * constr list +val find_coinductive : env -> types -> pinductive * constr list type mind_specif = mutual_inductive_body * one_inductive_body @@ -33,23 +33,38 @@ type mind_specif = mutual_inductive_body * one_inductive_body val lookup_mind_specif : env -> inductive -> mind_specif (** {6 Functions to build standard types related to inductive } *) -val ind_subst : mutual_inductive -> mutual_inductive_body -> constr list +val ind_subst : mutual_inductive -> mutual_inductive_body -> universe_instance -> constr list + +val make_inductive_subst : mutual_inductive_body -> universe_instance -> universe_subst + +val inductive_instance : mutual_inductive_body -> universe_instance +val inductive_context : mutual_inductive_body -> universe_context +val inductive_params_ctxt : mutual_inductive_body puniverses -> rel_context + +val instantiate_inductive_constraints : mutual_inductive_body -> universe_subst -> constraints -val type_of_inductive : env -> mind_specif -> types +val constrained_type_of_inductive : env -> mind_specif puniverses -> types constrained + +val type_of_inductive : env -> mind_specif puniverses -> types + +val type_of_inductive_knowing_parameters : env -> ?polyprop:bool -> mind_specif puniverses -> types Lazy.t array -> types val elim_sorts : mind_specif -> sorts_family list (** Return type as quoted by the user *) -val type_of_constructor : constructor -> mind_specif -> types + +val constrained_type_of_constructor : pconstructor -> mind_specif -> types constrained +val type_of_constructor : pconstructor -> mind_specif -> types +val type_of_constructor_in_ctx : constructor -> mind_specif -> types in_universe_context (** Return constructor types in normal form *) -val arities_of_constructors : inductive -> mind_specif -> types array +val arities_of_constructors : pinductive -> mind_specif -> types array (** Return constructor types in user form *) -val type_of_constructors : inductive -> mind_specif -> types array +val type_of_constructors : pinductive -> mind_specif -> types array (** Transforms inductive specification into types (in nf) *) -val arities_of_specif : mutual_inductive -> mind_specif -> types array +val arities_of_specif : mutual_inductive puniverses -> mind_specif -> types array val inductive_params : mind_specif -> int @@ -61,11 +76,11 @@ val inductive_params : mind_specif -> int the universe constraints generated. *) val type_case_branches : - env -> inductive * constr list -> unsafe_judgment -> constr - -> types array * types * constraints + env -> pinductive * constr list -> unsafe_judgment -> constr + -> types array * types val build_branches_type : - inductive -> mutual_inductive_body * one_inductive_body -> + pinductive -> mutual_inductive_body * one_inductive_body -> constr list -> constr -> types array (** Return the arity of an inductive type *) @@ -75,7 +90,7 @@ val inductive_sort_family : one_inductive_body -> sorts_family (** Check a [case_info] actually correspond to a Case expression on the given inductive type. *) -val check_case_info : env -> inductive -> case_info -> unit +val check_case_info : env -> pinductive -> case_info -> unit (** {6 Guard conditions for fix and cofix-points. } *) val check_fix : env -> fixpoint -> unit @@ -92,14 +107,8 @@ val check_cofix : env -> cofixpoint -> unit exception SingletonInductiveBecomesProp of Id.t -val type_of_inductive_knowing_parameters : ?polyprop:bool -> - env -> one_inductive_body -> types Lazy.t array -> types - val max_inductive_sort : sorts array -> universe -val instantiate_universes : env -> rel_context -> - polymorphic_arity -> types Lazy.t array -> rel_context * sorts - (** {6 Debug} *) type size = Large | Strict diff --git a/kernel/kernel.mllib b/kernel/kernel.mllib index 0d0adf9a7..29fe887d7 100644 --- a/kernel/kernel.mllib +++ b/kernel/kernel.mllib @@ -32,6 +32,7 @@ Type_errors Modops Inductive Typeops +Fast_typeops Indtypes Cooking Term_typing @@ -39,7 +40,6 @@ Subtyping Mod_typing Nativelibrary Safe_typing - Vm Csymtable Vconv diff --git a/kernel/mod_subst.ml b/kernel/mod_subst.ml index 9589c0656..cfe46152e 100644 --- a/kernel/mod_subst.ml +++ b/kernel/mod_subst.ml @@ -271,7 +271,7 @@ let progress f x ~orelse = let y = f x in if y != x then y else orelse -let subst_ind sub mind = +let subst_mind sub mind = let mpu,dir,l = MutInd.repr3 mind in let mpc = KerName.modpath (MutInd.canonical mind) in try @@ -284,7 +284,14 @@ let subst_ind sub mind = MutInd.make knu knc' with No_subst -> mind -let subst_con0 sub cst = +let subst_ind sub (ind,i as indi) = + let ind' = subst_mind sub ind in + if ind' == ind then indi else ind',i + +let subst_pind sub (ind,u) = + (subst_ind sub ind, u) + +let subst_con0 sub (cst,u) = let mpu,dir,l = Constant.repr3 cst in let mpc = KerName.modpath (Constant.canonical cst) in let mpu,mpc,resolve,user = subst_dual_mp sub mpu mpc in @@ -299,11 +306,28 @@ let subst_con0 sub cst = progress (kn_of_delta resolve) (if user then knu else knc) ~orelse:knc in let cst' = Constant.make knu knc' in - cst', mkConst cst' + cst', mkConstU (cst',u) let subst_con sub cst = try subst_con0 sub cst - with No_subst -> cst, mkConst cst + with No_subst -> fst cst, mkConstU cst + +let subst_con_kn sub con = + subst_con sub (con,Univ.Instance.empty) + +let subst_pcon sub (con,u as pcon) = + try let con', can = subst_con0 sub pcon in + con',u + with No_subst -> pcon + +let subst_pcon_term sub (con,u as pcon) = + try let con', can = subst_con0 sub pcon in + (con',u), can + with No_subst -> pcon, mkConstU pcon + +let subst_constant sub con = + try fst (subst_con0 sub (con,Univ.Instance.empty)) + with No_subst -> con (* Here the semantics is completely unclear. What does "Hint Unfold t" means when "t" is a parameter? @@ -312,18 +336,25 @@ let subst_con sub cst = interpretation (i.e. an evaluable reference is never expanded). *) let subst_evaluable_reference subst = function | EvalVarRef id -> EvalVarRef id - | EvalConstRef kn -> EvalConstRef (fst (subst_con subst kn)) + | EvalConstRef kn -> EvalConstRef (subst_constant subst kn) let rec map_kn f f' c = let func = map_kn f f' in match kind_of_term c with | Const kn -> (try snd (f' kn) with No_subst -> c) - | Ind (kn,i) -> + | Proj (kn,t) -> + let kn' = try fst (f' (kn,Univ.Instance.empty)) + with No_subst -> kn + in + let t' = func t in + if kn' == kn && t' == t then c + else mkProj (kn', t') + | Ind ((kn,i),u) -> let kn' = f kn in - if kn'==kn then c else mkInd (kn',i) - | Construct ((kn,i),j) -> + if kn'==kn then c else mkIndU ((kn',i),u) + | Construct (((kn,i),j),u) -> let kn' = f kn in - if kn'==kn then c else mkConstruct ((kn',i),j) + if kn'==kn then c else mkConstructU (((kn',i),j),u) | Case (ci,p,ct,l) -> let ci_ind = let (kn,i) = ci.ci_ind in @@ -382,7 +413,7 @@ let rec map_kn f f' c = let subst_mps sub c = if is_empty_subst sub then c - else map_kn (subst_ind sub) (subst_con0 sub) c + else map_kn (subst_mind sub) (subst_con0 sub) c let rec replace_mp_in_mp mpfrom mpto mp = match mp with diff --git a/kernel/mod_subst.mli b/kernel/mod_subst.mli index 34f10b31a..5a913a906 100644 --- a/kernel/mod_subst.mli +++ b/kernel/mod_subst.mli @@ -118,15 +118,32 @@ val debug_pr_delta : delta_resolver -> Pp.std_ppcmds val subst_mp : substitution -> module_path -> module_path -val subst_ind : +val subst_mind : substitution -> mutual_inductive -> mutual_inductive +val subst_ind : + substitution -> inductive -> inductive + +val subst_pind : substitution -> pinductive -> pinductive + val subst_kn : substitution -> kernel_name -> kernel_name val subst_con : + substitution -> pconstant -> constant * constr + +val subst_pcon : + substitution -> pconstant -> pconstant + +val subst_pcon_term : + substitution -> pconstant -> pconstant * constr + +val subst_con_kn : substitution -> constant -> constant * constr +val subst_constant : + substitution -> constant -> constant + (** Here the semantics is completely unclear. What does "Hint Unfold t" means when "t" is a parameter? Does the user mean "Unfold X.t" or does she mean "Unfold y" diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml index 6c0f1b060..b20fe9671 100644 --- a/kernel/mod_typing.ml +++ b/kernel/mod_typing.ml @@ -52,7 +52,7 @@ let rec rebuild_mp mp l = | []-> mp | i::r -> rebuild_mp (MPdot(mp,Label.of_id i)) r -let (+++) = Univ.union_constraints +let (+++) = Univ.Constraint.union let rec check_with_def env struc (idl,c) mp equiv = let lab,idl = match idl with @@ -72,24 +72,31 @@ let rec check_with_def env struc (idl,c) mp equiv = (* In the spirit of subtyping.check_constant, we accept any implementations of parameters and opaques terms, as long as they have the right type *) + let env' = Environ.add_constraints + (Univ.UContext.constraints (Future.force cb.const_universes)) env' in let c',cst = match cb.const_body with | Undef _ | OpaqueDef _ -> - let j,cst1 = Typeops.infer env' c in + let j = Typeops.infer env' c in let typ = Typeops.type_of_constant_type env' cb.const_type in - let cst2 = Reduction.conv_leq env' j.uj_type typ in - let cst = cb.const_constraints +++ cst1 +++ cst2 in - j.uj_val, cst + let cst = Reduction.infer_conv_leq env' (Environ.universes env') + j.uj_type typ in + j.uj_val,cst | Def cs -> - let cst1 = Reduction.conv env' c (Mod_subst.force_constr cs) in - let cst = cb.const_constraints +++ cst1 in - c, cst + let cst = Reduction.infer_conv env' (Environ.universes env') c + (Mod_subst.force_constr cs) in + let cst = + if cb.const_polymorphic then cst + else (*FIXME MS: computed above *) + (Univ.UContext.constraints (Future.force cb.const_universes)) +++ cst + in + c, cst in let def = Def (Mod_subst.from_val c') in let cb' = { cb with const_body = def; - const_body_code = Cemitcodes.from_val (compile_constant_body env' def); - const_constraints = cst } + const_body_code = Cemitcodes.from_val (compile_constant_body env' def) } + (* const_universes = Future.from_val cst } *) in before@(lab,SFBconst(cb'))::after, c', cst else @@ -185,7 +192,7 @@ let rec check_with_mod env struc (idl,mp1) mp equiv = | Algebraic (NoFunctor (MEident mp0)) -> let mpnew = rebuild_mp mp0 idl in check_modpath_equiv env' mpnew mp; - before@(lab,spec)::after, equiv, Univ.empty_constraint + before@(lab,spec)::after, equiv, Univ.Constraint.empty | _ -> error_generative_module_expected lab end with @@ -229,7 +236,7 @@ let rec translate_mse env mpo inl = function let mtb = lookup_modtype mp1 env in mtb.typ_expr, mtb.typ_delta in - sign,Some (MEident mp1),reso,Univ.empty_constraint + sign,Some (MEident mp1),reso,Univ.Constraint.empty |MEapply (fe,mp1) -> translate_apply env inl (translate_mse env mpo inl fe) mp1 (mk_alg_app mpo) |MEwith(me, with_decl) -> @@ -297,7 +304,7 @@ let finalize_module env mp (sign,alg,reso,cst) restype = match restype with typ_mp = mp; typ_expr = sign; typ_expr_alg = None; - typ_constraints = Univ.empty_constraint; + typ_constraints = Univ.Constraint.empty; typ_delta = reso } in let cst' = Subtyping.check_subtypes env auto_mtb res_mtb in let impl = match alg with Some e -> Algebraic e | None -> Struct sign in @@ -322,7 +329,7 @@ let rec translate_mse_incl env mp inl = function |MEident mp1 -> let mb = strengthen_and_subst_mb (lookup_module mp1 env) mp true in let sign = clean_bounded_mod_expr mb.mod_type in - sign,None,mb.mod_delta,Univ.empty_constraint + sign,None,mb.mod_delta,Univ.Constraint.empty |MEapply (fe,arg) -> let ftrans = translate_mse_incl env mp inl fe in translate_apply env inl ftrans arg (fun _ _ -> None) diff --git a/kernel/modops.ml b/kernel/modops.ml index 6d0e919f8..093ee7024 100644 --- a/kernel/modops.ml +++ b/kernel/modops.ml @@ -210,7 +210,7 @@ and subst_structure sub do_delta sign = let cb' = subst_const_body sub cb in if cb==cb' then orig else (l,SFBconst cb') |SFBmind mib -> - let mib' = subst_mind sub mib in + let mib' = subst_mind_body sub mib in if mib==mib' then orig else (l,SFBmind mib') |SFBmodule mb -> let mb' = subst_module sub do_delta mb in @@ -460,7 +460,7 @@ and strengthen_and_subst_struct str subst mp_from mp_to alias incl reso = because reso' contains mp_to maps to reso(mp_from) *) reso', item'::rest' | (l,SFBmind mib) :: rest -> - let item' = l,SFBmind (subst_mind subst mib) in + let item' = l,SFBmind (subst_mind_body subst mib) in let reso',rest' = strengthen_and_subst_struct rest subst mp_from mp_to alias incl reso in diff --git a/kernel/names.ml b/kernel/names.ml index ef0e812ed..c76d95937 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -309,6 +309,11 @@ module ModPath = struct let initial = MPfile DirPath.initial + let rec dp = function + | MPfile sl -> sl + | MPbound (_,_,dp) -> dp + | MPdot (mp,l) -> dp mp + module Self_Hashcons = struct type t = module_path type u = (DirPath.t -> DirPath.t) * (MBId.t -> MBId.t) * @@ -424,7 +429,6 @@ module KerName = struct let hcons = Hashcons.simple_hcons HashKN.generate (ModPath.hcons,DirPath.hcons,String.hcons) - end module KNmap = HMap.Make(KerName) @@ -567,6 +571,7 @@ let constr_modpath (ind,_) = ind_modpath ind let ith_mutual_inductive (mind, _) i = (mind, i) let ith_constructor_of_inductive ind i = (ind, i) +let ith_constructor_of_pinductive (ind,u) i = ((ind,i),u) let inductive_of_constructor (ind, i) = ind let index_of_constructor (ind, i) = i @@ -663,8 +668,7 @@ let hcons_mind = Hashcons.simple_hcons MutInd.HashKP.generate KerName.hcons let hcons_ind = Hashcons.simple_hcons Hind.generate hcons_mind let hcons_construct = Hashcons.simple_hcons Hconstruct.generate hcons_ind - -(*******) +(*****************) type transparent_state = Id.Pred.t * Cpred.t @@ -674,25 +678,26 @@ let var_full_transparent_state = (Id.Pred.full, Cpred.empty) let cst_full_transparent_state = (Id.Pred.empty, Cpred.full) type 'a tableKey = - | ConstKey of Constant.t + | ConstKey of 'a | VarKey of Id.t - | RelKey of 'a - + | RelKey of Int.t type inv_rel_key = int (* index in the [rel_context] part of environment starting by the end, {\em inverse} of de Bruijn indice *) -type id_key = inv_rel_key tableKey +type id_key = Constant.t tableKey -let eq_id_key ik1 ik2 = +let eq_table_key f ik1 ik2 = if ik1 == ik2 then true else match ik1,ik2 with - | ConstKey c1, ConstKey c2 -> Constant.UserOrd.equal c1 c2 + | ConstKey c1, ConstKey c2 -> f c1 c2 | VarKey id1, VarKey id2 -> Id.equal id1 id2 | RelKey k1, RelKey k2 -> Int.equal k1 k2 | _ -> false +let eq_id_key = eq_table_key Constant.UserOrd.equal + let eq_con_chk = Constant.UserOrd.equal let eq_mind_chk = MutInd.UserOrd.equal let eq_ind_chk (kn1,i1) (kn2,i2) = Int.equal i1 i2 && eq_mind_chk kn1 kn2 @@ -777,6 +782,7 @@ let kn_ord = KerName.compare (** Compatibility layer for [Constant] *) type constant = Constant.t +type projection = constant let constant_of_kn = Constant.make1 let constant_of_kn_equiv = Constant.make @@ -787,6 +793,7 @@ let user_con = Constant.user let con_label = Constant.label let con_modpath = Constant.modpath let eq_constant = Constant.equal +let eq_constant_key = Constant.UserOrd.equal let con_ord = Constant.CanOrd.compare let con_user_ord = Constant.UserOrd.compare let string_of_con = Constant.to_string diff --git a/kernel/names.mli b/kernel/names.mli index db973ed3a..49a838ae5 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -216,6 +216,8 @@ sig val initial : t (** Name of the toplevel structure ([= MPfile initial_dir]) *) + val dp : t -> DirPath.t + end module MPset : Set.S with type elt = ModPath.t @@ -440,10 +442,11 @@ val hcons_construct : constructor -> constructor (******) type 'a tableKey = - | ConstKey of Constant.t + | ConstKey of 'a | VarKey of Id.t - | RelKey of 'a + | RelKey of Int.t +(** Sets of names *) type transparent_state = Id.Pred.t * Cpred.t val empty_transparent_state : transparent_state @@ -455,8 +458,10 @@ type inv_rel_key = int (** index in the [rel_context] part of environment starting by the end, {e inverse} of de Bruijn indice *) -type id_key = inv_rel_key tableKey +type id_key = Constant.t tableKey +val eq_table_key : ('a -> 'a -> bool) -> 'a tableKey -> 'a tableKey -> bool +val eq_constant_key : Constant.t -> Constant.t -> bool val eq_id_key : id_key -> id_key -> bool (** equalities on constant and inductive names (for the checker) *) @@ -629,6 +634,8 @@ val kn_ord : kernel_name -> kernel_name -> int type constant = Constant.t (** @deprecated Alias type *) +type projection = constant + val constant_of_kn_equiv : KerName.t -> KerName.t -> constant (** @deprecated Same as [Constant.make] *) diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml index 1f6effba6..bd659a471 100644 --- a/kernel/nativecode.ml +++ b/kernel/nativecode.ml @@ -48,6 +48,7 @@ type gname = | 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 | Gfixtype of label option * int @@ -95,6 +96,7 @@ let gname_hash gn = match gn with | Ginternal s -> combinesmall 9 (String.hash s) | Grel i -> combinesmall 10 (Int.hash i) | Gnamed id -> combinesmall 11 (Id.hash id) +| Gproj (s, p) -> combinesmall 12 (combine (String.hash s) (Constant.hash p)) let case_ctr = ref (-1) @@ -253,6 +255,7 @@ type primitive = | Mk_cofix of int | Mk_rel of int | Mk_var of identifier + | Mk_proj | Is_accu | Is_int | Cast_accu @@ -298,6 +301,8 @@ let eq_primitive p1 p2 = | Force_cofix, Force_cofix -> true | Mk_meta, Mk_meta -> true | Mk_evar, Mk_evar -> true + | Mk_proj, Mk_proj -> true + | _ -> false let primitive_hash = function @@ -344,6 +349,7 @@ let primitive_hash = function | Coq_primitive (prim, None) -> combinesmall 36 (Primitives.hash prim) | Coq_primitive (prim, Some (prefix,kn)) -> combinesmall 37 (combine3 (String.hash prefix) (Constant.hash kn) (Primitives.hash prim)) + | Mk_proj -> 38 type mllambda = | MLlocal of lname @@ -1002,6 +1008,7 @@ let compile_prim decl cond paux = | Lapp(f,args) -> MLapp(ml_of_lam env l f, Array.map (ml_of_lam env l) args) | Lconst (prefix,c) -> MLglobal(Gconstant (prefix,c)) + | Lproj (prefix,c) -> MLglobal(Gproj (prefix,c)) | Lprim _ -> let decl,cond,paux = extract_prim (ml_of_lam env l) t in compile_prim decl cond paux @@ -1461,6 +1468,8 @@ let string_of_gname g = Format.sprintf "%sconstruct_%s_%i_%i" prefix (string_of_mind mind) i (j-1) | Gconstant (prefix, c) -> Format.sprintf "%sconst_%s" prefix (string_of_con c) + | Gproj (prefix, c) -> + Format.sprintf "%sproj_%s" prefix (string_of_con c) | Gcase (l,i) -> Format.sprintf "case_%s_%i" (string_of_label_def l) i | Gpred (l,i) -> @@ -1518,12 +1527,12 @@ let pp_mllam fmt l = | MLif(t,l1,l2) -> Format.fprintf fmt "@[(if %a then@\n %a@\nelse@\n %a)@]" pp_mllam t pp_mllam l1 pp_mllam l2 - | MLmatch (asw, c, accu_br, br) -> - let mind,i = asw.asw_ind in - let prefix = asw.asw_prefix in - let accu = Format.sprintf "%sAccu_%s_%i" prefix (string_of_mind mind) i in - Format.fprintf fmt - "@[begin match Obj.magic (%a) with@\n| %s _ ->@\n %a@\n%aend@]" + | MLmatch (annot, c, accu_br, br) -> + let mind,i = annot.asw_ind in + let prefix = annot.asw_prefix in + let accu = Format.sprintf "%sAccu_%s_%i" prefix (string_of_mind mind) i in + Format.fprintf fmt + "@[begin match Obj.magic (%a) with@\n| %s _ ->@\n %a@\n%aend@]" pp_mllam c accu pp_mllam accu_br (pp_branches prefix) br | MLconstruct(prefix,c,args) -> @@ -1626,6 +1635,7 @@ let pp_mllam fmt l = | Mk_rel i -> Format.fprintf fmt "mk_rel_accu %i" i | Mk_var id -> Format.fprintf fmt "mk_var_accu (Names.id_of_string \"%s\")" (string_of_id id) + | Mk_proj -> Format.fprintf fmt "mk_proj_accu" | Is_accu -> Format.fprintf fmt "is_accu" | Is_int -> Format.fprintf fmt "is_int" | Cast_accu -> Format.fprintf fmt "cast_accu" @@ -1758,9 +1768,11 @@ and compile_named env sigma auxdefs id = | None -> Glet(Gnamed id, MLprimitive (Mk_var id))::auxdefs -let compile_constant env sigma prefix ~interactive con body = - match body with - | Def t -> +let compile_constant env sigma prefix ~interactive con cb = + match cb.const_proj with + | None -> + begin match cb.const_body with + | Def t -> let t = Mod_subst.force_constr t in let code = lambda_of_constr env sigma t in if !Flags.debug then Pp.msg_debug (Pp.str "Generated lambda code"); @@ -1778,11 +1790,42 @@ let compile_constant env sigma prefix ~interactive con body = in if !Flags.debug then Pp.msg_debug (Pp.str "Optimized mllambda code"); code, name - | _ -> + | _ -> + let i = push_symbol (SymbConst con) in + [Glet(Gconstant ("",con), MLapp (MLprimitive Mk_const, [|get_const_code i|]))], + if interactive then LinkedInteractive prefix + else Linked prefix + end + | Some pb -> + let mind = pb.proj_ind in + let ind = (mind,0) in + let mib = lookup_mind mind env in + let oib = mib.mind_packets.(0) in + let tbl = oib.mind_reloc_tbl in + (* Building info *) + let prefix = get_mind_prefix env mind in + let ci = { ci_ind = ind; ci_npar = mib.mind_nparams; + ci_cstr_nargs = [|0|]; + ci_cstr_ndecls = [||] (*FIXME*); + ci_pp_info = { ind_nargs = 0; style = RegularStyle } } in + let asw = { asw_ind = ind; asw_prefix = prefix; asw_ci = ci; + asw_reloc = tbl; asw_finite = true } in + let c_uid = fresh_lname Anonymous in + let _, arity = tbl.(0) in + let ci_uid = fresh_lname Anonymous in + let cargs = Array.init arity + (fun i -> if Int.equal i pb.proj_arg then Some ci_uid else None) + in let i = push_symbol (SymbConst con) in - [Glet(Gconstant ("",con), MLapp (MLprimitive Mk_const, [|get_const_code i|]))], - if interactive then LinkedInteractive prefix - else Linked prefix + let accu = MLapp (MLprimitive Cast_accu, [|MLlocal c_uid|]) in + let accu_br = MLapp (MLprimitive Mk_proj, [|get_const_code i;accu|]) in + let code = MLmatch(asw,MLlocal c_uid,accu_br,[|[((ind,1),cargs)],MLlocal ci_uid|]) in + 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), mkMLlam fargs (MLapp (MLglobal gn, [|MLlocal + arg|]))):: + [Glet(gn, mkMLlam [|c_uid|] code)], Linked prefix let loaded_native_files = ref ([] : string list) @@ -1858,8 +1901,8 @@ let compile_mind_deps env prefix ~interactive reverse order, as well as linking information updates *) let rec compile_deps env sigma prefix ~interactive init t = match kind_of_term t with - | Ind (mind,_) -> compile_mind_deps env prefix ~interactive init mind - | Const c -> + | Ind ((mind,_),u) -> compile_mind_deps env prefix ~interactive init mind + | Const (c,u) -> let c = get_allias env c in let cb,(nameref,_) = lookup_constant_key c env in let (_, (_, const_updates)) = init in @@ -1873,12 +1916,14 @@ let rec compile_deps env sigma prefix ~interactive init t = | _ -> init in let code, name = - compile_constant env sigma prefix ~interactive c cb.const_body + compile_constant env sigma prefix ~interactive c cb in let comp_stack = code@comp_stack in let const_updates = Cmap_env.add c (nameref, name) const_updates in comp_stack, (mind_updates, const_updates) - | Construct ((mind,_),_) -> compile_mind_deps env prefix ~interactive init mind + | Construct (((mind,_),_),u) -> compile_mind_deps env prefix ~interactive init mind + | Proj (p,c) -> + compile_deps env sigma prefix ~interactive init (mkApp (mkConst p, [|c|])) | Case (ci, p, c, ac) -> let mind = fst ci.ci_ind in let init = compile_mind_deps env prefix ~interactive init mind in @@ -1888,7 +1933,7 @@ let rec compile_deps env sigma prefix ~interactive init t = let compile_constant_field env prefix con acc cb = let (gl, _) = compile_constant ~interactive:false env empty_evars prefix - con cb.const_body + con cb in gl@acc diff --git a/kernel/nativeconv.ml b/kernel/nativeconv.ml index 82786df64..766e6513c 100644 --- a/kernel/nativeconv.ml +++ b/kernel/nativeconv.ml @@ -70,7 +70,7 @@ and conv_atom pb lvl a1 a2 cu = if not (eq_constant c1 c2) then raise NotConvertible; cu | Asort s1, Asort s2 -> - sort_cmp pb s1 s2 cu + ignore(sort_cmp_universes pb s1 s2 (cu, None)); cu | Avar id1, Avar id2 -> if not (Id.equal id1 id2) then raise NotConvertible; cu @@ -131,9 +131,9 @@ let native_conv pb sigma env t1 t2 = vm_conv pb env t1 t2 end else - let env = Environ.pre_env env in + let penv = Environ.pre_env env in let ml_filename, prefix = get_ml_filename () in - let code, upds = mk_conv_code env sigma prefix t1 t2 in + let code, upds = mk_conv_code penv sigma prefix t1 t2 in match compile ml_filename code with | (0,fn) -> begin @@ -144,7 +144,7 @@ let native_conv pb sigma env t1 t2 = let time_info = Format.sprintf "Evaluation done in %.5f@." (t1 -. t0) in if !Flags.debug then Pp.msg_debug (Pp.str time_info); (* TODO change 0 when we can have deBruijn *) - conv_val pb 0 !rt1 !rt2 empty_constraint + ignore(conv_val pb 0 !rt1 !rt2 (Environ.universes env)) end | _ -> anomaly (Pp.str "Compilation failure") diff --git a/kernel/nativeinstr.mli b/kernel/nativeinstr.mli index 13d61841f..7d1bf0d19 100644 --- a/kernel/nativeinstr.mli +++ b/kernel/nativeinstr.mli @@ -29,6 +29,7 @@ and lambda = | Llet of name * lambda * lambda | Lapp of lambda * lambda array | Lconst of prefix * constant + | Lproj of prefix * constant (* prefix, projection name *) | Lprim of prefix * constant * Primitives.t * lambda array | Lcase of annot_sw * lambda * lambda * lam_branches (* annotations, term being matched, accu, branches *) diff --git a/kernel/nativelambda.ml b/kernel/nativelambda.ml index 8ea28ddff..16ca444e3 100644 --- a/kernel/nativelambda.ml +++ b/kernel/nativelambda.ml @@ -79,12 +79,12 @@ let get_const_prefix env c = | NotLinked -> "" | Linked s -> s | LinkedInteractive s -> s - + (* A generic map function *) let map_lam_with_binders g f n lam = match lam with - | Lrel _ | Lvar _ | Lconst _ | Luint _ | Lval _ | Lsort _ | Lind _ + | Lrel _ | Lvar _ | Lconst _ | Lproj _ | Luint _ | Lval _ | Lsort _ | Lind _ | Lconstruct _ | Llazy | Lforce | Lmeta _ | Levar _ -> lam | Lprod(dom,codom) -> let dom' = f n dom in @@ -183,7 +183,7 @@ let lam_subst_args subst args = let can_subst lam = match lam with - | Lrel _ | Lvar _ | Lconst _ | Lval _ | Lsort _ | Lind _ | Llam _ + | Lrel _ | Lvar _ | Lconst _ | Lproj _ | Lval _ | Lsort _ | Lind _ | Llam _ | Lconstruct _ | Lmeta _ | Levar _ -> true | _ -> false @@ -257,6 +257,7 @@ and simplify_app substf f substa args = let args = Array.append (lam_subst_args substf args') (lam_subst_args substa args) in simplify_app substf f subst_id args + (* TODO | Lproj -> simplify if the argument is known or a known global *) | _ -> mkLapp (simplify substf f) (simplify_args substa args) and simplify_args subst args = Array.smartmap (simplify subst) args @@ -290,7 +291,7 @@ let rec occurence k kind lam = if Int.equal n k then if kind then false else raise Not_found else kind - | Lvar _ | Lconst _ | Luint _ | Lval _ | Lsort _ | Lind _ + | Lvar _ | Lconst _ | Lproj _ | Luint _ | Lval _ | Lsort _ | Lind _ | Lconstruct _ | Llazy | Lforce | Lmeta _ | Levar _ -> kind | Lprod(dom, codom) -> occurence k (occurence k kind dom) codom @@ -504,7 +505,7 @@ let is_lazy prefix t = match kind_of_term t with | App (f,args) -> begin match kind_of_term f with - | Construct c -> + | Construct (c,_) -> let entry = mkInd (fst c) in (try let _ = @@ -552,7 +553,7 @@ let rec lambda_of_constr env sigma c = | Sort s -> Lsort s - | Ind ind -> + | Ind (ind,u) -> let prefix = get_mind_prefix !global_env (fst ind) in Lind (prefix, ind) @@ -584,6 +585,9 @@ let rec lambda_of_constr env sigma c = | Construct _ -> lambda_of_app env sigma c empty_args + | Proj (p, c) -> + mkLapp (Lproj (get_const_prefix !global_env p, p)) [|lambda_of_constr env sigma c|] + | Case(ci,t,a,branches) -> let (mind,i as ind) = ci.ci_ind in let mib = lookup_mind mind !global_env in @@ -642,7 +646,7 @@ let rec lambda_of_constr env sigma c = and lambda_of_app env sigma f args = match kind_of_term f with - | Const kn -> + | Const (kn,u) -> let kn = get_allias !global_env kn in let cb = lookup_constant kn !global_env in (try @@ -654,7 +658,7 @@ and lambda_of_app env sigma f args = f args with Not_found -> begin match cb.const_body with - | Def csubst -> + | Def csubst -> (* TODO optimize if f is a proj and argument is known *) if cb.const_inline_code then lambda_of_app env sigma (Mod_subst.force_constr csubst) args else @@ -669,7 +673,7 @@ and lambda_of_app env sigma f args = let prefix = get_const_prefix !global_env kn in mkLapp (Lconst (prefix, kn)) (lambda_of_args env sigma 0 args) end) - | Construct c -> + | Construct (c,u) -> let tag, nparams, arity = Renv.get_construct_info env c in let expected = nparams + arity in let nargs = Array.length args in @@ -737,7 +741,7 @@ let compile_static_int31 fc args = Luint (UintVal (Uint31.of_int (Array.fold_left (fun temp_i -> fun t -> match kind_of_term t with - | Construct (_,d) -> 2*temp_i+d-1 + | Construct ((_,d),_) -> 2*temp_i+d-1 | _ -> raise NotClosed) 0 args))) diff --git a/kernel/nativelambda.mli b/kernel/nativelambda.mli index a2763626c..33a0dacf6 100644 --- a/kernel/nativelambda.mli +++ b/kernel/nativelambda.mli @@ -12,7 +12,6 @@ open Nativevalues open Nativeinstr (** This file defines the lambda code generation phase of the native compiler *) - type evars = { evars_val : existential -> constr option; evars_typ : existential -> types; @@ -26,6 +25,8 @@ val decompose_Llam_Llet : lambda -> (Names.name * lambda option) array * lambda val is_lazy : prefix -> constr -> bool val mk_lazy : lambda -> lambda +val get_mind_prefix : env -> mutual_inductive -> string + val get_allias : env -> constant -> constant val lambda_of_constr : env -> evars -> Constr.constr -> lambda diff --git a/kernel/nativevalues.ml b/kernel/nativevalues.ml index 043f06e26..d88d5d25d 100644 --- a/kernel/nativevalues.ml +++ b/kernel/nativevalues.ml @@ -60,6 +60,7 @@ type atom = | Aprod of name * t * (t -> t) | Ameta of metavariable * t | Aevar of existential * t + | Aproj of constant * accumulator let accumulate_tag = 0 @@ -128,6 +129,9 @@ let mk_meta_accu mv ty = let mk_evar_accu ev ty = mk_accu (Aevar (ev,ty)) +let mk_proj_accu kn c = + mk_accu (Aproj (kn,c)) + let atom_of_accu (k:accumulator) = (Obj.magic (Obj.field (Obj.magic k) 2) : atom) diff --git a/kernel/nativevalues.mli b/kernel/nativevalues.mli index 4fbf493cc..32079c8d0 100644 --- a/kernel/nativevalues.mli +++ b/kernel/nativevalues.mli @@ -52,6 +52,7 @@ type atom = | Aprod of name * t * (t -> t) | Ameta of metavariable * t | Aevar of existential * t + | Aproj of constant * accumulator (* Constructors *) @@ -68,6 +69,7 @@ val mk_fix_accu : rec_pos -> int -> t array -> t array -> t val mk_cofix_accu : int -> t array -> t array -> t val mk_meta_accu : metavariable -> t val mk_evar_accu : existential -> t -> t +val mk_proj_accu : constant -> accumulator -> t val upd_cofix : t -> t -> unit val force_cofix : t -> t val mk_const : tag -> t diff --git a/kernel/opaqueproof.ml b/kernel/opaqueproof.ml index 102dcf99f..673b12b2c 100644 --- a/kernel/opaqueproof.ml +++ b/kernel/opaqueproof.ml @@ -7,11 +7,16 @@ (************************************************************************) open Names +open Univ open Term open Mod_subst -type work_list = Id.t array Cmap.t * Id.t array Mindmap.t -type cooking_info = { modlist : work_list; abstract : Context.named_context } +type work_list = (Instance.t * Id.t array) Cmap.t * + (Instance.t * Id.t array) Mindmap.t + +type cooking_info = { + modlist : work_list; + abstract : Context.named_context in_universe_context } type proofterm = (constr * Univ.constraints) Future.computation type opaque = | Indirect of substitution list * DirPath.t * int (* subst, lib, index *) @@ -94,7 +99,7 @@ let force_constraints = function | NoIndirect(_,cu) -> snd(Future.force cu) | Indirect (_,dp,i) -> match !get_univ dp i with - | None -> Univ.empty_constraint + | None -> Univ.Constraint.empty | Some u -> Future.force u let get_constraints = function diff --git a/kernel/opaqueproof.mli b/kernel/opaqueproof.mli index 957889aa9..71f491754 100644 --- a/kernel/opaqueproof.mli +++ b/kernel/opaqueproof.mli @@ -38,8 +38,12 @@ val get_constraints : opaque -> Univ.constraints Future.computation option val subst_opaque : substitution -> opaque -> opaque val iter_direct_opaque : (constr -> unit) -> opaque -> opaque -type work_list = Id.t array Cmap.t * Id.t array Mindmap.t -type cooking_info = { modlist : work_list; abstract : Context.named_context } +type work_list = (Univ.Instance.t * Id.t array) Cmap.t * + (Univ.Instance.t * Id.t array) Mindmap.t + +type cooking_info = { + modlist : work_list; + abstract : Context.named_context Univ.in_universe_context } (* The type has two caveats: 1) cook_constr is defined after diff --git a/kernel/pre_env.ml b/kernel/pre_env.ml index b655887d7..ba9f30233 100644 --- a/kernel/pre_env.ml +++ b/kernel/pre_env.ml @@ -124,7 +124,7 @@ let env_of_rel n env = let push_named_context_val d (ctxt,vals) = let id,_,_ = d in let rval = ref VKnone in - Context.add_named_decl d ctxt, (id,rval)::vals + add_named_decl d ctxt, (id,rval)::vals let push_named d env = (* if not (env.env_rel_context = []) then raise (ASSERT env.env_rel_context); diff --git a/kernel/pre_env.mli b/kernel/pre_env.mli index 964d709cf..74a5fb1ae 100644 --- a/kernel/pre_env.mli +++ b/kernel/pre_env.mli @@ -7,10 +7,10 @@ (************************************************************************) open Names -open Univ open Term open Context open Declarations +open Univ (** The type of environments. *) diff --git a/kernel/reduction.ml b/kernel/reduction.ml index 5397e42f9..63bd40681 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -26,11 +26,11 @@ open Environ open Closure open Esubst -let unfold_reference ((ids, csts), infos) k = +let conv_key k = match k with - | VarKey id when not (Id.Pred.mem id ids) -> None - | ConstKey cst when not (Cpred.mem cst csts) -> None - | _ -> unfold_reference infos k + | VarKey id -> VarKey id + | ConstKey (cst,_) -> ConstKey cst + | RelKey n -> RelKey n let rec is_empty_stack = function [] -> true @@ -58,6 +58,8 @@ let compare_stack_shape stk1 stk2 = | (_, (Zupdate _|Zshift _)::s2) -> compare_rec bal stk1 s2 | (Zapp l1::s1, _) -> compare_rec (bal+Array.length l1) s1 stk2 | (_, Zapp l2::s2) -> compare_rec (bal-Array.length l2) stk1 s2 + | (Zproj (n1,m1,p1)::s1, Zproj (n2,m2,p2)::s2) -> + Int.equal bal 0 && compare_rec 0 s1 s2 | (Zcase(c1,_,_)::s1, Zcase(c2,_,_)::s2) -> Int.equal bal 0 (* && c1.ci_ind = c2.ci_ind *) && compare_rec 0 s1 s2 | (Zfix(_,a1)::s1, Zfix(_,a2)::s2) -> @@ -67,6 +69,7 @@ let compare_stack_shape stk1 stk2 = type lft_constr_stack_elt = Zlapp of (lift * fconstr) array + | Zlproj of constant * lift | Zlfix of (lift * fconstr) * lft_constr_stack | Zlcase of case_info * lift * fconstr * fconstr array and lft_constr_stack = lft_constr_stack_elt list @@ -85,6 +88,8 @@ let pure_stack lfts stk = | (Zshift n,(l,pstk)) -> (el_shft n l, pstk) | (Zapp a, (l,pstk)) -> (l,zlapp (Array.map (fun t -> (l,t)) a) pstk) + | (Zproj (n,m,c), (l,pstk)) -> + (l, Zlproj (c,l)::pstk) | (Zfix(fx,a),(l,pstk)) -> let (lfx,pa) = pure_rec l a in (l, Zlfix((lfx,fx),pa)::pstk) @@ -96,17 +101,17 @@ let pure_stack lfts stk = (* Reduction Functions *) (****************************************************************************) -let whd_betaiota t = - whd_val (create_clos_infos betaiota empty_env) (inject t) +let whd_betaiota env t = + whd_val (create_clos_infos betaiota env) (inject t) -let nf_betaiota t = - norm_val (create_clos_infos betaiota empty_env) (inject t) +let nf_betaiota env t = + norm_val (create_clos_infos betaiota env) (inject t) -let whd_betaiotazeta x = +let whd_betaiotazeta env x = match kind_of_term x with | (Sort _|Var _|Meta _|Evar _|Const _|Ind _|Construct _| Prod _|Lambda _|Fix _|CoFix _) -> x - | _ -> whd_val (create_clos_infos betaiotazeta empty_env) (inject x) + | _ -> whd_val (create_clos_infos betaiotazeta env) (inject x) let whd_betadeltaiota env t = match kind_of_term t with @@ -143,12 +148,31 @@ let betazeta_appvect n c v = (********************************************************************) (* Conversion utility functions *) -type 'a conversion_function = env -> 'a -> 'a -> Univ.constraints -type 'a trans_conversion_function = transparent_state -> env -> 'a -> 'a -> Univ.constraints +type 'a conversion_function = env -> 'a -> 'a -> unit +type 'a trans_conversion_function = Names.transparent_state -> 'a conversion_function +type 'a universe_conversion_function = env -> Univ.universes -> 'a -> 'a -> unit +type 'a trans_universe_conversion_function = + Names.transparent_state -> 'a universe_conversion_function +type 'a infer_conversion_function = env -> Univ.universes -> 'a -> 'a -> Univ.constraints + +type conv_universes = Univ.universes * Univ.constraints option exception NotConvertible exception NotConvertibleVect of int +let convert_universes (univs,cstrs as cuniv) u u' = + if Univ.Instance.check_eq univs u u' then cuniv + else + (match cstrs with + | None -> raise NotConvertible + | Some cstrs -> (univs, Some (Univ.enforce_eq_instances u u' cstrs))) + +let conv_table_key k1 k2 cuniv = + match k1, k2 with + | ConstKey (cst, u), ConstKey (cst', u') when eq_constant_key cst cst' -> + convert_universes cuniv u u' + | _ -> raise NotConvertible + let compare_stacks f fmind lft1 stk1 lft2 stk2 cuniv = let rec cmp_rec pstk1 pstk2 cuniv = match (pstk1,pstk2) with @@ -156,6 +180,10 @@ let compare_stacks f fmind lft1 stk1 lft2 stk2 cuniv = let cu1 = cmp_rec s1 s2 cuniv in (match (z1,z2) with | (Zlapp a1,Zlapp a2) -> Array.fold_right2 f a1 a2 cu1 + | (Zlproj (c1,l1),Zlproj (c2,l2)) -> + if not (eq_constant c1 c2) then + raise NotConvertible + else cu1 | (Zlfix(fx1,a1),Zlfix(fx2,a2)) -> let cu2 = f fx1 fx2 cu1 in cmp_rec a1 a2 cu2 @@ -184,34 +212,64 @@ type conv_pb = | CUMUL let is_cumul = function CUMUL -> true | CONV -> false - -let sort_cmp pb s0 s1 cuniv = +let is_pos = function Pos -> true | Null -> false + +(* let sort_cmp env pb s0 s1 cuniv = *) +(* match (s0,s1) with *) +(* | (Prop c1, Prop c2) when is_cumul pb -> *) +(* begin match c1, c2 with *) +(* | Null, _ | _, Pos -> cuniv (\* Prop <= Set *\) *) +(* | _ -> raise NotConvertible *) +(* end *) +(* | (Prop c1, Prop c2) -> *) +(* if c1 == c2 then cuniv else raise NotConvertible *) +(* | (Prop c1, Type u) when is_cumul pb -> *) +(* enforce_leq (if is_pos c1 then Universe.type0 else Universe.type0m) u cuniv *) +(* | (Type u, Prop c) when is_cumul pb -> *) +(* enforce_leq u (if is_pos c then Universe.type0 else Universe.type0m) cuniv *) +(* | (Type u1, Type u2) -> *) +(* (match pb with *) +(* | CONV -> Univ.enforce_eq u1 u2 cuniv *) +(* | CUMUL -> enforce_leq u1 u2 cuniv) *) +(* | (_, _) -> raise NotConvertible *) + +(* let conv_sort env s0 s1 = sort_cmp CONV s0 s1 Constraint.empty *) +(* let conv_sort_leq env s0 s1 = sort_cmp CUMUL s0 s1 Constraint.empty *) + +let check_eq (univs, cstrs as cuniv) u u' = + match cstrs with + | None -> if check_eq univs u u' then cuniv else raise NotConvertible + | Some cstrs -> univs, Some (Univ.enforce_eq u u' cstrs) + +let check_leq (univs, cstrs as cuniv) u u' = + match cstrs with + | None -> if check_leq univs u u' then cuniv else raise NotConvertible + | Some cstrs -> univs, Some (Univ.enforce_leq u u' cstrs) + +let sort_cmp_universes pb s0 s1 univs = + let dir = if is_cumul pb then check_leq univs else check_eq univs in match (s0,s1) with | (Prop c1, Prop c2) when is_cumul pb -> begin match c1, c2 with - | Null, _ | _, Pos -> cuniv (* Prop <= Set *) + | Null, _ | _, Pos -> univs (* Prop <= Set *) | _ -> raise NotConvertible end - | (Prop c1, Prop c2) -> - if c1 == c2 then cuniv else raise NotConvertible - | (Prop c1, Type u) when is_cumul pb -> assert (is_univ_variable u); cuniv - | (Type u1, Type u2) -> - assert (is_univ_variable u2); - (match pb with - | CONV -> enforce_eq u1 u2 cuniv - | CUMUL -> enforce_leq u1 u2 cuniv) - | (_, _) -> raise NotConvertible + | (Prop c1, Prop c2) -> if c1 == c2 then univs else raise NotConvertible + | (Prop c1, Type u) -> dir (univ_of_sort s0) u + | (Type u, Prop c) -> dir u (univ_of_sort s1) + | (Type u1, Type u2) -> dir u1 u2 +(* let sort_cmp _ _ _ cuniv = cuniv *) -let conv_sort env s0 s1 = sort_cmp CONV s0 s1 empty_constraint - -let conv_sort_leq env s0 s1 = sort_cmp CUMUL s0 s1 empty_constraint +(* let conv_sort env s0 s1 = sort_cmp CONV s0 s1 empty_constraint *) +(* let conv_sort_leq env s0 s1 = sort_cmp CUMUL s0 s1 empty_constraint *) let rec no_arg_available = function | [] -> true | Zupdate _ :: stk -> no_arg_available stk | Zshift _ :: stk -> no_arg_available stk | Zapp v :: stk -> Int.equal (Array.length v) 0 && no_arg_available stk + | Zproj _ :: _ -> true | Zcase _ :: _ -> true | Zfix _ :: _ -> true @@ -223,6 +281,7 @@ let rec no_nth_arg_available n = function let k = Array.length v in if n >= k then no_nth_arg_available (n-k) stk else false + | Zproj _ :: _ -> true | Zcase _ :: _ -> true | Zfix _ :: _ -> true @@ -231,6 +290,7 @@ let rec no_case_available = function | Zupdate _ :: stk -> no_case_available stk | Zshift _ :: stk -> no_case_available stk | Zapp _ :: stk -> no_case_available stk + | Zproj (_,_,p) :: _ -> false | Zcase _ :: _ -> false | Zfix _ :: _ -> true @@ -241,7 +301,7 @@ let in_whnf (t,stk) = | FConstruct _ -> no_case_available stk | FCoFix _ -> no_case_available stk | FFix(((ri,n),(_,_,_)),_) -> no_nth_arg_available ri.(n) stk - | (FFlex _ | FProd _ | FEvar _ | FInd _ | FAtom _ | FRel _) -> true + | (FFlex _ | FProd _ | FEvar _ | FInd _ | FAtom _ | FRel _ | FProj _) -> true | FLOCKED -> assert false let steps = ref 0 @@ -253,6 +313,15 @@ let slave_process = | _ -> f := (fun () -> false); !f ()) in fun () -> !f () +let unfold_projection infos p c = + if RedFlags.red_set infos.i_flags (RedFlags.fCONST p) then + (match try Some (lookup_projection p (info_env infos)) with Not_found -> None with + | Some pb -> + let s = Zproj (pb.Declarations.proj_npars, pb.Declarations.proj_arg, p) in + Some (c, s) + | None -> None) + else None + (* Conversion between [lft1]term1 and [lft2]term2 *) let rec ccnv cv_pb l2r infos lft1 lft2 term1 term2 cuniv = eqappr cv_pb l2r infos (lft1, (term1,[])) (lft2, (term2,[])) cuniv @@ -266,9 +335,10 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = steps := 0; end; (* First head reduce both terms *) + let whd = whd_stack (infos_with_reds infos betaiotazeta) in let rec whd_both (t1,stk1) (t2,stk2) = - let st1' = whd_stack (snd infos) t1 stk1 in - let st2' = whd_stack (snd infos) t2 stk2 in + let st1' = whd t1 stk1 in + let st2' = whd t2 stk2 in (* Now, whd_stack on term2 might have modified st1 (due to sharing), and st1 might not be in whnf anymore. If so, we iterate ccnv. *) if in_whnf st1' then (st1',st2') else whd_both st1' st2' in @@ -284,7 +354,7 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = | (Sort s1, Sort s2) -> if not (is_empty_stack v1 && is_empty_stack v2) then anomaly (Pp.str "conversion was given ill-typed terms (Sort)"); - sort_cmp cv_pb s1 s2 cuniv + sort_cmp_universes cv_pb s1 s2 cuniv | (Meta n, Meta m) -> if Int.equal n m then convert_stacks l2r infos lft1 lft2 v1 v2 cuniv @@ -292,10 +362,10 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = | _ -> raise NotConvertible) | (FEvar ((ev1,args1),env1), FEvar ((ev2,args2),env2)) -> if Evar.equal ev1 ev2 then - let u1 = convert_stacks l2r infos lft1 lft2 v1 v2 cuniv in + let cuniv = convert_stacks l2r infos lft1 lft2 v1 v2 cuniv in convert_vect l2r infos el1 el2 (Array.map (mk_clos env1) args1) - (Array.map (mk_clos env2) args2) u1 + (Array.map (mk_clos env2) args2) cuniv else raise NotConvertible (* 2 index known to be bound to no constant *) @@ -307,28 +377,59 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = (* 2 constants, 2 local defined vars or 2 defined rels *) | (FFlex fl1, FFlex fl2) -> (try (* try first intensional equality *) - if eq_table_key fl1 fl2 - then convert_stacks l2r infos lft1 lft2 v1 v2 cuniv - else raise NotConvertible + if eq_table_key fl1 fl2 then convert_stacks l2r infos lft1 lft2 v1 v2 cuniv + else + (let cuniv = conv_table_key fl1 fl2 cuniv in + convert_stacks l2r infos lft1 lft2 v1 v2 cuniv) with NotConvertible -> (* else the oracle tells which constant is to be expanded *) let (app1,app2) = - if Conv_oracle.oracle_order (Closure.oracle_of_infos (snd infos)) l2r fl1 fl2 then + if Conv_oracle.oracle_order (Closure.oracle_of_infos infos) l2r (conv_key fl1) (conv_key fl2) then match unfold_reference infos fl1 with - | Some def1 -> ((lft1, whd_stack (snd infos) def1 v1), appr2) + | Some def1 -> ((lft1, whd def1 v1), appr2) | None -> (match unfold_reference infos fl2 with - | Some def2 -> (appr1, (lft2, whd_stack (snd infos) def2 v2)) + | Some def2 -> (appr1, (lft2, whd def2 v2)) | None -> raise NotConvertible) else match unfold_reference infos fl2 with - | Some def2 -> (appr1, (lft2, whd_stack (snd infos) def2 v2)) + | Some def2 -> (appr1, (lft2, whd def2 v2)) | None -> (match unfold_reference infos fl1 with - | Some def1 -> ((lft1, whd_stack (snd infos) def1 v1), appr2) + | Some def1 -> ((lft1, whd def1 v1), appr2) | None -> raise NotConvertible) in eqappr cv_pb l2r infos app1 app2 cuniv) + | (FProj (p1,c1), FProj (p2, c2)) -> + (* Projections: prefer unfolding to first-order unification, + which will happen naturally if the terms c1, c2 are not in constructor + form *) + (match unfold_projection infos p1 c1 with + | Some (def1,s1) -> + eqappr cv_pb l2r infos (lft1, whd def1 (s1 :: v1)) appr2 cuniv + | None -> + match unfold_projection infos p2 c2 with + | Some (def2,s2) -> + eqappr cv_pb l2r infos appr1 (lft2, whd def2 (s2 :: v2)) cuniv + | None -> + if eq_constant p1 p2 && compare_stack_shape v1 v2 then + let u1 = ccnv CONV l2r infos el1 el2 c1 c2 cuniv in + convert_stacks l2r infos lft1 lft2 v1 v2 u1 + else (* Two projections in WHNF: unfold *) + raise NotConvertible) + + | (FProj (p1,c1), t2) -> + (match unfold_projection infos p1 c1 with + | Some (def1,s1) -> + eqappr cv_pb l2r infos (lft1, whd def1 (s1 :: v1)) appr2 cuniv + | None -> raise NotConvertible) + + | (_, FProj (p2,c2)) -> + (match unfold_projection infos p2 c2 with + | Some (def2,s2) -> + eqappr cv_pb l2r infos appr1 (lft2, whd def2 (s2 :: v2)) cuniv + | None -> raise NotConvertible) + (* other constructors *) | (FLambda _, FLambda _) -> (* Inconsistency: we tolerate that v1, v2 contain shift and update but @@ -337,15 +438,15 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = anomaly (Pp.str "conversion was given ill-typed terms (FLambda)"); let (_,ty1,bd1) = destFLambda mk_clos hd1 in let (_,ty2,bd2) = destFLambda mk_clos hd2 in - let u1 = ccnv CONV l2r infos el1 el2 ty1 ty2 cuniv in - ccnv CONV l2r infos (el_lift el1) (el_lift el2) bd1 bd2 u1 + let cuniv = ccnv CONV l2r infos el1 el2 ty1 ty2 cuniv in + ccnv CONV l2r infos (el_lift el1) (el_lift el2) bd1 bd2 cuniv | (FProd (_,c1,c2), FProd (_,c'1,c'2)) -> if not (is_empty_stack v1 && is_empty_stack v2) then anomaly (Pp.str "conversion was given ill-typed terms (FProd)"); (* Luo's system *) - let u1 = ccnv CONV l2r infos el1 el2 c1 c'1 cuniv in - ccnv cv_pb l2r infos (el_lift el1) (el_lift el2) c2 c'2 u1 + let cuniv = ccnv CONV l2r infos el1 el2 c1 c'1 cuniv in + ccnv cv_pb l2r infos (el_lift el1) (el_lift el2) c2 c'2 cuniv (* Eta-expansion on the fly *) | (FLambda _, _) -> @@ -368,30 +469,63 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = (el_lift lft1, (hd1, eta_expand_stack v1)) (el_lift lft2, (bd2, [])) cuniv (* only one constant, defined var or defined rel *) - | (FFlex fl1, _) -> + | (FFlex fl1, c2) -> (match unfold_reference infos fl1 with | Some def1 -> - eqappr cv_pb l2r infos (lft1, whd_stack (snd infos) def1 v1) appr2 cuniv - | None -> raise NotConvertible) - | (_, FFlex fl2) -> + eqappr cv_pb l2r infos (lft1, whd def1 v1) appr2 cuniv + | None -> + match c2 with + | FConstruct ((ind2,j2),u2) -> + (try + let v2, v1 = + eta_expand_ind_stacks (info_env infos) ind2 hd2 v2 (snd appr1) + in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv + with Not_found -> raise NotConvertible) + | _ -> raise NotConvertible) + + | (c1, FFlex fl2) -> (match unfold_reference infos fl2 with | Some def2 -> - eqappr cv_pb l2r infos appr1 (lft2, whd_stack (snd infos) def2 v2) cuniv - | None -> raise NotConvertible) - + eqappr cv_pb l2r infos appr1 (lft2, whd def2 v2) cuniv + | None -> + match c1 with + | FConstruct ((ind1,j1),u1) -> + (try let v1, v2 = + eta_expand_ind_stacks (info_env infos) ind1 hd1 v1 (snd appr2) + in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv + with Not_found -> raise NotConvertible) + | _ -> raise NotConvertible) + (* Inductive types: MutInd MutConstruct Fix Cofix *) - | (FInd ind1, FInd ind2) -> + | (FInd (ind1,u1), FInd (ind2,u2)) -> if eq_ind ind1 ind2 then - convert_stacks l2r infos lft1 lft2 v1 v2 cuniv + (let cuniv = convert_universes cuniv u1 u2 in + convert_stacks l2r infos lft1 lft2 v1 v2 cuniv) else raise NotConvertible - | (FConstruct (ind1,j1), FConstruct (ind2,j2)) -> + | (FConstruct ((ind1,j1),u1), FConstruct ((ind2,j2),u2)) -> if Int.equal j1 j2 && eq_ind ind1 ind2 then - convert_stacks l2r infos lft1 lft2 v1 v2 cuniv + (let cuniv = convert_universes cuniv u1 u2 in + convert_stacks l2r infos lft1 lft2 v1 v2 cuniv) else raise NotConvertible + + (* Eta expansion of records *) + | (FConstruct ((ind1,j1),u1), _) -> + (try + let v1, v2 = + eta_expand_ind_stacks (info_env infos) ind1 hd1 v1 (snd appr2) + in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv + with Not_found -> raise NotConvertible) + + | (_, FConstruct ((ind2,j2),u2)) -> + (try + let v2, v1 = + eta_expand_ind_stacks (info_env infos) ind2 hd2 v2 (snd appr1) + in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv + with Not_found -> raise NotConvertible) | (FFix (((op1, i1),(_,tys1,cl1)),e1), FFix(((op2, i2),(_,tys2,cl2)),e2)) -> if Int.equal i1 i2 && Array.equal Int.equal op1 op2 @@ -401,11 +535,11 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = let fty2 = Array.map (mk_clos e2) tys2 in let fcl1 = Array.map (mk_clos (subs_liftn n e1)) cl1 in let fcl2 = Array.map (mk_clos (subs_liftn n e2)) cl2 in - let u1 = convert_vect l2r infos el1 el2 fty1 fty2 cuniv in - let u2 = + let cuniv = convert_vect l2r infos el1 el2 fty1 fty2 cuniv in + let cuniv = convert_vect l2r infos - (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 u1 in - convert_stacks l2r infos lft1 lft2 v1 v2 u2 + (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 cuniv in + convert_stacks l2r infos lft1 lft2 v1 v2 cuniv else raise NotConvertible | (FCoFix ((op1,(_,tys1,cl1)),e1), FCoFix((op2,(_,tys2,cl2)),e2)) -> @@ -416,11 +550,11 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = let fty2 = Array.map (mk_clos e2) tys2 in let fcl1 = Array.map (mk_clos (subs_liftn n e1)) cl1 in let fcl2 = Array.map (mk_clos (subs_liftn n e2)) cl2 in - let u1 = convert_vect l2r infos el1 el2 fty1 fty2 cuniv in - let u2 = + let cuniv = convert_vect l2r infos el1 el2 fty1 fty2 cuniv in + let cuniv = convert_vect l2r infos - (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 u1 in - convert_stacks l2r infos lft1 lft2 v1 v2 u2 + (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 cuniv in + convert_stacks l2r infos lft1 lft2 v1 v2 cuniv else raise NotConvertible (* Should not happen because both (hd1,v1) and (hd2,v2) are in whnf *) @@ -433,7 +567,7 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = and convert_stacks l2r infos lft1 lft2 stk1 stk2 cuniv = compare_stacks - (fun (l1,t1) (l2,t2) c -> ccnv CONV l2r infos l1 l2 t1 t2 c) + (fun (l1,t1) (l2,t2) c -> ccnv CONV l2r infos l1 l2 t1 t2 cuniv) (eq_ind) lft1 stk1 lft2 stk2 cuniv @@ -442,26 +576,45 @@ and convert_vect l2r infos lft1 lft2 v1 v2 cuniv = let lv2 = Array.length v2 in if Int.equal lv1 lv2 then - let rec fold n univ = - if n >= lv1 then univ + let rec fold n cuniv = + if n >= lv1 then cuniv else - let u1 = ccnv CONV l2r infos lft1 lft2 v1.(n) v2.(n) univ in - fold (n+1) u1 in + let cuniv = ccnv CONV l2r infos lft1 lft2 v1.(n) v2.(n) cuniv in + fold (n+1) cuniv in fold 0 cuniv else raise NotConvertible -let clos_fconv trans cv_pb l2r evars env t1 t2 = - let infos = trans, create_clos_infos ~evars betaiotazeta env in - ccnv cv_pb l2r infos el_id el_id (inject t1) (inject t2) empty_constraint +let clos_fconv trans cv_pb l2r evars env univs t1 t2 = + let reds = Closure.RedFlags.red_add_transparent betaiotazeta trans in + let infos = create_clos_infos ~evars reds env in + ccnv cv_pb l2r infos el_id el_id (inject t1) (inject t2) univs -let trans_fconv reds cv_pb l2r evars env t1 t2 = - if eq_constr t1 t2 then empty_constraint - else clos_fconv reds cv_pb l2r evars env t1 t2 +let trans_fconv_universes reds cv_pb l2r evars env univs t1 t2 = + let b = + if cv_pb = CUMUL then leq_constr_univs univs t1 t2 + else eq_constr_univs univs t1 t2 + in + if b then () + else + let _ = clos_fconv reds cv_pb l2r evars env (univs, None) t1 t2 in + () + +(* Profiling *) +(* let trans_fconv_universes_key = Profile.declare_profile "trans_fconv_universes" *) +(* let trans_fconv_universes = Profile.profile8 trans_fconv_universes_key trans_fconv_universes *) + +let trans_fconv reds cv_pb l2r evars env = + trans_fconv_universes reds cv_pb l2r evars env (universes env) let trans_conv_cmp ?(l2r=false) conv reds = trans_fconv reds conv l2r (fun _->None) let trans_conv ?(l2r=false) ?(evars=fun _->None) reds = trans_fconv reds CONV l2r evars let trans_conv_leq ?(l2r=false) ?(evars=fun _->None) reds = trans_fconv reds CUMUL l2r evars +let trans_conv_universes ?(l2r=false) ?(evars=fun _->None) reds = + trans_fconv_universes reds CONV l2r evars +let trans_conv_leq_universes ?(l2r=false) ?(evars=fun _->None) reds = + trans_fconv_universes reds CUMUL l2r evars + let fconv = trans_fconv (Id.Pred.full, Cpred.full) let conv_cmp ?(l2r=false) cv_pb = fconv cv_pb l2r (fun _->None) @@ -470,22 +623,43 @@ let conv_leq ?(l2r=false) ?(evars=fun _->None) = fconv CUMUL l2r evars let conv_leq_vecti ?(l2r=false) ?(evars=fun _->None) env v1 v2 = Array.fold_left2_i - (fun i c t1 t2 -> - let c' = - try conv_leq ~l2r ~evars env t1 t2 - with NotConvertible -> raise (NotConvertibleVect i) in - union_constraints c c') - empty_constraint + (fun i _ t1 t2 -> + try conv_leq ~l2r ~evars env t1 t2 + with NotConvertible -> raise (NotConvertibleVect i)) + () v1 v2 +let infer_conv_universes cv_pb l2r evars reds env univs t1 t2 = + let b = + if cv_pb = CUMUL then leq_constr_univs univs t1 t2 + else eq_constr_univs univs t1 t2 + in + if b then Constraint.empty + else + let (u, cstrs) = + clos_fconv reds cv_pb l2r evars env (univs, Some Constraint.empty) t1 t2 + in Option.get cstrs + +(* Profiling *) +(* let infer_conv_universes_key = Profile.declare_profile "infer_conv_universes" *) +(* let infer_conv_universes = Profile.profile8 infer_conv_universes_key infer_conv_universes *) + +let infer_conv ?(l2r=false) ?(evars=fun _ -> None) ?(ts=full_transparent_state) + env univs t1 t2 = + infer_conv_universes CONV l2r evars ts env univs t1 t2 + +let infer_conv_leq ?(l2r=false) ?(evars=fun _ -> None) ?(ts=full_transparent_state) + env univs t1 t2 = + infer_conv_universes CUMUL l2r evars ts env univs t1 t2 + (* option for conversion *) let nat_conv = ref (fun cv_pb sigma -> fconv cv_pb false (sigma.Nativelambda.evars_val)) let set_nat_conv f = nat_conv := f let native_conv cv_pb sigma env t1 t2 = - if eq_constr t1 t2 then empty_constraint + if eq_constr t1 t2 then () else begin let t1 = (it_mkLambda_or_LetIn t1 (rel_context env)) in let t2 = (it_mkLambda_or_LetIn t2 (rel_context env)) in diff --git a/kernel/reduction.mli b/kernel/reduction.mli index 7c0607cc4..b9bd41f28 100644 --- a/kernel/reduction.mli +++ b/kernel/reduction.mli @@ -13,28 +13,39 @@ open Environ (*********************************************************************** s Reduction functions *) -val whd_betaiotazeta : constr -> constr +val whd_betaiotazeta : env -> constr -> constr val whd_betadeltaiota : env -> constr -> constr val whd_betadeltaiota_nolet : env -> constr -> constr -val whd_betaiota : constr -> constr -val nf_betaiota : constr -> constr +val whd_betaiota : env -> constr -> constr +val nf_betaiota : env -> constr -> constr (*********************************************************************** s conversion functions *) exception NotConvertible exception NotConvertibleVect of int -type 'a conversion_function = env -> 'a -> 'a -> Univ.constraints -type 'a trans_conversion_function = Names.transparent_state -> env -> 'a -> 'a -> Univ.constraints + +type conv_universes = Univ.universes * Univ.constraints option + +type 'a conversion_function = env -> 'a -> 'a -> unit +type 'a trans_conversion_function = Names.transparent_state -> 'a conversion_function +type 'a universe_conversion_function = env -> Univ.universes -> 'a -> 'a -> unit +type 'a trans_universe_conversion_function = + Names.transparent_state -> 'a universe_conversion_function + +type 'a infer_conversion_function = env -> Univ.universes -> 'a -> 'a -> Univ.constraints type conv_pb = CONV | CUMUL -val sort_cmp : - conv_pb -> sorts -> sorts -> Univ.constraints -> Univ.constraints +val sort_cmp_universes : + conv_pb -> sorts -> sorts -> conv_universes -> conv_universes -val conv_sort : sorts conversion_function -val conv_sort_leq : sorts conversion_function +(* val sort_cmp : *) +(* conv_pb -> sorts -> sorts -> Univ.constraints -> Univ.constraints *) + +(* val conv_sort : sorts conversion_function *) +(* val conv_sort_leq : sorts conversion_function *) val trans_conv_cmp : ?l2r:bool -> conv_pb -> constr trans_conversion_function val trans_conv : @@ -42,6 +53,11 @@ val trans_conv : val trans_conv_leq : ?l2r:bool -> ?evars:(existential->constr option) -> types trans_conversion_function +val trans_conv_universes : + ?l2r:bool -> ?evars:(existential->constr option) -> constr trans_universe_conversion_function +val trans_conv_leq_universes : + ?l2r:bool -> ?evars:(existential->constr option) -> types trans_universe_conversion_function + val conv_cmp : ?l2r:bool -> conv_pb -> constr conversion_function val conv : ?l2r:bool -> ?evars:(existential->constr option) -> constr conversion_function @@ -50,6 +66,11 @@ val conv_leq : val conv_leq_vecti : ?l2r:bool -> ?evars:(existential->constr option) -> types array conversion_function +val infer_conv : ?l2r:bool -> ?evars:(existential->constr option) -> + ?ts:Names.transparent_state -> constr infer_conversion_function +val infer_conv_leq : ?l2r:bool -> ?evars:(existential->constr option) -> + ?ts:Names.transparent_state -> types infer_conversion_function + (** option for conversion *) val set_vm_conv : (conv_pb -> types conversion_function) -> unit val vm_conv : conv_pb -> types conversion_function diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index c89766fb9..093797fc0 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -139,7 +139,7 @@ let empty_environment = modlabels = Label.Set.empty; objlabels = Label.Set.empty; future_cst = []; - univ = Univ.empty_constraint; + univ = Univ.Constraint.empty; engagement = None; imports = []; loads = []; @@ -197,7 +197,10 @@ let add_constraints cst senv = | Now cst -> { senv with env = Environ.add_constraints cst senv.env; - univ = Univ.union_constraints cst senv.univ } + univ = Univ.Constraint.union cst senv.univ } + +let push_context_set ctx = add_constraints (Now (Univ.ContextSet.constraints ctx)) +let push_context ctx = add_constraints (Now (Univ.UContext.constraints ctx)) let is_curmod_library senv = match senv.modvariant with LIBRARY -> true | _ -> false @@ -291,22 +294,22 @@ let safe_push_named (id,_,_ as d) env = with Not_found -> () in Environ.push_named d env + let push_named_def (id,de) senv = - let (c,typ,cst) = Term_typing.translate_local_def senv.env id de in - let c,cst' = match c with - | Def c -> Mod_subst.force_constr c, Univ.empty_constraint - | OpaqueDef o -> Opaqueproof.force_proof o, Opaqueproof.force_constraints o + let c,typ,univs = Term_typing.translate_local_def senv.env id de in + let c = match c with + | Def c -> Mod_subst.force_constr c + | OpaqueDef o -> Opaqueproof.force_proof o | _ -> assert false in - let senv = add_constraints (Now cst') senv in - let senv' = add_constraints (Now cst) senv in + let senv' = push_context de.Entries.const_entry_universes senv in let env'' = safe_push_named (id,Some c,typ) senv'.env in - (Univ.union_constraints cst cst', {senv' with env=env''}) + {senv' with env=env''} -let push_named_assum (id,t) senv = - let (t,cst) = Term_typing.translate_local_assum senv.env t in - let senv' = add_constraints (Now cst) senv in +let push_named_assum ((id,t),ctx) senv = + let senv' = push_context_set ctx senv in + let t = Term_typing.translate_local_assum senv'.env t in let env'' = safe_push_named (id,None,t) senv'.env in - (cst, {senv' with env=env''}) + {senv' with env=env''} (** {6 Insertion of new declarations to current environment } *) @@ -324,20 +327,35 @@ let labels_of_mib mib = Array.iter visit_mip mib.mind_packets; get () -let constraints_of_sfb = function - | SFBmind mib -> [Now mib.mind_constraints] - | SFBmodtype mtb -> [Now mtb.typ_constraints] - | SFBmodule mb -> [Now mb.mod_constraints] - | SFBconst cb -> [Now cb.const_constraints] @ - match cb.const_body with - | (Undef _ | Def _) -> [] - | OpaqueDef lc -> - match Opaqueproof.get_constraints lc with - | None -> [] - | Some fc -> - match Future.peek_val fc with - | None -> [Later fc] - | Some c -> [Now c] +let globalize_constant_universes cb = + if cb.const_polymorphic then + Now Univ.Constraint.empty + else + (match Future.peek_val cb.const_universes with + | Some c -> Now (Univ.UContext.constraints c) + | None -> Later (Future.chain ~pure:true cb.const_universes Univ.UContext.constraints)) + +let globalize_mind_universes mb = + if mb.mind_polymorphic then + Now Univ.Constraint.empty + else + Now (Univ.UContext.constraints mb.mind_universes) + +let constraints_of_sfb sfb = + match sfb with + | SFBconst cb -> globalize_constant_universes cb + | SFBmind mib -> globalize_mind_universes mib + | SFBmodtype mtb -> Now mtb.typ_constraints + | SFBmodule mb -> Now mb.mod_constraints + +(* let add_constraints cst senv = *) +(* { senv with *) +(* env = Environ.add_constraints cst senv.env; *) +(* univ = Univ.Constraint.union cst senv.univ } *) + +(* let next_universe senv = *) +(* let univ = senv.max_univ in *) +(* univ + 1, { senv with max_univ = univ + 1 } *) (** A generic function for adding a new field in a same environment. It also performs the corresponding [add_constraints]. *) @@ -358,7 +376,8 @@ let add_field ((l,sfb) as field) gn senv = | SFBmodule _ | SFBmodtype _ -> check_modlabel l senv; (Label.Set.singleton l, Label.Set.empty) in - let senv = List.fold_right add_constraints (constraints_of_sfb sfb) senv in + let cst = constraints_of_sfb sfb in + let senv = add_constraints cst senv in let env' = match sfb, gn with | SFBconst cb, C con -> Environ.add_constant con cb senv.env | SFBmind mib, I mind -> Environ.add_mind mind mib senv.env @@ -377,7 +396,6 @@ let add_field ((l,sfb) as field) gn senv = let update_resolver f senv = { senv with modresolver = f senv.modresolver } (** Insertion of constants and parameters in environment *) - type global_declaration = | ConstantEntry of Entries.constant_entry | GlobalRecipe of Cooking.recipe @@ -548,8 +566,8 @@ let propagate_senv newdef newenv newresolver senv oldsenv = modlabels = Label.Set.add (fst newdef) oldsenv.modlabels; univ = List.fold_left (fun acc cst -> - Univ.union_constraints acc (Future.force cst)) - (Univ.union_constraints senv.univ oldsenv.univ) + Univ.Constraint.union acc (Future.force cst)) + (Univ.Constraint.union senv.univ oldsenv.univ) now_cst; future_cst = later_cst @ oldsenv.future_cst; (* engagement is propagated to the upper level *) @@ -571,7 +589,7 @@ let end_module l restype senv = let senv'= propagate_loads { senv with env = newenv; - univ = Univ.union_constraints senv.univ mb.mod_constraints} in + univ = Univ.Constraint.union senv.univ mb.mod_constraints} in let newenv = Environ.add_constraints mb.mod_constraints senv'.env in let newenv = Modops.add_module mb newenv in let newresolver = @@ -637,7 +655,7 @@ let add_include me is_module inl senv = { typ_mp = mp_sup; typ_expr = NoFunctor (List.rev senv.revstruct); typ_expr_alg = None; - typ_constraints = Univ.empty_constraint; + typ_constraints = Univ.Constraint.empty; typ_delta = senv.modresolver } in compute_sign sign mtb resolver senv in @@ -672,6 +690,10 @@ type compiled_library = { type native_library = Nativecode.global list +(** FIXME: MS: remove?*) +let current_modpath senv = senv.modpath +let current_dirpath senv = Names.ModPath.dp (current_modpath senv) + let start_library dir senv = check_initial senv; assert (not (DirPath.is_empty dir)); @@ -747,10 +769,7 @@ type judgment = Environ.unsafe_judgment let j_val j = j.Environ.uj_val let j_type j = j.Environ.uj_type -let safe_infer senv = Typeops.infer (env_of_senv senv) - -let typing senv = Typeops.typing (env_of_senv senv) - +let typing senv = Typeops.infer (env_of_senv senv) (** {6 Retroknowledge / native compiler } *) diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index d70d7d8be..ad2148ead 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -55,9 +55,9 @@ val join_safe_environment : safe_environment -> safe_environment (** Insertion of local declarations (Local or Variables) *) val push_named_assum : - Id.t * Term.types -> Univ.constraints safe_transformer + (Id.t * Term.types) Univ.in_universe_context_set -> safe_transformer0 val push_named_def : - Id.t * Entries.definition_entry -> Univ.constraints safe_transformer + Id.t * Entries.definition_entry -> safe_transformer0 (** Insertion of global axioms or definitions *) @@ -85,10 +85,19 @@ val add_modtype : (** Adding universe constraints *) -val add_constraints : Univ.constraints -> safe_transformer0 +val push_context_set : + Univ.universe_context_set -> safe_transformer0 -(** Setting the Set-impredicative engagement *) +val push_context : + Univ.universe_context -> safe_transformer0 +val add_constraints : + Univ.constraints -> safe_transformer0 + +(* (\** Generator of universes *\) *) +(* val next_universe : int safe_transformer *) + +(** Settin the strongly constructive or classical logical engagement *) val set_engagement : Declarations.engagement -> safe_transformer0 (** {6 Interactive module functions } *) @@ -113,6 +122,10 @@ val add_include : Entries.module_struct_entry -> bool -> Declarations.inline -> Mod_subst.delta_resolver safe_transformer +val current_modpath : safe_environment -> module_path + +val current_dirpath : safe_environment -> dir_path + (** {6 Libraries : loading and saving compilation units } *) type compiled_library @@ -137,12 +150,7 @@ type judgment val j_val : judgment -> Term.constr val j_type : judgment -> Term.constr -(** The safe typing of a term returns a typing judgment and some universe - constraints (to be added to the environment for the judgment to - hold). It is guaranteed that the constraints are satisfiable. - *) -val safe_infer : safe_environment -> Term.constr -> judgment * Univ.constraints - +(** The safe typing of a term returns a typing judgment. *) val typing : safe_environment -> Term.constr -> judgment (** {6 Queries } *) @@ -164,4 +172,4 @@ val register : val register_inline : constant -> safe_transformer0 val set_strategy : - safe_environment -> 'a Names.tableKey -> Conv_oracle.level -> safe_environment + safe_environment -> Names.constant Names.tableKey -> Conv_oracle.level -> safe_environment diff --git a/kernel/sorts.ml b/kernel/sorts.ml index 03f1cd265..3ebd06dd8 100644 --- a/kernel/sorts.ml +++ b/kernel/sorts.ml @@ -20,6 +20,16 @@ let prop = Prop Null let set = Prop Pos let type1 = Type type1_univ +let univ_of_sort = function + | Type u -> u + | Prop Pos -> Universe.type0 + | Prop Null -> Universe.type0m + +let sort_of_univ u = + if is_type0m_univ u then Prop Null + else if is_type0_univ u then Prop Pos + else Type u + let compare s1 s2 = if s1 == s2 then 0 else match s1, s2 with @@ -36,8 +46,16 @@ let compare s1 s2 = let equal s1 s2 = Int.equal (compare s1 s2) 0 let is_prop = function -| Prop Null -> true -| _ -> false + | Prop Null -> true + | _ -> false + +let is_set = function + | Prop Pos -> true + | _ -> false + +let is_small = function + | Prop _ -> true + | Type u -> is_small_univ u let family = function | Prop Null -> InProp @@ -56,7 +74,7 @@ let hash = function in combinesmall 1 h | Type u -> - let h = Universe.hash u in + let h = Hashtbl.hash u in (** FIXME *) combinesmall 2 h module List = struct @@ -70,14 +88,18 @@ module Hsorts = type _t = t type t = _t type u = universe -> universe + let hashcons huniv = function - | Type u -> Type (huniv u) + | Type u as c -> + let u' = huniv u in + if u' == u then c else Type u' | s -> s let equal s1 s2 = match (s1,s2) with | (Prop c1, Prop c2) -> c1 == c2 | (Type u1, Type u2) -> u1 == u2 |_ -> false - let hash = hash + + let hash = Hashtbl.hash (** FIXME *) end) let hcons = Hashcons.simple_hcons Hsorts.generate hcons_univ diff --git a/kernel/sorts.mli b/kernel/sorts.mli index 2750145f1..ff7d138d6 100644 --- a/kernel/sorts.mli +++ b/kernel/sorts.mli @@ -24,7 +24,9 @@ val equal : t -> t -> bool val compare : t -> t -> int val hash : t -> int +val is_set : t -> bool val is_prop : t -> bool +val is_small : t -> bool val family : t -> family val hcons : t -> t @@ -35,3 +37,6 @@ module List : sig val mem : family -> family list -> bool val intersect : family list -> family list -> family list end + +val univ_of_sort : t -> Univ.universe +val sort_of_univ : Univ.universe -> t diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml index af4468981..2c093939a 100644 --- a/kernel/subtyping.ml +++ b/kernel/subtyping.ml @@ -80,10 +80,8 @@ let make_labmap mp list = let check_conv_error error why cst f env a1 a2 = - try - union_constraints cst (f env a1 a2) - with - NotConvertible -> error why + try Constraint.union cst (f env (Environ.universes env) a1 a2) + with NotConvertible -> error why (* for now we do not allow reorderings *) @@ -94,10 +92,15 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2 let check_conv why cst f = check_conv_error error why cst f in let mib1 = match info1 with - | IndType ((_,0), mib) -> Declareops.subst_mind subst1 mib + | IndType ((_,0), mib) -> Declareops.subst_mind_body subst1 mib | _ -> error (InductiveFieldExpected mib2) in - let mib2 = Declareops.subst_mind subst2 mib2 in + let u = + if mib1.mind_polymorphic then + UContext.instance mib1.mind_universes + else Instance.empty + in + let mib2 = Declareops.subst_mind_body subst2 mib2 in let check_inductive_type cst name env t1 t2 = (* Due to sort-polymorphism in inductive types, the conclusions of @@ -131,7 +134,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 conv_leq env (mkArity (ctx1,s1)) (mkArity (ctx2,s2)) + cst infer_conv_leq env (mkArity (ctx1,s1)) (mkArity (ctx2,s2)) in let check_packet cst p1 p2 = @@ -149,18 +152,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 cst = check_inductive_type cst p2.mind_typename env (type_of_inductive env (mib1,p1)) (type_of_inductive env (mib2,p2)) - in + 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 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 conv env t1 t2) + (fun cst id t1 t2 -> check_conv (NotConvertibleConstructorField id) cst infer_conv env t1 t2) cst p2.mind_consnames - (arities_of_specif mind (mib1,p1)) - (arities_of_specif mind (mib2,p2)) + (arities_of_specif (mind,u) (mib1,p1)) + (arities_of_specif (mind,u) (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) (==) (fun x -> FiniteInductiveFieldExpected x); @@ -180,13 +185,13 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2 let kn2' = kn_of_delta reso2 kn2 in if KerName.equal kn2 kn2' || MutInd.equal (mind_of_delta_kn reso1 kn1) - (subst_ind subst2 (MutInd.make kn2 kn2')) + (subst_mind subst2 (MutInd.make kn2 kn2')) then () else error NotEqualInductiveAliases end; (* we check that records and their field names are preserved. *) - check (fun mib -> mib.mind_record) (==) (fun x -> RecordFieldExpected x); - if mib1.mind_record then begin + check (fun mib -> mib.mind_record <> None) (==) (fun x -> RecordFieldExpected x); + if mib1.mind_record <> None then begin let rec names_prod_letin t = match kind_of_term t with | Prod(n,_,t) -> n::(names_prod_letin t) | LetIn(n,_,_,t) -> n::(names_prod_letin t) @@ -264,17 +269,16 @@ let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 = t1,t2 else (t1,t2) in - check_conv err cst conv_leq env t1 t2 + check_conv err cst infer_conv_leq env t1 t2 in - match info1 with | Constant cb1 -> let () = assert (List.is_empty cb1.const_hyps && List.is_empty cb2.const_hyps) in let cb1 = Declareops.subst_const_body subst1 cb1 in let cb2 = Declareops.subst_const_body subst2 cb2 in (* Start by checking types*) - let typ1 = Typeops.type_of_constant_type env cb1.const_type in - let typ2 = Typeops.type_of_constant_type env cb2.const_type in + let typ1 = cb1.const_type in + let typ2 = cb2.const_type in let cst = check_type cst env typ1 typ2 in (* Now we check the bodies: - A transparent constant can only be implemented by a compatible @@ -292,7 +296,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 conv env c1 c2)) + check_conv NotConvertibleBodyField cst infer_conv env c1 c2)) | IndType ((kn,i),mind1) -> ignore (Errors.error ( "The kernel does not recognize yet that a parameter can be " ^ @@ -301,10 +305,14 @@ let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 = "name.")); let () = assert (List.is_empty mind1.mind_hyps && List.is_empty cb2.const_hyps) in if Declareops.constant_has_body cb2 then error DefinitionFieldExpected; - let arity1 = type_of_inductive env (mind1,mind1.mind_packets.(i)) in - let typ2 = Typeops.type_of_constant_type env cb2.const_type in + let u1 = inductive_instance mind1 in + let arity1,cst1 = constrained_type_of_inductive env + ((mind1,mind1.mind_packets.(i)),u1) in + let cst2 = UContext.constraints (Future.force cb2.const_universes) in + let typ2 = cb2.const_type in + let cst = Constraint.union cst (Constraint.union cst1 cst2) in let error = NotConvertibleTypeField (env, arity1, typ2) in - check_conv error cst conv_leq env arity1 typ2 + check_conv error cst infer_conv_leq env arity1 typ2 | IndConstr (((kn,i),j) as cstr,mind1) -> ignore (Errors.error ( "The kernel does not recognize yet that a parameter can be " ^ @@ -313,10 +321,13 @@ let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 = "name.")); let () = assert (List.is_empty mind1.mind_hyps && List.is_empty cb2.const_hyps) in if Declareops.constant_has_body cb2 then error DefinitionFieldExpected; - let ty1 = type_of_constructor cstr (mind1,mind1.mind_packets.(i)) in - let ty2 = Typeops.type_of_constant_type env cb2.const_type in + let u1 = inductive_instance mind1 in + let ty1,cst1 = constrained_type_of_constructor (cstr,u1) (mind1,mind1.mind_packets.(i)) in + let cst2 = UContext.constraints (Future.force cb2.const_universes) in + let ty2 = cb2.const_type in + let cst = Constraint.union cst (Constraint.union cst1 cst2) in let error = NotConvertibleTypeField (env, ty1, ty2) in - check_conv error cst conv env ty1 ty2 + check_conv error cst infer_conv env ty1 ty2 let rec check_modules cst env msb1 msb2 subst1 subst2 = let mty1 = module_type_of_module msb1 in @@ -368,7 +379,7 @@ and check_modtypes cst env mtb1 mtb2 subst1 subst2 equiv = mtb2.typ_mp list2 mtb1.typ_mp list1 subst2 subst1 mtb2.typ_delta mtb1.typ_delta in - Univ.union_constraints cst1 cst2 + Univ.Constraint.union cst1 cst2 else check_signatures cst env mtb1.typ_mp list1 mtb2.typ_mp list2 subst1 subst2 @@ -398,7 +409,7 @@ and check_modtypes cst env mtb1 mtb2 subst1 subst2 equiv = let check_subtypes env sup super = let env = add_module_type sup.typ_mp sup env in - check_modtypes empty_constraint env + check_modtypes Univ.Constraint.empty env (strengthen sup sup.typ_mp) super empty_subst (map_mp super.typ_mp sup.typ_mp sup.typ_delta) false diff --git a/kernel/term.ml b/kernel/term.ml index 24fe6d962..b85c525d1 100644 --- a/kernel/term.ml +++ b/kernel/term.ml @@ -32,7 +32,6 @@ type types = Constr.t (** Same as [constr], for documentation purposes. *) type existential_key = Constr.existential_key - type existential = Constr.existential type metavariable = Constr.metavariable @@ -54,6 +53,10 @@ type case_info = Constr.case_info = type cast_kind = Constr.cast_kind = VMcast | NATIVEcast | DEFAULTcast | REVERTcast +(********************************************************************) +(* Constructions as implemented *) +(********************************************************************) + type rec_declaration = Constr.rec_declaration type fixpoint = Constr.fixpoint type cofixpoint = Constr.cofixpoint @@ -62,6 +65,12 @@ type ('constr, 'types) prec_declaration = ('constr, 'types) Constr.prec_declaration type ('constr, 'types) pfixpoint = ('constr, 'types) Constr.pfixpoint type ('constr, 'types) pcofixpoint = ('constr, 'types) Constr.pcofixpoint +type 'a puniverses = 'a Univ.puniverses + +(** Simply type aliases *) +type pconstant = constant puniverses +type pinductive = inductive puniverses +type pconstructor = constructor puniverses type ('constr, 'types) kind_of_term = ('constr, 'types) Constr.kind_of_term = | Rel of int @@ -74,12 +83,13 @@ type ('constr, 'types) kind_of_term = ('constr, 'types) Constr.kind_of_term = | Lambda of Name.t * 'types * 'constr | LetIn of Name.t * 'constr * 'types * 'constr | App of 'constr * 'constr array - | Const of constant - | Ind of inductive - | Construct of constructor + | Const of pconstant + | Ind of pinductive + | Construct of pconstructor | Case of case_info * 'constr * 'constr * 'constr array | Fix of ('constr, 'types) pfixpoint | CoFix of ('constr, 'types) pcofixpoint + | Proj of constant * 'constr type values = Constr.values @@ -93,6 +103,8 @@ let type1_sort = Sorts.type1 let sorts_ord = Sorts.compare let is_prop_sort = Sorts.is_prop let family_of_sort = Sorts.family +let univ_of_sort = Sorts.univ_of_sort +let sort_of_univ = Sorts.sort_of_univ (** {6 Term constructors. } *) @@ -110,8 +122,13 @@ let mkLambda = Constr.mkLambda let mkLetIn = Constr.mkLetIn let mkApp = Constr.mkApp let mkConst = Constr.mkConst +let mkProj = Constr.mkProj let mkInd = Constr.mkInd let mkConstruct = Constr.mkConstruct +let mkConstU = Constr.mkConstU +let mkIndU = Constr.mkIndU +let mkConstructU = Constr.mkConstructU +let mkConstructUi = Constr.mkConstructUi let mkCase = Constr.mkCase let mkFix = Constr.mkFix let mkCoFix = Constr.mkCoFix @@ -121,9 +138,16 @@ let mkCoFix = Constr.mkCoFix (**********************************************************************) let eq_constr = Constr.equal +let eq_constr_univs = Constr.eq_constr_univs +let leq_constr_univs = Constr.leq_constr_univs +let eq_constr_universes = Constr.eq_constr_universes +let leq_constr_universes = Constr.leq_constr_universes +let eq_constr_nounivs = Constr.eq_constr_nounivs + let kind_of_term = Constr.kind let constr_ord = Constr.compare let fold_constr = Constr.fold +let map_puniverses = Constr.map_puniverses let map_constr = Constr.map let map_constr_with_binders = Constr.map_with_binders let iter_constr = Constr.iter @@ -195,9 +219,7 @@ let rec is_Type c = match kind_of_term c with | Cast (c,_,_) -> is_Type c | _ -> false -let is_small = function - | Prop _ -> true - | _ -> false +let is_small = Sorts.is_small let iskind c = isprop c || is_Type c @@ -649,6 +671,7 @@ let kind_of_type t = match kind_of_term t with | Prod (na,t,c) -> ProdType (na, t, c) | LetIn (na,b,t,c) -> LetInType (na, b, t, c) | App (c,l) -> AtomicType (c, l) - | (Rel _ | Meta _ | Var _ | Evar _ | Const _ | Case _ | Fix _ | CoFix _ | Ind _) + | (Rel _ | Meta _ | Var _ | Evar _ | Const _ + | Proj _ | Case _ | Fix _ | CoFix _ | Ind _) -> AtomicType (t,[||]) | (Lambda _ | Construct _) -> failwith "Not a type" diff --git a/kernel/term.mli b/kernel/term.mli index f2f5e8495..2d3df6e1e 100644 --- a/kernel/term.mli +++ b/kernel/term.mli @@ -24,6 +24,13 @@ type sorts = Sorts.t = type sorts_family = Sorts.family = InProp | InSet | InType +type 'a puniverses = 'a Univ.puniverses + +(** Simply type aliases *) +type pconstant = constant puniverses +type pinductive = inductive puniverses +type pconstructor = constructor puniverses + type constr = Constr.constr (** Alias types, for compatibility. *) @@ -73,12 +80,13 @@ type ('constr, 'types) kind_of_term = ('constr, 'types) Constr.kind_of_term = | Lambda of Name.t * 'types * 'constr | LetIn of Name.t * 'constr * 'types * 'constr | App of 'constr * 'constr array - | Const of constant - | Ind of inductive - | Construct of constructor + | Const of constant puniverses + | Ind of inductive puniverses + | Construct of constructor puniverses | Case of case_info * 'constr * 'constr * 'constr array | Fix of ('constr, 'types) pfixpoint | CoFix of ('constr, 'types) pcofixpoint + | Proj of constant * 'constr type values = Constr.values @@ -157,16 +165,16 @@ val decompose_app : constr -> constr * constr list val decompose_appvect : constr -> constr * constr array (** Destructs a constant *) -val destConst : constr -> constant +val destConst : constr -> constant puniverses (** Destructs an existential variable *) val destEvar : constr -> existential (** Destructs a (co)inductive type *) -val destInd : constr -> inductive +val destInd : constr -> inductive puniverses (** Destructs a constructor *) -val destConstruct : constr -> constructor +val destConstruct : constr -> constructor puniverses (** Destructs a [match c as x in I args return P with ... | Ci(...yij...) => ti | ... end] (or [let (..y1i..) := c as x in I args @@ -397,8 +405,13 @@ val mkLambda : Name.t * types * constr -> constr val mkLetIn : Name.t * constr * types * constr -> constr val mkApp : constr * constr array -> constr val mkConst : constant -> constr +val mkProj : (constant * constr) -> constr val mkInd : inductive -> constr val mkConstruct : constructor -> constr +val mkConstU : constant puniverses -> constr +val mkIndU : inductive puniverses -> constr +val mkConstructU : constructor puniverses -> constr +val mkConstructUi : (pinductive * int) -> constr val mkCase : case_info * constr * constr * constr array -> constr val mkFix : fixpoint -> constr val mkCoFix : cofixpoint -> constr @@ -408,6 +421,26 @@ val mkCoFix : cofixpoint -> constr val eq_constr : constr -> constr -> bool (** Alias for [Constr.equal] *) +(** [eq_constr_univs a b] [true, c] if [a] equals [b] modulo alpha, casts, + application grouping and the universe equalities in [c]. *) +val eq_constr_univs : constr Univ.check_function + +(** [leq_constr_univs a b] [true, c] if [a] is convertible to [b] modulo + alpha, casts, application grouping and the universe inequalities in [c]. *) +val leq_constr_univs : constr Univ.check_function + +(** [eq_constr_universes a b] [true, c] if [a] equals [b] modulo alpha, casts, + application grouping and the universe equalities in [c]. *) +val eq_constr_universes : constr -> constr -> bool Univ.universe_constrained + +(** [leq_constr_universes a b] [true, c] if [a] is convertible to [b] modulo + alpha, casts, application grouping and the universe inequalities in [c]. *) +val leq_constr_universes : constr -> constr -> bool Univ.universe_constrained + +(** [eq_constr_univs a b] [true, c] if [a] equals [b] modulo alpha, casts, + application grouping and ignoring universe instances. *) +val eq_constr_nounivs : constr -> constr -> bool + val kind_of_term : constr -> (constr, types) kind_of_term (** Alias for [Constr.kind] *) @@ -424,6 +457,10 @@ val map_constr_with_binders : ('a -> 'a) -> ('a -> constr -> constr) -> 'a -> constr -> constr (** Alias for [Constr.map_with_binders] *) +val map_puniverses : ('a -> 'b) -> 'a puniverses -> 'b puniverses +val univ_of_sort : sorts -> Univ.universe +val sort_of_univ : Univ.universe -> sorts + val iter_constr : (constr -> unit) -> constr -> unit (** Alias for [Constr.iter] *) @@ -437,6 +474,8 @@ val compare_constr : (constr -> constr -> bool) -> constr -> constr -> bool val hash_constr : constr -> int (** Alias for [Constr.hash] *) +(*********************************************************************) + val hcons_sorts : sorts -> sorts (** Alias for [Constr.hashcons_sorts] *) diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index a084504dc..9aa688fc7 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -22,29 +22,35 @@ open Declarations open Environ open Entries open Typeops +open Fast_typeops -let constrain_type env j cst1 = function - | `None -> - make_polymorphic_if_constant_for_ind env j, cst1 +let debug = false +let prerr_endline = + if debug then prerr_endline else fun _ -> () + +let constrain_type env j poly = function + | `None -> j.uj_type | `Some t -> - let (tj,cst2) = infer_type env t in - let (_,cst3) = judge_of_cast env j DEFAULTcast tj in - assert (eq_constr t tj.utj_val); - let cstrs = union_constraints (union_constraints cst1 cst2) cst3 in - NonPolymorphicType t, cstrs - | `SomeWJ (t, tj, cst2) -> - let (_,cst3) = judge_of_cast env j DEFAULTcast tj in - assert (eq_constr t tj.utj_val); - let cstrs = union_constraints (union_constraints cst1 cst2) cst3 in - NonPolymorphicType t, cstrs + let tj = infer_type env t in + let _ = judge_of_cast env j DEFAULTcast tj in + assert (eq_constr t tj.utj_val); + t + | `SomeWJ (t, tj) -> + let tj = infer_type env t in + let _ = judge_of_cast env j DEFAULTcast tj in + assert (eq_constr t tj.utj_val); + t let map_option_typ = function None -> `None | Some x -> `Some x -let translate_local_assum env t = - let (j,cst) = infer env t in - let t = Typeops.assumption_of_judgment env j in - (t,cst) - +let local_constrain_type env j = function + | None -> + j.uj_type + | Some t -> + let tj = infer_type env t in + let _ = judge_of_cast env j DEFAULTcast tj in + assert (eq_constr t tj.utj_val); + t (* Insertion of constants and parameters in environment. *) @@ -59,19 +65,19 @@ let handle_side_effects env body side_eff = if name.[i] == '.' || name.[i] == '#' then name.[i] <- '_' done; Name (id_of_string name) in let rec sub c i x = match kind_of_term x with - | Const c' when eq_constant c c' -> mkRel i + | Const (c', _) when eq_constant c c' -> mkRel i | _ -> map_constr_with_binders ((+) 1) (fun i x -> sub c i x) i x in let fix_body (c,cb) t = match cb.const_body with | Undef _ -> assert false | Def b -> let b = Mod_subst.force_constr b in - let b_ty = Typeops.type_of_constant_type env cb.const_type in + let b_ty = cb.const_type in let t = sub c 1 (Vars.lift 1 t) in mkLetIn (cname c, b, b_ty, t) | OpaqueDef b -> let b = Opaqueproof.force_proof b in - let b_ty = Typeops.type_of_constant_type env cb.const_type in + let b_ty = cb.const_type in let t = sub c 1 (Vars.lift 1 t) in mkApp (mkLambda (cname c, b_ty, t), [|b|]) in List.fold_right fix_body cbl t @@ -86,46 +92,50 @@ let hcons_j j = let feedback_completion_typecheck = Option.iter (fun state_id -> Pp.feedback ~state_id Interface.Complete) -let infer_declaration env dcl = +let infer_declaration env kn dcl = match dcl with - | ParameterEntry (ctx,t,nl) -> - let j, cst = infer env t in + | ParameterEntry (ctx,poly,(t,uctx),nl) -> + let env = push_context uctx env in + let j = infer env t in let t = hcons_constr (Typeops.assumption_of_judgment env j) in - Undef nl, NonPolymorphicType t, cst, false, ctx + Undef nl, t, None, poly, Future.from_val uctx, false, ctx | DefinitionEntry ({ const_entry_type = Some typ; const_entry_opaque = true } as c) -> + let env = push_context c.const_entry_universes env in let { const_entry_body = body; const_entry_feedback = feedback_id } = c in - let tyj, tycst = infer_type env typ in + let tyj = infer_type env typ in let proofterm = Future.chain ~greedy:true ~pure:true body (fun (body, side_eff) -> let body = handle_side_effects env body side_eff in - let j, cst = infer env body in + let j = infer env body in let j = hcons_j j in - let _typ, cst = constrain_type env j cst (`SomeWJ (typ,tyj,tycst)) in + let _typ = constrain_type env j c.const_entry_polymorphic (`SomeWJ (typ,tyj)) in feedback_completion_typecheck feedback_id; - j.uj_val, cst) in + j.uj_val, Univ.empty_constraint) in let def = OpaqueDef (Opaqueproof.create proofterm) in - let typ = NonPolymorphicType typ in - def, typ, tycst, c.const_entry_inline_code, c.const_entry_secctx + def, typ, None, c.const_entry_polymorphic, Future.from_val c.const_entry_universes, + c.const_entry_inline_code, c.const_entry_secctx | DefinitionEntry c -> + let env = push_context c.const_entry_universes env in let { const_entry_type = typ; const_entry_opaque = opaque } = c in let { const_entry_body = body; const_entry_feedback = feedback_id } = c in let body, side_eff = Future.join body in let body = handle_side_effects env body side_eff in - let j, cst = infer env body in + let j = infer env body in let j = hcons_j j in - let typ, cst = constrain_type env j cst (map_option_typ typ) in + let typ = constrain_type env j c.const_entry_polymorphic (map_option_typ typ) in feedback_completion_typecheck feedback_id; let def = Def (Mod_subst.from_val j.uj_val) in - def, typ, cst, c.const_entry_inline_code, c.const_entry_secctx + def, typ, None, c.const_entry_polymorphic, + Future.from_val c.const_entry_universes, c.const_entry_inline_code, c.const_entry_secctx -let global_vars_set_constant_type env = function - | NonPolymorphicType t -> global_vars_set env t - | PolymorphicArity (ctx,_) -> - Context.fold_rel_context - (fold_rel_declaration - (fun t c -> Id.Set.union (global_vars_set env t) c)) - ctx ~init:Id.Set.empty +(* let global_vars_set_constant_type env = function *) +(* | NonPolymorphicType t -> global_vars_set env t *) +(* | PolymorphicArity (ctx,_) -> *) +(* Context.fold_rel_context *) +(* (fold_rel_declaration *) +(* (fun t c -> Id.Set.union (global_vars_set env t) c)) *) +(* ctx ~init:Id.Set.empty *) let record_aux env s1 s2 = let v = @@ -137,7 +147,7 @@ let record_aux env s1 s2 = let suggest_proof_using = ref (fun _ _ _ _ _ -> ()) let set_suggest_proof_using f = suggest_proof_using := f -let build_constant_declaration kn env (def,typ,cst,inline_code,ctx) = +let build_constant_declaration kn env (def,typ,proj,poly,univs,inline_code,ctx) = let check declared inferred = let mk_set l = List.fold_right Id.Set.add (List.map pi1 l) Id.Set.empty in let inferred_set, declared_set = mk_set inferred, mk_set declared in @@ -152,12 +162,14 @@ let build_constant_declaration kn env (def,typ,cst,inline_code,ctx) = | None when not (List.is_empty context_ids) -> (* No declared section vars, and non-empty section context: we must look at the body NOW, if any *) - let ids_typ = global_vars_set_constant_type env typ in + let ids_typ = global_vars_set env typ in let ids_def = match def with | Undef _ -> Idset.empty | Def cs -> global_vars_set env (Mod_subst.force_constr cs) | OpaqueDef lc -> let vars = global_vars_set env (Opaqueproof.force_proof lc) in + (* we force so that cst are added to the env immediately after *) + ignore(Future.join univs); !suggest_proof_using kn env vars ids_typ context_ids; if !Flags.compilation_mode = Flags.BuildVo then record_aux env ids_typ vars; @@ -174,38 +186,50 @@ let build_constant_declaration kn env (def,typ,cst,inline_code,ctx) = match def with | Undef _ as x -> x (* nothing to check *) | Def cs as x -> - let ids_typ = global_vars_set_constant_type env typ in + let ids_typ = global_vars_set env typ in let ids_def = global_vars_set env (Mod_subst.force_constr cs) in let inferred = keep_hyps env (Idset.union ids_typ ids_def) in check declared inferred; x | OpaqueDef lc -> (* In this case we can postpone the check *) OpaqueDef (Opaqueproof.iter_direct_opaque (fun c -> - let ids_typ = global_vars_set_constant_type env typ in + let ids_typ = global_vars_set env typ in let ids_def = global_vars_set env c in let inferred = keep_hyps env (Idset.union ids_typ ids_def) in check declared inferred) lc) in + let tps = + match proj with + | None -> Cemitcodes.from_val (compile_constant_body env def) + | Some pb -> + Cemitcodes.from_val (compile_constant_body env (Def (Mod_subst.from_val pb.proj_body))) + in { const_hyps = hyps; const_body = def; const_type = typ; - const_body_code = Cemitcodes.from_val (compile_constant_body env def); - const_constraints = cst; + const_proj = proj; + const_body_code = tps; + const_polymorphic = poly; + const_universes = univs; const_inline_code = inline_code } + (*s Global and local constant declaration. *) let translate_constant env kn ce = - build_constant_declaration kn env (infer_declaration env ce) + build_constant_declaration kn env (infer_declaration env (Some kn) ce) + +let translate_local_assum env t = + let j = infer env t in + let t = Typeops.assumption_of_judgment env j in + t let translate_recipe env kn r = - let def,typ,cst,inline_code,hyps = Cooking.cook_constant env r in - build_constant_declaration kn env (def,typ,cst,inline_code,hyps) + build_constant_declaration kn env (Cooking.cook_constant env r) let translate_local_def env id centry = - let def,typ,cst,inline_code,ctx = - infer_declaration env (DefinitionEntry centry) in - let typ = type_of_constant_type env typ in - def, typ, cst + let def,typ,proj,poly,univs,inline_code,ctx = + infer_declaration env None (DefinitionEntry centry) in + def, typ, univs (* Insertion of inductive types. *) diff --git a/kernel/term_typing.mli b/kernel/term_typing.mli index b1c336ad9..a2a35492e 100644 --- a/kernel/term_typing.mli +++ b/kernel/term_typing.mli @@ -14,9 +14,9 @@ open Declarations open Entries val translate_local_def : env -> Id.t -> definition_entry -> - constant_def * types * Univ.constraints + constant_def * types * constant_universes -val translate_local_assum : env -> types -> types * constraints +val translate_local_assum : env -> types -> types (* returns the same definition_entry but with side effects turned into * let-ins or beta redexes. it is meant to get a term out of a not yet @@ -32,7 +32,9 @@ val translate_recipe : env -> constant -> Cooking.recipe -> constant_body (** Internal functions, mentioned here for debug purpose only *) -val infer_declaration : env -> constant_entry -> Cooking.result +val infer_declaration : env -> constant option -> + constant_entry -> Cooking.result + val build_constant_declaration : constant -> env -> Cooking.result -> constant_body diff --git a/kernel/type_errors.ml b/kernel/type_errors.ml index 42b93dd37..30dcbafe6 100644 --- a/kernel/type_errors.ml +++ b/kernel/type_errors.ml @@ -42,12 +42,12 @@ type type_error = | NotAType of unsafe_judgment | BadAssumption of unsafe_judgment | ReferenceVariables of identifier * constr - | ElimArity of inductive * sorts_family list * constr * unsafe_judgment + | ElimArity of pinductive * sorts_family list * constr * unsafe_judgment * (sorts_family * sorts_family * arity_error) option | CaseNotInductive of unsafe_judgment - | WrongCaseInfo of inductive * case_info + | WrongCaseInfo of pinductive * case_info | NumberBranches of unsafe_judgment * int - | IllFormedBranch of constr * constructor * constr * constr + | IllFormedBranch of constr * pconstructor * constr * constr | Generalization of (Name.t * types) * unsafe_judgment | ActualType of unsafe_judgment * types | CantApplyBadType of @@ -56,11 +56,12 @@ type type_error = | IllFormedRecBody of guard_error * Name.t array * int * env * unsafe_judgment array | IllTypedRecBody of int * Name.t array * unsafe_judgment array * types array + | UnsatisfiedConstraints of Univ.constraints exception TypeError of env * type_error -let nfj {uj_val=c;uj_type=ct} = - {uj_val=c;uj_type=nf_betaiota ct} +let nfj env {uj_val=c;uj_type=ct} = + {uj_val=c;uj_type=nf_betaiota env ct} let error_unbound_rel env n = raise (TypeError (env, UnboundRel n)) @@ -84,11 +85,11 @@ let error_case_not_inductive env j = raise (TypeError (env, CaseNotInductive j)) let error_number_branches env cj expn = - raise (TypeError (env, NumberBranches (nfj cj,expn))) + raise (TypeError (env, NumberBranches (nfj env cj,expn))) let error_ill_formed_branch env c i actty expty = raise (TypeError (env, - IllFormedBranch (c,i,nf_betaiota actty, nf_betaiota expty))) + IllFormedBranch (c,i,nf_betaiota env actty, nf_betaiota env expty))) let error_generalization env nvar c = raise (TypeError (env, Generalization (nvar,c))) @@ -114,3 +115,5 @@ let error_elim_explain kp ki = | InType, InSet -> StrongEliminationOnNonSmallType (* if Set impredicative *) | _ -> WrongArity +let error_unsatisfied_constraints env c = + raise (TypeError (env, UnsatisfiedConstraints c)) diff --git a/kernel/type_errors.mli b/kernel/type_errors.mli index b9d8efbcd..09310b42b 100644 --- a/kernel/type_errors.mli +++ b/kernel/type_errors.mli @@ -43,12 +43,12 @@ type type_error = | NotAType of unsafe_judgment | BadAssumption of unsafe_judgment | ReferenceVariables of identifier * constr - | ElimArity of inductive * sorts_family list * constr * unsafe_judgment + | ElimArity of pinductive * sorts_family list * constr * unsafe_judgment * (sorts_family * sorts_family * arity_error) option | CaseNotInductive of unsafe_judgment - | WrongCaseInfo of inductive * case_info + | WrongCaseInfo of pinductive * case_info | NumberBranches of unsafe_judgment * int - | IllFormedBranch of constr * constructor * constr * constr + | IllFormedBranch of constr * pconstructor * constr * constr | Generalization of (Name.t * types) * unsafe_judgment | ActualType of unsafe_judgment * types | CantApplyBadType of @@ -57,6 +57,7 @@ type type_error = | IllFormedRecBody of guard_error * Name.t array * int * env * unsafe_judgment array | IllTypedRecBody of int * Name.t array * unsafe_judgment array * types array + | UnsatisfiedConstraints of Univ.constraints exception TypeError of env * type_error @@ -71,14 +72,14 @@ val error_assumption : env -> unsafe_judgment -> 'a val error_reference_variables : env -> identifier -> constr -> 'a val error_elim_arity : - env -> inductive -> sorts_family list -> constr -> unsafe_judgment -> + env -> pinductive -> sorts_family list -> constr -> unsafe_judgment -> (sorts_family * sorts_family * arity_error) option -> 'a val error_case_not_inductive : env -> unsafe_judgment -> 'a val error_number_branches : env -> unsafe_judgment -> int -> 'a -val error_ill_formed_branch : env -> constr -> constructor -> constr -> constr -> 'a +val error_ill_formed_branch : env -> constr -> pconstructor -> constr -> constr -> 'a val error_generalization : env -> Name.t * types -> unsafe_judgment -> 'a @@ -98,3 +99,5 @@ val error_ill_typed_rec_body : env -> int -> Name.t array -> unsafe_judgment array -> types array -> 'a val error_elim_explain : sorts_family -> sorts_family -> arity_error + +val error_unsatisfied_constraints : env -> Univ.constraints -> 'a diff --git a/kernel/typeops.ml b/kernel/typeops.ml index 3400d8ce6..09fd4cc7f 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -20,19 +20,21 @@ open Reduction open Inductive open Type_errors -let conv_leq l2r = default_conv CUMUL ~l2r +let conv_leq l2r env x y = default_conv CUMUL ~l2r env x y let conv_leq_vecti env v1 v2 = Array.fold_left2_i - (fun i c t1 t2 -> - let c' = - try default_conv CUMUL env t1 t2 - with NotConvertible -> raise (NotConvertibleVect i) in - union_constraints c c') - empty_constraint + (fun i _ t1 t2 -> + try conv_leq false env t1 t2 + with NotConvertible -> raise (NotConvertibleVect i)) + () v1 v2 +let check_constraints cst env = + if Environ.check_constraints cst env then () + else error_unsatisfied_constraints env cst + (* This should be a type (a priori without intension to be an assumption) *) let type_judgment env j = match kind_of_term(whd_betadeltaiota env j.uj_type) with @@ -69,9 +71,9 @@ let judge_of_prop_contents = function (* Type of Type(i). *) let judge_of_type u = - let uu = super u in - { uj_val = mkType u; - uj_type = mkType uu } + let uu = Universe.super u in + { uj_val = mkType u; + uj_type = mkType uu } (*s Type of a de Bruijn index. *) @@ -111,53 +113,32 @@ let check_hyps_inclusion env c sign = (* Make a type polymorphic if an arity *) -let extract_level env p = - let _,c = dest_prod_assum env p in - match kind_of_term c with Sort (Type u) -> Some u | _ -> None - -let extract_context_levels env l = - let fold l (_, b, p) = match b with - | None -> extract_level env p :: l - | _ -> l - in - List.fold_left fold [] l - -let make_polymorphic_if_constant_for_ind env {uj_val = c; uj_type = t} = - let params, ccl = dest_prod_assum env t in - match kind_of_term ccl with - | Sort (Type u) when isInd (fst (decompose_app (whd_betadeltaiota env c))) -> - let param_ccls = extract_context_levels env params in - let s = { poly_param_levels = param_ccls; poly_level = u} in - PolymorphicArity (params,s) - | _ -> - NonPolymorphicType t - (* Type of constants *) -let type_of_constant_knowing_parameters env t paramtyps = - match t with - | NonPolymorphicType t -> t - | PolymorphicArity (sign,ar) -> - let ctx = List.rev sign in - let ctx,s = instantiate_universes env ctx ar paramtyps in - mkArity (List.rev ctx,s) - -let type_of_constant_type env t = - type_of_constant_knowing_parameters env t [||] +let type_of_constant env cst = constant_type env cst +let type_of_constant_in env cst = constant_type_in env cst +let type_of_constant_knowing_parameters env t _ = t +let type_of_constant_type env cst = cst -let type_of_constant env cst = - type_of_constant_type env (constant_type env cst) +let judge_of_constant env (kn,u as cst) = + let c = mkConstU cst in + let cb = lookup_constant kn env in + let _ = check_hyps_inclusion env c cb.const_hyps in + let ty, cu = type_of_constant env cst in + let _ = Environ.check_constraints cu env in + (make_judge c ty) -let judge_of_constant_knowing_parameters env cst jl = - let c = mkConst cst in +let type_of_projection env (cst,u) = let cb = lookup_constant cst env in - let _ = check_hyps_inclusion env c cb.const_hyps in - let paramstyp = Array.map (fun j -> lazy j.uj_type) jl in - let t = type_of_constant_knowing_parameters env cb.const_type paramstyp in - make_judge c t + match cb.const_proj with + | Some pb -> + if cb.const_polymorphic then + let mib,_ = lookup_mind_specif env (pb.proj_ind,0) in + let subst = make_inductive_subst mib u in + Vars.subst_univs_constr subst pb.proj_type + else pb.proj_type + | None -> raise (Invalid_argument "type_of_projection: not a projection") -let judge_of_constant env cst = - judge_of_constant_knowing_parameters env cst [||] (* Type of a lambda-abstraction. *) @@ -184,26 +165,27 @@ let judge_of_letin env name defj typj j = (* Type of an application. *) let judge_of_apply env funj argjv = - let len = Array.length argjv in - let rec apply_rec n typ cst = - if len <= n then - { uj_val = mkApp (j_val funj, Array.map j_val argjv); uj_type = typ }, - cst - else - let hj = Array.unsafe_get argjv n in - match kind_of_term (whd_betadeltaiota env typ) with - | Prod (_,c1,c2) -> - let c = - try conv_leq false env hj.uj_type c1 - with NotConvertible -> - error_cant_apply_bad_type env (n + 1, c1, hj.uj_type) funj argjv - in - let cst' = union_constraints cst c in - apply_rec (n+1) (subst1 hj.uj_val c2) cst' - | _ -> - error_cant_apply_not_functional env funj argjv + let rec apply_rec n typ = function + | [] -> + { uj_val = mkApp (j_val funj, Array.map j_val argjv); + uj_type = typ } + | hj::restjl -> + (match kind_of_term (whd_betadeltaiota env typ) with + | Prod (_,c1,c2) -> + (try + let () = conv_leq false env hj.uj_type c1 in + apply_rec (n+1) (subst1 hj.uj_val c2) restjl + with NotConvertible -> + error_cant_apply_bad_type env + (n,c1, hj.uj_type) + funj argjv) + + | _ -> + error_cant_apply_not_functional env funj argjv) in - apply_rec 0 funj.uj_type empty_constraint + apply_rec 1 + funj.uj_type + (Array.to_list argjv) (* Type of product *) @@ -221,14 +203,14 @@ let sort_of_product env domsort rangsort = rangsort | _ -> (* Rule is (Type_i,Set,Type_i) in the Set-predicative calculus *) - Type (sup u1 type0_univ) + Type (Universe.sup Universe.type0 u1) end (* Product rule (Prop,Type_i,Type_i) *) - | (Prop Pos, Type u2) -> Type (sup type0_univ u2) + | (Prop Pos, Type u2) -> Type (Universe.sup Universe.type0 u2) (* Product rule (Prop,Type_i,Type_i) *) | (Prop Null, Type _) -> rangsort (* Product rule (Type_i,Type_i,Type_i) *) - | (Type u1, Type u2) -> Type (sup u1 u2) + | (Type u1, Type u2) -> Type (Universe.sup u1 u2) (* [judge_of_product env name (typ1,s1) (typ2,s2)] implements the rule @@ -262,18 +244,17 @@ let judge_of_cast env cj k tj = vm_conv CUMUL env cj.uj_type expected_type | DEFAULTcast -> mkCast (cj.uj_val, k, expected_type), - conv_leq false env cj.uj_type expected_type + default_conv ~l2r:false CUMUL env cj.uj_type expected_type | REVERTcast -> cj.uj_val, - conv_leq true env cj.uj_type expected_type + default_conv ~l2r:true CUMUL env cj.uj_type expected_type | NATIVEcast -> let sigma = Nativelambda.empty_evars in mkCast (cj.uj_val, k, expected_type), native_conv CUMUL sigma env cj.uj_type expected_type in - { uj_val = c; - uj_type = expected_type }, - cst + { uj_val = c; + uj_type = expected_type } with NotConvertible -> error_actual_type env cj expected_type @@ -291,50 +272,70 @@ let judge_of_cast env cj k tj = the App case of execute; from this constraints, the expected dynamic constraints of the form u<=v are enforced *) -let judge_of_inductive_knowing_parameters env ind jl = - let c = mkInd ind in +(* let judge_of_inductive_knowing_parameters env ind jl = *) +(* let c = mkInd ind in *) +(* let (mib,mip) = lookup_mind_specif env ind in *) +(* check_args env c mib.mind_hyps; *) +(* let paramstyp = Array.map (fun j -> j.uj_type) jl in *) +(* let t = in *) +(* make_judge c t *) + +let judge_of_inductive env (ind,u as indu) = + let c = mkIndU indu in let (mib,mip) = lookup_mind_specif env ind in check_hyps_inclusion env c mib.mind_hyps; - let paramstyp = Array.map (fun j -> lazy j.uj_type) jl in - let t = Inductive.type_of_inductive_knowing_parameters env mip paramstyp in - make_judge c t - -let judge_of_inductive env ind = - judge_of_inductive_knowing_parameters env ind [||] + let t,cst = Inductive.constrained_type_of_inductive env ((mib,mip),u) in + check_constraints cst env; + (make_judge c t) (* Constructors. *) -let judge_of_constructor env c = - let constr = mkConstruct c in +let judge_of_constructor env (c,u as cu) = + let constr = mkConstructU cu in let _ = let ((kn,_),_) = c in let mib = lookup_mind kn env in check_hyps_inclusion env constr mib.mind_hyps in let specif = lookup_mind_specif env (inductive_of_constructor c) in - make_judge constr (type_of_constructor c specif) + let t,cst = constrained_type_of_constructor cu specif in + let () = check_constraints cst env in + (make_judge constr t) (* Case. *) -let check_branch_types env ind cj (lfj,explft) = +let check_branch_types env (ind,u) cj (lfj,explft) = try conv_leq_vecti env (Array.map j_type lfj) explft with NotConvertibleVect i -> - error_ill_formed_branch env cj.uj_val (ind,i+1) lfj.(i).uj_type explft.(i) + error_ill_formed_branch env cj.uj_val ((ind,i+1),u) lfj.(i).uj_type explft.(i) | Invalid_argument _ -> error_number_branches env cj (Array.length explft) let judge_of_case env ci pj cj lfj = - let indspec = + let (pind, _ as indspec) = try find_rectype env cj.uj_type with Not_found -> error_case_not_inductive env cj in - let _ = check_case_info env (fst indspec) ci in - let (bty,rslty,univ) = + let _ = check_case_info env pind ci in + let (bty,rslty) = type_case_branches env indspec pj cj.uj_val in - let univ' = check_branch_types env (fst indspec) cj (lfj,bty) in + let () = check_branch_types env pind cj (lfj,bty) in ({ uj_val = mkCase (ci, (*nf_betaiota*) pj.uj_val, cj.uj_val, Array.map j_val lfj); - uj_type = rslty }, - union_constraints univ univ') + uj_type = rslty }) + +let judge_of_projection env p cj = + let pb = lookup_projection p env in + let (ind,u), args = + try find_rectype env cj.uj_type + with Not_found -> error_case_not_inductive env cj + in + assert(eq_mind pb.proj_ind (fst ind)); + let usubst = make_inductive_subst (fst (lookup_mind_specif env ind)) u in + let ty = Vars.subst_univs_constr usubst pb.Declarations.proj_type in + let ty = substl (cj.uj_val :: List.rev args) ty in + (* TODO: Universe polymorphism for projections *) + {uj_val = mkProj (p,cj.uj_val); + uj_type = ty} (* Fixpoints. *) @@ -352,104 +353,88 @@ let type_fixpoint env lna lar vdefj = (************************************************************************) (************************************************************************) -(* This combinator adds the universe constraints both in the local - graph and in the universes of the environment. This is to ensure - that the infered local graph is satisfiable. *) -let univ_combinator (cst,univ) (j,c') = - (j,(union_constraints cst c', merge_constraints c' univ)) - (* The typing machine. *) (* ATTENTION : faudra faire le typage du contexte des Const, Ind et Constructsi un jour cela devient des constructions arbitraires et non plus des variables *) -let rec execute env cstr cu = +let rec execute env cstr = match kind_of_term cstr with (* Atomic terms *) | Sort (Prop c) -> - (judge_of_prop_contents c, cu) - + judge_of_prop_contents c + | Sort (Type u) -> - (judge_of_type u, cu) + judge_of_type u | Rel n -> - (judge_of_relative env n, cu) + judge_of_relative env n | Var id -> - (judge_of_variable env id, cu) + judge_of_variable env id | Const c -> - (judge_of_constant env c, cu) + judge_of_constant env c + + | Proj (p, c) -> + let cj = execute env c in + judge_of_projection env p cj (* Lambda calculus operators *) | App (f,args) -> - let (jl,cu1) = execute_array env args cu in - let (j,cu2) = - match kind_of_term f with - | Ind ind -> - (* Sort-polymorphism of inductive types *) - judge_of_inductive_knowing_parameters env ind jl, cu1 - | Const cst -> - (* Sort-polymorphism of constant *) - judge_of_constant_knowing_parameters env cst jl, cu1 - | _ -> - (* No sort-polymorphism *) - execute env f cu1 - in - univ_combinator cu2 (judge_of_apply env j jl) + let jl = execute_array env args in + let j = execute env f in + judge_of_apply env j jl | Lambda (name,c1,c2) -> - let (varj,cu1) = execute_type env c1 cu in - let env1 = push_rel (name,None,varj.utj_val) env in - let (j',cu2) = execute env1 c2 cu1 in - (judge_of_abstraction env name varj j', cu2) + let varj = execute_type env c1 in + let env1 = push_rel (name,None,varj.utj_val) env in + let j' = execute env1 c2 in + judge_of_abstraction env name varj j' | Prod (name,c1,c2) -> - let (varj,cu1) = execute_type env c1 cu in - let env1 = push_rel (name,None,varj.utj_val) env in - let (varj',cu2) = execute_type env1 c2 cu1 in - (judge_of_product env name varj varj', cu2) + let varj = execute_type env c1 in + let env1 = push_rel (name,None,varj.utj_val) env in + let varj' = execute_type env1 c2 in + judge_of_product env name varj varj' | LetIn (name,c1,c2,c3) -> - let (j1,cu1) = execute env c1 cu in - let (j2,cu2) = execute_type env c2 cu1 in - let (_,cu3) = - univ_combinator cu2 (judge_of_cast env j1 DEFAULTcast j2) in - let env1 = push_rel (name,Some j1.uj_val,j2.utj_val) env in - let (j',cu4) = execute env1 c3 cu3 in - (judge_of_letin env name j1 j2 j', cu4) + let j1 = execute env c1 in + let j2 = execute_type env c2 in + let _ = judge_of_cast env j1 DEFAULTcast j2 in + let env1 = push_rel (name,Some j1.uj_val,j2.utj_val) env in + let j' = execute env1 c3 in + judge_of_letin env name j1 j2 j' | Cast (c,k, t) -> - let (cj,cu1) = execute env c cu in - let (tj,cu2) = execute_type env t cu1 in - univ_combinator cu2 - (judge_of_cast env cj k tj) + let cj = execute env c in + let tj = execute_type env t in + judge_of_cast env cj k tj (* Inductive types *) | Ind ind -> - (judge_of_inductive env ind, cu) + judge_of_inductive env ind | Construct c -> - (judge_of_constructor env c, cu) + judge_of_constructor env c | Case (ci,p,c,lf) -> - let (cj,cu1) = execute env c cu in - let (pj,cu2) = execute env p cu1 in - let (lfj,cu3) = execute_array env lf cu2 in - univ_combinator cu3 - (judge_of_case env ci pj cj lfj) + let cj = execute env c in + let pj = execute env p in + let lfj = execute_array env lf in + judge_of_case env ci pj cj lfj | Fix ((vn,i as vni),recdef) -> - let ((fix_ty,recdef'),cu1) = execute_recdef env recdef i cu in - let fix = (vni,recdef') in + let (fix_ty,recdef') = execute_recdef env recdef i in + let fix = (vni,recdef') in check_fix env fix; - (make_judge (mkFix fix) fix_ty, cu1) - + make_judge (mkFix fix) fix_ty + | CoFix (i,recdef) -> - let ((fix_ty,recdef'),cu1) = execute_recdef env recdef i cu in - let cofix = (i,recdef') in + let (fix_ty,recdef') = execute_recdef env recdef i in + let cofix = (i,recdef') in check_cofix env cofix; - (make_judge (mkCoFix cofix) fix_ty, cu1) - + (make_judge (mkCoFix cofix) fix_ty) + (* Partial proofs: unsupported by the kernel *) | Meta _ -> anomaly (Pp.str "the kernel does not support metavariables") @@ -457,61 +442,53 @@ let rec execute env cstr cu = | Evar _ -> anomaly (Pp.str "the kernel does not support existential variables") -and execute_type env constr cu = - let (j,cu1) = execute env constr cu in - (type_judgment env j, cu1) +and execute_type env constr = + let j = execute env constr in + type_judgment env j -and execute_recdef env (names,lar,vdef) i cu = - let (larj,cu1) = execute_array env lar cu in +and execute_recdef env (names,lar,vdef) i = + let larj = execute_array env lar in let lara = Array.map (assumption_of_judgment env) larj in let env1 = push_rec_types (names,lara,vdef) env in - let (vdefj,cu2) = execute_array env1 vdef cu1 in + let vdefj = execute_array env1 vdef in let vdefv = Array.map j_val vdefj in - let cst = type_fixpoint env1 names lara vdefj in - univ_combinator cu2 - ((lara.(i),(names,lara,vdefv)),cst) + let () = type_fixpoint env1 names lara vdefj in + (lara.(i),(names,lara,vdefv)) -and execute_array env = Array.fold_map' (execute env) +and execute_array env = Array.map (execute env) (* Derived functions *) let infer env constr = - let (j,(cst,_)) = - execute env constr (empty_constraint, universes env) in - assert (eq_constr j.uj_val constr); - (j, cst) + let j = execute env constr in + assert (eq_constr j.uj_val constr); + j + +(* let infer_key = Profile.declare_profile "infer" *) +(* let infer = Profile.profile2 infer_key infer *) let infer_type env constr = - let (j,(cst,_)) = - execute_type env constr (empty_constraint, universes env) in - (j, cst) + let j = execute_type env constr in + j let infer_v env cv = - let (jv,(cst,_)) = - execute_array env cv (empty_constraint, universes env) in - (jv, cst) + let jv = execute_array env cv in + jv (* Typing of several terms. *) let infer_local_decl env id = function | LocalDef c -> - let (j,cst) = infer env c in - (Name id, Some j.uj_val, j.uj_type), cst + let j = infer env c in + (Name id, Some j.uj_val, j.uj_type) | LocalAssum c -> - let (j,cst) = infer env c in - (Name id, None, assumption_of_judgment env j), cst + let j = infer env c in + (Name id, None, assumption_of_judgment env j) let infer_local_decls env decls = let rec inferec env = function | (id, d) :: l -> - let env, l, cst1 = inferec env l in - let d, cst2 = infer_local_decl env id d in - push_rel d env, add_rel_decl d l, union_constraints cst1 cst2 - | [] -> env, empty_rel_context, empty_constraint in + let (env, l) = inferec env l in + let d = infer_local_decl env id d in + (push_rel d env, add_rel_decl d l) + | [] -> (env, empty_rel_context) in inferec env decls - -(* Exported typing functions *) - -let typing env c = - let (j,cst) = infer env c in - let _ = add_constraints cst env in - j diff --git a/kernel/typeops.mli b/kernel/typeops.mli index d6484e823..6bc1ce496 100644 --- a/kernel/typeops.mli +++ b/kernel/typeops.mli @@ -14,15 +14,21 @@ open Environ open Entries open Declarations -(** {6 Typing functions (not yet tagged as safe) } *) +(** {6 Typing functions (not yet tagged as safe) } -val infer : env -> constr -> unsafe_judgment * constraints -val infer_v : env -> constr array -> unsafe_judgment array * constraints -val infer_type : env -> types -> unsafe_type_judgment * constraints + They return unsafe judgments that are "in context" of a set of + (local) universe variables (the ones that appear in the term) + and associated constraints. In case of polymorphic definitions, + these variables and constraints will be generalized. + *) + + +val infer : env -> constr -> unsafe_judgment +val infer_v : env -> constr array -> unsafe_judgment array +val infer_type : env -> types -> unsafe_type_judgment val infer_local_decls : - env -> (Id.t * local_entry) list - -> env * rel_context * constraints + env -> (Id.t * local_entry) list -> (env * rel_context) (** {6 Basic operations of the typing machine. } *) @@ -45,21 +51,25 @@ val judge_of_relative : env -> int -> unsafe_judgment val judge_of_variable : env -> variable -> unsafe_judgment (** {6 type of a constant } *) -val judge_of_constant : env -> constant -> unsafe_judgment +val judge_of_constant : env -> constant puniverses -> unsafe_judgment + +(* val judge_of_constant_knowing_parameters : *) +(* env -> constant -> unsafe_judgment array -> unsafe_judgment *) -val judge_of_constant_knowing_parameters : - env -> constant -> unsafe_judgment array -> unsafe_judgment +val judge_of_projection : env -> Names.projection -> unsafe_judgment -> unsafe_judgment (** {6 Type of application. } *) val judge_of_apply : env -> unsafe_judgment -> unsafe_judgment array - -> unsafe_judgment * constraints + -> unsafe_judgment (** {6 Type of an abstraction. } *) val judge_of_abstraction : env -> Name.t -> unsafe_type_judgment -> unsafe_judgment -> unsafe_judgment +val sort_of_product : env -> sorts -> sorts -> sorts + (** {6 Type of a product. } *) val judge_of_product : env -> Name.t -> unsafe_type_judgment -> unsafe_type_judgment @@ -73,37 +83,35 @@ val judge_of_letin : (** {6 Type of a cast. } *) val judge_of_cast : env -> unsafe_judgment -> cast_kind -> unsafe_type_judgment -> - unsafe_judgment * constraints + unsafe_judgment (** {6 Inductive types. } *) -val judge_of_inductive : env -> inductive -> unsafe_judgment +val judge_of_inductive : env -> inductive puniverses -> unsafe_judgment -val judge_of_inductive_knowing_parameters : - env -> inductive -> unsafe_judgment array -> unsafe_judgment +(* val judge_of_inductive_knowing_parameters : *) +(* env -> inductive -> unsafe_judgment array -> unsafe_judgment *) -val judge_of_constructor : env -> constructor -> unsafe_judgment +val judge_of_constructor : env -> constructor puniverses -> unsafe_judgment (** {6 Type of Cases. } *) val judge_of_case : env -> case_info -> unsafe_judgment -> unsafe_judgment -> unsafe_judgment array - -> unsafe_judgment * constraints + -> unsafe_judgment (** Typecheck general fixpoint (not checking guard conditions) *) val type_fixpoint : env -> Name.t array -> types array - -> unsafe_judgment array -> constraints - -(** Kernel safe typing but applicable to partial proofs *) -val typing : env -> constr -> unsafe_judgment + -> unsafe_judgment array -> unit -val type_of_constant : env -> constant -> types +val type_of_constant : env -> constant puniverses -> types constrained val type_of_constant_type : env -> constant_type -> types +val type_of_projection : env -> Names.projection puniverses -> types + +val type_of_constant_in : env -> constant puniverses -> types + val type_of_constant_knowing_parameters : env -> constant_type -> types Lazy.t array -> types -(** Make a type polymorphic if an arity *) -val make_polymorphic_if_constant_for_ind : env -> unsafe_judgment -> - constant_type diff --git a/kernel/univ.ml b/kernel/univ.ml index 551d74043..8322a7e96 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -29,13 +29,56 @@ open Util union-find algorithm. The assertions $<$ and $\le$ are represented by adjacency lists *) -module UniverseLevel = struct +module Level = struct open Names type t = + | Prop | Set - | Level of int * DirPath.t + | Level of int * Names.DirPath.t + type _t = t + + (* Hash-consing *) + + module Hunivlevel = + Hashcons.Make( + struct + type t = _t + type u = Names.DirPath.t -> Names.DirPath.t + let hashcons hdir = function + | Prop as x -> x + | Set as x -> x + | Level (n,d) -> Level (n,hdir d) + let equal l1 l2 = + l1 == l2 || + match l1,l2 with + | Prop, Prop -> true + | Set, Set -> true + | Level (n,d), Level (n',d') -> + n == n' && d == d' + | _ -> false + let hash = Hashtbl.hash + end) + + let hcons = Hashcons.simple_hcons Hunivlevel.generate Names.DirPath.hcons + + let make m n = hcons (Level (n, m)) + + let set = hcons Set + let prop = hcons Prop + + let is_small = function + | Level _ -> false + | _ -> true + + let is_prop = function + | Prop -> true + | _ -> false + + let is_set = function + | Set -> true + | _ -> false (* A specialized comparison function: we compare the [int] part first. This way, most of the time, the [DirPath.t] part is not considered. @@ -49,6 +92,9 @@ module UniverseLevel = struct if u == v then 0 else (match u,v with + | Prop,Prop -> 0 + | Prop, _ -> -1 + | _, Prop -> 1 | Set, Set -> 0 | Set, _ -> -1 | _, Set -> 1 @@ -63,27 +109,385 @@ module UniverseLevel = struct Int.equal i1 i2 && DirPath.equal dp1 dp2 | _ -> false - let hash = function - | Set -> 0 - | Level (i, dp) -> - Hashset.Combine.combine (Int.hash i) (DirPath.hash dp) - - let make m n = Level (n, m) + let eq u v = u == v + let leq u v = compare u v <= 0 let to_string = function + | Prop -> "Prop" | Set -> "Set" - | Level (n,d) -> DirPath.to_string d^"."^string_of_int n + | Level (n,d) -> Names.DirPath.to_string d^"."^string_of_int n + + let pr u = str (to_string u) + + let apart u v = + match u, v with + | Prop, Set | Set, Prop -> true + | _ -> false + end -module UniverseLMap = Map.Make (UniverseLevel) -module UniverseLSet = Set.Make (UniverseLevel) +let pr_universe_level_list l = + prlist_with_sep spc Level.pr l + +module LSet = struct + module M = Set.Make (Level) + include M + + let pr s = + str"{" ++ pr_universe_level_list (elements s) ++ str"}" -type universe_level = UniverseLevel.t + let of_list l = + List.fold_left (fun acc x -> add x acc) empty l -let compare_levels = UniverseLevel.compare + let of_array l = + Array.fold_left (fun acc x -> add x acc) empty l +end + +module LMap = struct + module M = Map.Make (Level) + include M + + let union l r = + merge (fun k l r -> + match l, r with + | Some _, _ -> l + | _, _ -> r) l r + + let subst_union l r = + merge (fun k l r -> + match l, r with + | Some (Some _), _ -> l + | Some None, None -> l + | _, _ -> r) l r + + let diff ext orig = + fold (fun u v acc -> + if mem u orig then acc + else add u v acc) + ext empty + + let elements = bindings + let of_set s d = + LSet.fold (fun u -> add u d) s + empty + + let of_list l = + List.fold_left (fun m (u, v) -> add u v m) empty l + + let universes m = + fold (fun u _ acc -> LSet.add u acc) m LSet.empty + + let pr f m = + h 0 (prlist_with_sep fnl (fun (u, v) -> + Level.pr u ++ f v) (elements m)) + + let find_opt t m = + try Some (find t m) + with Not_found -> None +end + +type universe_level = Level.t + +module LList = struct + type t = Level.t list + type _t = t + module Huniverse_level_list = + Hashcons.Make( + struct + type t = _t + type u = universe_level -> universe_level + let hashcons huc s = + List.fold_right (fun x a -> huc x :: a) s [] + let equal s s' = List.for_all2eq (==) s s' + let hash = Hashtbl.hash + end) + + let hcons = + Hashcons.simple_hcons Huniverse_level_list.generate Level.hcons + + let empty = hcons [] + let eq l l' = l == l' || + (try List.for_all2 Level.eq l l' + with Invalid_argument _ -> false) + + let levels = + List.fold_left (fun s x -> LSet.add x s) LSet.empty + +end + +type universe_level_list = universe_level list + +type universe_level_subst_fn = universe_level -> universe_level + +type universe_set = LSet.t +type 'a universe_map = 'a LMap.t + +let compare_levels = Level.compare +let eq_levels = Level.eq + +module Hashconsing = struct + module Uid = struct + type t = int + + let make_maker () = + let _id = ref ~-1 in + ((fun () -> incr _id;!_id), + (fun () -> !_id), + (fun i -> _id := i)) + + let dummy = -1 + + external to_int : t -> int = "%identity" + + + external of_int : int -> t= "%identity" + end + + module Hcons = struct + + module type SA = + sig + type data + type t + val make : data -> t + val node : t -> data + val hash : t -> int + val uid : t -> Uid.t + val equal : t -> t -> bool + val stats : unit -> unit + val init : unit -> unit + end + + module type S = + sig + + type data + type t = private { id : Uid.t; + key : int; + node : data } + val make : data -> t + val node : t -> data + val hash : t -> int + val uid : t -> Uid.t + val equal : t -> t -> bool + val stats : unit -> unit + val init : unit -> unit + end + + module Make (H : Hashtbl.HashedType) : S with type data = H.t = + struct + let uid_make,uid_current,uid_set = Uid.make_maker() + type data = H.t + type t = { id : Uid.t; + key : int; + node : data } + let node t = t.node + let uid t = t.id + let hash t = t.key + let equal t1 t2 = t1 == t2 + module WH = Weak.Make( struct + type _t = t + type t = _t + let hash = hash + let equal a b = a == b || H.equal a.node b.node + end) + let pool = WH.create 491 + + exception Found of Uid.t + let total_count = ref 0 + let miss_count = ref 0 + let init () = + total_count := 0; + miss_count := 0 + + let make x = + incr total_count; + let cell = { id = Uid.dummy; key = H.hash x; node = x } in + try + WH.find pool cell + with + | Not_found -> + let cell = { cell with id = uid_make(); } in + incr miss_count; + WH.add pool cell; + cell + + exception Found of t + + let stats () = () + end + end + module HList = struct + + module type S = sig + type elt + type 'a node = Nil | Cons of elt * 'a + + module rec Node : + sig + include Hcons.S with type data = Data.t + end + and Data : sig + include Hashtbl.HashedType with type t = Node.t node + end + type data = Data.t + type t = Node.t + val hash : t -> int + val uid : t -> Uid.t + val make : data -> t + val equal : t -> t -> bool + val nil : t + val is_nil : t -> bool + val tip : elt -> t + val node : t -> t node + val cons : (* ?sorted:bool -> *) elt -> t -> t + val hd : t -> elt + val tl : t -> t + val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a + val map : (elt -> elt) -> t -> t + val iter : (elt -> 'a) -> t -> unit + val exists : (elt -> bool) -> t -> bool + val for_all : (elt -> bool) -> t -> bool + val rev : t -> t + val rev_map : (elt -> elt) -> t -> t + val length : t -> int + val mem : elt -> t -> bool + val remove : elt -> t -> t + val stats : unit -> unit + val init : unit -> unit + val to_list : t -> elt list + val compare : (elt -> elt -> int) -> t -> t -> int + end + + module Make (H : Hcons.SA) : S with type elt = H.t = + struct + type elt = H.t + type 'a node = Nil | Cons of elt * 'a + module rec Node : Hcons.S with type data = Data.t = Hcons.Make (Data) + and Data : Hashtbl.HashedType with type t = Node.t node = + struct + type t = Node.t node + let equal x y = + match x,y with + | _,_ when x==y -> true + | Cons (a,aa), Cons(b,bb) -> (aa==bb) && (H.equal a b) + | _ -> false + let hash = function + | Nil -> 0 + | Cons(a,aa) -> 17 + 65599 * (Uid.to_int (H.uid a)) + 491 * (Uid.to_int aa.Node.id) + end + + type data = Data.t + type t = Node.t + let make = Node.make + let node x = x.Node.node + let hash x = x.Node.key + let equal = Node.equal + let uid x= x.Node.id + let nil = Node.make Nil + let stats = Node.stats + let init = Node.init + + let is_nil = + function { Node.node = Nil } -> true | _ -> false + + (* doing sorted insertion allows to make + better use of hash consing *) + let rec sorted_cons e l = + match l.Node.node with + | Nil -> Node.make (Cons(e, l)) + | Cons (x, ll) -> + if H.uid e < H.uid x + then Node.make (Cons(e, l)) + else Node.make (Cons(x, sorted_cons e ll)) + + let cons e l = + Node.make(Cons(e, l)) + + let tip e = Node.make (Cons(e, nil)) + + (* let cons ?(sorted=true) e l = *) + (* if sorted then sorted_cons e l else cons e l *) + + let hd = function { Node.node = Cons(a,_) } -> a | _ -> failwith "hd" + let tl = function { Node.node = Cons(_,a) } -> a | _ -> failwith "tl" + + let fold f l acc = + let rec loop acc l = match l.Node.node with + | Nil -> acc + | Cons (a, aa) -> loop (f a acc) aa + in + loop acc l + + let map f l = + let rec loop l = match l.Node.node with + | Nil -> nil + | Cons(a, aa) -> cons (f a) (loop aa) + in + loop l + + let iter f l = + let rec loop l = match l.Node.node with + | Nil -> () + | Cons(a,aa) -> (f a);(loop aa) + in + loop l + + let exists f l = + let rec loop l = match l.Node.node with + | Nil -> false + | Cons(a,aa) -> f a || loop aa + in + loop l + + let for_all f l = + let rec loop l = match l.Node.node with + | Nil -> true + | Cons(a,aa) -> f a && loop aa + in + loop l + + let to_list l = + let rec loop l = match l.Node.node with + | Nil -> [] + | Cons(a,aa) -> a :: loop aa + in + loop l + + let remove x l = + let rec loop l = match l.Node.node with + | Nil -> l + | Cons(a,aa) -> + if H.equal a x then aa + else cons a (loop aa) + in + loop l + + let rev l = fold cons l nil + let rev_map f l = fold (fun x acc -> cons (f x) acc) l nil + let length l = fold (fun _ c -> c+1) l 0 + let rec mem e l = + match l.Node.node with + | Nil -> false + | Cons (x, ll) -> x == e || mem e ll + + let rec compare cmp l1 l2 = + if l1 == l2 then 0 else + match node l1, node l2 with + | Nil, Nil -> 0 + | _, Nil -> 1 + | Nil, _ -> -1 + | Cons (x1,l1), Cons(x2,l2) -> + (match cmp x1 x2 with + | 0 -> compare cmp l1 l2 + | c -> c) + + end + end +end (* An algebraic universe [universe] is either a universe variable - [UniverseLevel.t] or a formal universe known to be greater than some + [Level.t] or a formal universe known to be greater than some universe variables and strictly greater than some (other) universe variables @@ -96,158 +500,346 @@ let compare_levels = UniverseLevel.compare module Universe = struct - type t = - | Atom of UniverseLevel.t - | Max of UniverseLevel.t list * UniverseLevel.t list + (* Invariants: non empty, sorted and without duplicates *) + + module Expr = + struct + type t = Level.t * int + type _t = t + + (* Hashing of expressions *) + module ExprHash = + struct + type t = _t + type u = Level.t -> Level.t + let hashcons hdir (b,n as x) = + let b' = hdir b in + if b' == b then x else (b',n) + let equal l1 l2 = + l1 == l2 || + match l1,l2 with + | (b,n), (b',n') -> b == b' && n == n' + let hash = Hashtbl.hash + + end + + module HExpr = + struct + + include Hashcons.Make(ExprHash) + + type data = t + type node = t + + let make = + Hashcons.simple_hcons generate Level.hcons + external node : node -> data = "%identity" + let hash = ExprHash.hash + let uid = hash + let equal x y = x == y + let stats _ = () + let init _ = () + end + + let hcons = HExpr.make + + let make l = hcons (l, 0) + + let compare u v = + if u == v then 0 + else + let (x, n) = u and (x', n') = v in + if Int.equal n n' then Level.compare x x' + else n - n' + + let prop = make Level.prop + let set = make Level.set + let type1 = hcons (Level.set, 1) + + let is_prop = function + | (l,0) -> Level.is_prop l + | _ -> false + + let is_set = function + | (l,0) -> Level.is_set l + | _ -> false + + let is_type1 = function + | (l,1) -> Level.is_set l + | _ -> false + + let is_small = function + | (l, 0) -> Level.is_small l + | _ -> false + + (* let eq (u,n) (v,n') = *) + (* Int.equal n n' && Level.eq u v *) + let eq x y = x == y + + let leq (u,n) (v,n') = + let cmp = Level.compare u v in + if Int.equal cmp 0 then n <= n' + else if n <= n' then + (Level.is_prop u && Level.is_small v) + else false + + let successor (u,n) = + if Level.is_prop u then type1 + else hcons (u, n + 1) + + let addn k (u,n as x) = + if k = 0 then x + else if Level.is_prop u then + hcons (Level.set,n+k) + else hcons (u,n+k) + + let super (u,n as x) (v,n' as y) = + let cmp = Level.compare u v in + if Int.equal cmp 0 then + if n < n' then Inl true + else Inl false + else if is_prop x then Inl true + else if is_prop y then Inl false + else Inr cmp + + let to_string (v, n) = + if Int.equal n 0 then Level.to_string v + else Level.to_string v ^ "+" ^ string_of_int n + + let pr x = str(to_string x) + + let level = function + | (v,0) -> Some v + | _ -> None + + let get_level (v,n) = v + + let map f (v, n as x) = + let v' = f v in + if v' == v then x + else if Level.is_prop v' && n != 0 then + hcons (Level.set, n) + else hcons (v', n) + + end + + module Hunivelt = struct + let node x = x + let make x = x + end + + (* module Hunivelt = Hashconsing.Hcons.Make( *) + (* struct *) + (* type t = Expr.t *) + (* let equal l1 l2 = *) + (* l1 == l2 || *) + (* match l1,l2 with *) + (* | (b,n), (b',n') -> b == b' && n == n' *) + (* let hash = Hashtbl.hash *) + (* end) *) + + let compare_expr n m = Expr.compare (Hunivelt.node n) (Hunivelt.node m) + let pr_expr n = Expr.pr (Hunivelt.node n) + + module Huniv = Hashconsing.HList.Make(Expr.HExpr) + type t = Huniv.t + open Huniv + + let eq x y = x == y (* Huniv.equal *) let compare u1 u2 = - if u1 == u2 then 0 else - match u1, u2 with - | Atom l1, Atom l2 -> UniverseLevel.compare l1 l2 - | Max (lt1, le1), Max (lt2, le2) -> - let c = List.compare UniverseLevel.compare lt1 lt2 in - if Int.equal c 0 then - List.compare UniverseLevel.compare le1 le2 - else c - | Atom _, Max _ -> -1 - | Max _, Atom _ -> 1 - - let equal u1 u2 = Int.equal (compare u1 u2) 0 - - let make l = Atom l - - open Hashset.Combine - - let rec hash_list accu = function - | [] -> 0 - | u :: us -> - let accu = combine (UniverseLevel.hash u) accu in - hash_list accu us - - let hash = function - | Atom u -> combinesmall 1 (UniverseLevel.hash u) - | Max (lt, le) -> - let hlt = hash_list 0 lt in - let hle = hash_list 0 le in - combinesmall 2 (combine hlt hle) + if eq u1 u2 then 0 else + Huniv.compare compare_expr u1 u2 + + let hcons_unique = Huniv.make + let normalize x = x + (* let hcons_unique x = x *) + let hcons x = hcons_unique (normalize x) + + let make l = Huniv.tip (Hunivelt.make (Expr.make l)) + let tip x = Huniv.tip (Hunivelt.make x) + + let equal_universes x y = + x == y +(* then true *) +(* else *) +(* (\* Consider lists as sets, i.e. up to reordering, *) +(* they are already without duplicates thanks to normalization. *\) *) +(* CList.eq_set x' y' *) + + let pr l = match node l with + | Cons (u, n) when is_nil n -> Expr.pr (Hunivelt.node u) + | _ -> + str "max(" ++ hov 0 + (prlist_with_sep pr_comma Expr.pr (List.map Hunivelt.node (to_list l))) ++ + str ")" + + let atom l = match node l with + | Cons (l, n) when is_nil n -> Some l + | _ -> None + + let level l = match node l with + | Cons (l, n) when is_nil n -> Expr.level (Hunivelt.node l) + | _ -> None + + let levels l = + fold (fun x acc -> LSet.add (Expr.get_level (Hunivelt.node x)) acc) l LSet.empty + + let is_small u = + match level (normalize u) with + | Some l -> Level.is_small l + | _ -> false -end + (* The lower predicative level of the hierarchy that contains (impredicative) + Prop and singleton inductive types *) + let type0m = tip Expr.prop -open Universe + (* The level of sets *) + let type0 = tip Expr.set + + (* When typing [Prop] and [Set], there is no constraint on the level, + hence the definition of [type1_univ], the type of [Prop] *) + let type1 = tip (Expr.successor Expr.set) + + let is_type0m u = + match level u with + | Some l -> Level.is_prop l + | _ -> false + + let is_type0 u = + match level u with + | Some l -> Level.is_set l + | _ -> false + + let is_type1 u = + match node u with + | Cons (l, n) when is_nil n -> Expr.is_type1 (Hunivelt.node l) + | _ -> false + + (* Returns the formal universe that lies juste above the universe variable u. + Used to type the sort u. *) + let super l = + Huniv.map (fun x -> Hunivelt.make (Expr.successor (Hunivelt.node x))) l + + let addn n l = + Huniv.map (fun x -> Hunivelt.make (Expr.addn n (Hunivelt.node x))) l + + let rec merge_univs l1 l2 = + match node l1, node l2 with + | Nil, _ -> l2 + | _, Nil -> l1 + | Cons (h1, t1), Cons (h2, t2) -> + (match Expr.super (Hunivelt.node h1) (Hunivelt.node h2) with + | Inl true (* h1 < h2 *) -> merge_univs t1 l2 + | Inl false -> merge_univs l1 t2 + | Inr c -> + if c <= 0 (* h1 < h2 is name order *) + then cons h1 (merge_univs t1 l2) + else cons h2 (merge_univs l1 t2)) + + let sort u = + let rec aux a l = + match node l with + | Cons (b, l') -> + (match Expr.super (Hunivelt.node a) (Hunivelt.node b) with + | Inl false -> aux a l' + | Inl true -> l + | Inr c -> + if c <= 0 then cons a l + else cons b (aux a l')) + | Nil -> cons a l + in + fold (fun a acc -> aux a acc) u nil + + (* Returns the formal universe that is greater than the universes u and v. + Used to type the products. *) + let sup x y = merge_univs x y + + let of_list l = + List.fold_right + (fun x acc -> cons (Hunivelt.make x) acc) + l nil + + let empty = nil + let is_empty n = is_nil n + + let exists f l = + Huniv.exists (fun x -> f (Hunivelt.node x)) l + + let for_all f l = + Huniv.for_all (fun x -> f (Hunivelt.node x)) l + + let smartmap f l = + Huniv.map (fun x -> + let n = Hunivelt.node x in + let x' = f n in + if x' == n then x else Hunivelt.make x') + l + +end type universe = Universe.t -let universe_level = function - | Atom l -> Some l - | Max _ -> None +open Universe -let pr_uni_level u = str (UniverseLevel.to_string u) +(* type universe_list = UList.t *) +(* let pr_universe_list = UList.pr *) -let pr_uni = function - | Atom u -> - pr_uni_level u - | Max ([],[u]) -> - str "(" ++ pr_uni_level u ++ str ")+1" - | Max (gel,gtl) -> - let opt_sep = match gel, gtl with - | [], _ | _, [] -> mt () - | _ -> pr_comma () - in - str "max(" ++ hov 0 - (prlist_with_sep pr_comma pr_uni_level gel ++ opt_sep ++ - prlist_with_sep pr_comma - (fun x -> str "(" ++ pr_uni_level x ++ str ")+1") gtl) ++ - str ")" - -(* Returns the formal universe that lies juste above the universe variable u. - Used to type the sort u. *) -let super = function - | Atom u -> - Max ([],[u]) - | Max _ -> - anomaly (str "Cannot take the successor of a non variable universe" ++ spc () ++ - str "(maybe a bugged tactic)") - -(* Returns the formal universe that is greater than the universes u and v. - Used to type the products. *) -let sup u v = - match u,v with - | Atom u, Atom v -> - if UniverseLevel.equal u v then Atom u else Max ([u;v],[]) - | u, Max ([],[]) -> u - | Max ([],[]), v -> v - | Atom u, Max (gel,gtl) -> Max (List.add_set UniverseLevel.equal u gel,gtl) - | Max (gel,gtl), Atom v -> Max (List.add_set UniverseLevel.equal v gel,gtl) - | Max (gel,gtl), Max (gel',gtl') -> - let gel'' = List.union UniverseLevel.equal gel gel' in - let gtl'' = List.union UniverseLevel.equal gtl gtl' in - Max (List.subtract UniverseLevel.equal gel'' gtl'',gtl'') +let pr_uni = Universe.pr +let is_small_univ = Universe.is_small + +let universe_level = Universe.level (* Comparison on this type is pointer equality *) type canonical_arc = - { univ: UniverseLevel.t; - lt: UniverseLevel.t list; - le: UniverseLevel.t list; - rank: int } + { univ: Level.t; + lt: Level.t list; + le: Level.t list; + rank : int} let terminal u = {univ=u; lt=[]; le=[]; rank=0} -(* A UniverseLevel.t is either an alias for another one, or a canonical one, +(* A Level.t is either an alias for another one, or a canonical one, for which we know the universes that are above *) type univ_entry = Canonical of canonical_arc - | Equiv of UniverseLevel.t + | Equiv of Level.t -type universes = univ_entry UniverseLMap.t +type universes = univ_entry LMap.t let enter_equiv_arc u v g = - UniverseLMap.add u (Equiv v) g + LMap.add u (Equiv v) g let enter_arc ca g = - UniverseLMap.add ca.univ (Canonical ca) g - -(* The lower predicative level of the hierarchy that contains (impredicative) - Prop and singleton inductive types *) -let type0m_univ = Max ([],[]) + LMap.add ca.univ (Canonical ca) g -let is_type0m_univ = function - | Max ([],[]) -> true - | _ -> false +let is_type0m_univ = Universe.is_type0m (* The level of predicative Set *) -let type0_univ = Atom UniverseLevel.Set +let type0m_univ = Universe.type0m +let type0_univ = Universe.type0 +let type1_univ = Universe.type1 -let is_type0_univ = function - | Atom UniverseLevel.Set -> true - | Max ([UniverseLevel.Set], []) -> msg_warning (str "Non canonical Set"); true - | u -> false +let sup = Universe.sup +let super = Universe.super -let is_univ_variable = function - | Atom UniverseLevel.Set -> false - | Atom _ -> true - | _ -> false +let is_type0_univ = Universe.is_type0 -(* When typing [Prop] and [Set], there is no constraint on the level, - hence the definition of [type1_univ], the type of [Prop] *) +let is_univ_variable l = Universe.level l != None -let type1_univ = Max ([], [UniverseLevel.Set]) +(* Every Level.t has a unique canonical arc representative *) -let initial_universes = UniverseLMap.empty -let is_initial_universes = UniverseLMap.is_empty - -(* Every UniverseLevel.t has a unique canonical arc representative *) - -(* repr : universes -> UniverseLevel.t -> canonical_arc *) +(* repr : universes -> Level.t -> canonical_arc *) (* canonical representative : we follow the Equiv links *) let repr g u = let rec repr_rec u = let a = - try UniverseLMap.find u g + try LMap.find u g with Not_found -> anomaly ~label:"Univ.repr" - (str "Universe" ++ spc () ++ pr_uni_level u ++ spc () ++ str "undefined") + (str"Universe " ++ Level.pr u ++ str" undefined") in match a with | Equiv v -> repr_rec v @@ -262,7 +854,7 @@ let can g = List.map (repr g) let safe_repr g u = let rec safe_repr_rec u = - match UniverseLMap.find u g with + match LMap.find u g with | Equiv v -> safe_repr_rec v | Canonical arc -> arc in @@ -286,7 +878,7 @@ let reprleq g arcu = searchrec [] arcu.le -(* between : UniverseLevel.t -> canonical_arc -> canonical_arc list *) +(* between : Level.t -> canonical_arc -> canonical_arc list *) (* between u v = { w | u<=w<=v, w canonical } *) (* between is the most costly operation *) @@ -320,6 +912,7 @@ let between g arcu arcv = *) type constraint_type = Lt | Le | Eq + type explanation = (constraint_type * universe) list let constraint_type_ord c1 c2 = match c1, c2 with @@ -335,10 +928,10 @@ let constraint_type_ord c1 c2 = match c1, c2 with correspond to the universes in (direct) relation [rel] with it, make a list of canonical universe, updating the relation with the starting point (path stored in reverse order). *) -let canp g (p:explanation) rel l : (canonical_arc * explanation) list = - List.map (fun u -> (repr g u, (rel,Atom u)::p)) l +let canp g (p:explanation Lazy.t) rel l : (canonical_arc * explanation Lazy.t) list = + List.map (fun u -> (repr g u, lazy ((rel,Universe.make u):: Lazy.force p))) l -type order = EQ | LT of explanation | LE of explanation | NLE +type order = EQ | LT of explanation Lazy.t | LE of explanation Lazy.t | NLE (** [compare_neq] : is [arcv] in the transitive upward closure of [arcu] ? @@ -375,14 +968,14 @@ let compare_neq strict g arcu arcv = | [] -> cmp c (arc :: lt_done) le_done lt_todo le_todo | u :: lt -> let arc = repr g u in - let p = (Lt, Atom u) :: p in + let p = lazy ((Lt, make u) :: Lazy.force p) in if arc == arcv then if strict then LT p else LE p else find ((arc, p) :: lt_todo) lt le end | u :: le -> let arc = repr g u in - let p = (Le, Atom u) :: p in + let p = lazy ((Le, make u) :: Lazy.force p) in if arc == arcv then if strict then LT p else LE p else find ((arc, p) :: lt_todo) lt le @@ -402,21 +995,22 @@ let compare_neq strict g arcu arcv = let rec find lt_todo lt = match lt with | [] -> let fold accu u = - let node = (repr g u, (Le, Atom u) :: p) in + let p = lazy ((Le, make u) :: Lazy.force p) in + let node = (repr g u, p) in node :: accu in let le_new = List.fold_left fold le_todo arc.le in cmp c lt_done (arc :: le_done) lt_todo le_new | u :: lt -> let arc = repr g u in - let p = (Lt, Atom u) :: p in + let p = lazy ((Lt, make u) :: Lazy.force p) in if arc == arcv then if strict then LT p else LE p else find ((arc, p) :: lt_todo) lt in find [] arc.lt in - cmp NLE [] [] [] [arcu, []] + cmp NLE [] [] [] [arcu, Lazy.lazy_from_val []] let compare g arcu arcv = if arcu == arcv then EQ else compare_neq true g arcu arcv @@ -456,50 +1050,80 @@ let check_smaller g strict u v = if strict then is_lt g arcu arcv else - arcu == snd (safe_repr g UniverseLevel.Set) || is_leq g arcu arcv + arcu == snd (safe_repr g Level.prop) || is_leq g arcu arcv (** Then, checks on universes *) -type check_function = universes -> universe -> universe -> bool +type 'a check_function = universes -> 'a -> 'a -> bool + +(* let equiv_list cmp l1 l2 = *) +(* let rec aux l1 l2 = *) +(* match l1 with *) +(* | [] -> l2 = [] *) +(* | hd :: tl1 -> *) +(* let rec aux' acc = function *) +(* | hd' :: tl2 -> *) +(* if cmp hd hd' then aux tl1 (acc @ tl2) *) +(* else aux' (hd' :: acc) tl2 *) +(* | [] -> false *) +(* in aux' [] l2 *) +(* in aux l1 l2 *) let incl_list cmp l1 l2 = - List.for_all (fun x1 -> List.exists (fun x2 -> cmp x1 x2) l2) l1 + Huniv.for_all (fun x1 -> Huniv.exists (fun x2 -> cmp x1 x2) l2) l1 let compare_list cmp l1 l2 = - (l1 == l2) - || (incl_list cmp l1 l2 && incl_list cmp l2 l1) + (l1 == l2) || (* (equiv_list cmp l1 l2) *) + (incl_list cmp l1 l2 && incl_list cmp l2 l1) + +let check_equal_expr g x y = + x == y || (let (u, n) = Hunivelt.node x and (v, m) = Hunivelt.node y in + n = m && check_equal g u v) (** [check_eq] is also used in [Evd.set_eq_sort], hence [Evarconv] and [Unification]. In this case, it seems that the Atom/Max case may occur, hence a relaxed version. *) -let gen_check_eq strict g u v = - match u,v with - | Atom ul, Atom vl -> check_equal g ul vl - | Max(ule,ult), Max(vle,vlt) -> - (* TODO: remove elements of lt in le! *) - compare_list (check_equal g) ule vle && - compare_list (check_equal g) ult vlt - | _ -> - (* not complete! (Atom(u) = Max([u],[]) *) - if strict then anomaly (str "check_eq") - else false (* in non-strict mode, under-approximation *) - -let check_eq = gen_check_eq true -let lax_check_eq = gen_check_eq false +(* let gen_check_eq strict g u v = *) +(* match u,v with *) +(* | Atom ul, Atom vl -> check_equal g ul vl *) +(* | Max(ule,ult), Max(vle,vlt) -> *) +(* (\* TODO: remove elements of lt in le! *\) *) +(* compare_list (check_equal g) ule vle && *) +(* compare_list (check_equal g) ult vlt *) +(* | _ -> *) +(* (\* not complete! (Atom(u) = Max([u],[]) *\) *) +(* if strict then anomaly (str "check_eq") *) +(* else false (\* in non-strict mode, under-approximation *\) *) + +(* let check_eq = gen_check_eq true *) +(* let lax_check_eq = gen_check_eq false *) +let check_eq g u v = + compare_list (check_equal_expr g) u v +let check_eq_level g u v = u == v || check_equal g u v +let lax_check_eq = check_eq + +let check_smaller_expr g (u,n) (v,m) = + if n <= m then + check_smaller g false u v + else if n - m = 1 then + check_smaller g true u v + else false + +let exists_bigger g ul l = + Huniv.exists (fun ul' -> + check_smaller_expr g (Hunivelt.node ul) (Hunivelt.node ul')) l let check_leq g u v = - match u,v with - | Atom ul, Atom vl -> check_smaller g false ul vl - | Max(le,lt), Atom vl -> - List.for_all (fun ul -> check_smaller g false ul vl) le && - List.for_all (fun ul -> check_smaller g true ul vl) lt - | _ -> anomaly (str "check_leq") + u == v || + match Universe.level u with + | Some l when Level.is_prop l -> true + | _ -> Huniv.for_all (fun ul -> exists_bigger g ul v) u (** Enforcing new constraints : [setlt], [setleq], [merge], [merge_disc] *) -(* setlt : UniverseLevel.t -> UniverseLevel.t -> reason -> unit *) +(* setlt : Level.t -> Level.t -> reason -> unit *) (* forces u > v *) (* this is normally an update of u in g rather than a creation. *) let setlt g arcu arcv = @@ -512,7 +1136,7 @@ let setlt_if (g,arcu) v = if is_lt g arcu arcv then g, arcu else setlt g arcu arcv -(* setleq : UniverseLevel.t -> UniverseLevel.t -> unit *) +(* setleq : Level.t -> Level.t -> unit *) (* forces u >= v *) (* this is normally an update of u in g rather than a creation. *) let setleq g arcu arcv = @@ -526,7 +1150,7 @@ let setleq_if (g,arcu) v = if is_leq g arcu arcv then g, arcu else setleq g arcu arcv -(* merge : UniverseLevel.t -> UniverseLevel.t -> unit *) +(* merge : Level.t -> Level.t -> unit *) (* we assume compare(u,v) = LE *) (* merge u v forces u ~ v with repr u as canonical repr *) let merge g arcu arcv = @@ -559,7 +1183,7 @@ let merge g arcu arcv = let g_arcu = List.fold_left setleq_if g_arcu w' in fst g_arcu -(* merge_disc : UniverseLevel.t -> UniverseLevel.t -> unit *) +(* merge_disc : Level.t -> Level.t -> unit *) (* we assume compare(u,v) = compare(v,u) = NLE *) (* merge_disc u v forces u ~ v with repr u as canonical repr *) let merge_disc g arc1 arc2 = @@ -579,36 +1203,37 @@ let merge_disc g arc1 arc2 = (* Universe inconsistency: error raised when trying to enforce a relation that would create a cycle in the graph of universes. *) -exception UniverseInconsistency of - constraint_type * universe * universe * explanation +type univ_inconsistency = constraint_type * universe * universe * explanation + +exception UniverseInconsistency of univ_inconsistency let error_inconsistency o u v (p:explanation) = - raise (UniverseInconsistency (o,Atom u,Atom v,p)) + raise (UniverseInconsistency (o,make u,make v,p)) -(* enforce_univ_leq : UniverseLevel.t -> UniverseLevel.t -> unit *) +(* enforce_univ_leq : Level.t -> Level.t -> unit *) (* enforce_univ_leq u v will force u<=v if possible, will fail otherwise *) let enforce_univ_leq u v g = let g,arcu = safe_repr g u in let g,arcv = safe_repr g v in if is_leq g arcu arcv then g else match compare g arcv arcu with - | LT p -> error_inconsistency Le u v (List.rev p) + | LT p -> error_inconsistency Le u v (List.rev (Lazy.force p)) | LE _ -> merge g arcv arcu | NLE -> fst (setleq g arcu arcv) | EQ -> anomaly (Pp.str "Univ.compare") -(* enforc_univ_eq : UniverseLevel.t -> UniverseLevel.t -> unit *) +(* enforc_univ_eq : Level.t -> Level.t -> unit *) (* enforc_univ_eq u v will force u=v if possible, will fail otherwise *) let enforce_univ_eq u v g = let g,arcu = safe_repr g u in let g,arcv = safe_repr g v in match compare g arcu arcv with | EQ -> g - | LT p -> error_inconsistency Eq u v (List.rev p) + | LT p -> error_inconsistency Eq v u (List.rev (Lazy.force p)) | LE _ -> merge g arcu arcv | NLE -> (match compare g arcv arcu with - | LT p -> error_inconsistency Eq u v (List.rev p) + | LT p -> error_inconsistency Eq u v (List.rev (Lazy.force p)) | LE _ -> merge g arcv arcu | NLE -> merge_disc g arcu arcv | EQ -> anomaly (Pp.str "Univ.compare")) @@ -620,16 +1245,20 @@ let enforce_univ_lt u v g = match compare g arcu arcv with | LT _ -> g | LE _ -> fst (setlt g arcu arcv) - | EQ -> error_inconsistency Lt u v [(Eq,Atom v)] + | EQ -> error_inconsistency Lt u v [(Eq,make v)] | NLE -> (match compare_neq false g arcv arcu with NLE -> fst (setlt g arcu arcv) | EQ -> anomaly (Pp.str "Univ.compare") - | (LE p|LT p) -> error_inconsistency Lt u v (List.rev p)) + | (LE p|LT p) -> error_inconsistency Lt u v (List.rev (Lazy.force p))) -(* Constraints and sets of consrtaints. *) +let empty_universes = LMap.empty +let initial_universes = enforce_univ_lt Level.prop Level.set LMap.empty +let is_initial_universes g = LMap.equal (==) g initial_universes -type univ_constraint = UniverseLevel.t * constraint_type * UniverseLevel.t +(* Constraints and sets of constraints. *) + +type univ_constraint = Level.t * constraint_type * Level.t let enforce_constraint cst g = match cst with @@ -637,6 +1266,14 @@ let enforce_constraint cst g = | (u,Le,v) -> enforce_univ_leq u v g | (u,Eq,v) -> enforce_univ_eq u v g +let pr_constraint_type op = + let op_str = match op with + | Lt -> " < " + | Le -> " <= " + | Eq -> " = " + in str op_str + + module UConstraintOrd = struct type t = univ_constraint @@ -644,51 +1281,566 @@ struct let i = constraint_type_ord c c' in if not (Int.equal i 0) then i else - let i' = UniverseLevel.compare u u' in + let i' = Level.compare u u' in if not (Int.equal i' 0) then i' - else UniverseLevel.compare v v' + else Level.compare v v' end -module Constraint = Set.Make(UConstraintOrd) +module Constraint = +struct + module S = Set.Make(UConstraintOrd) + include S -type constraints = Constraint.t + let pr c = + fold (fun (u1,op,u2) pp_std -> + pp_std ++ Level.pr u1 ++ pr_constraint_type op ++ + Level.pr u2 ++ fnl () ) c (str "") + +end let empty_constraint = Constraint.empty let is_empty_constraint = Constraint.is_empty +let union_constraint = Constraint.union let eq_constraint = Constraint.equal -let union_constraints = Constraint.union +type constraints = Constraint.t + +module Hconstraint = + Hashcons.Make( + struct + type t = univ_constraint + type u = universe_level -> universe_level + let hashcons hul (l1,k,l2) = (hul l1, k, hul l2) + let equal (l1,k,l2) (l1',k',l2') = + l1 == l1' && k == k' && l2 == l2' + let hash = Hashtbl.hash + end) + +module Hconstraints = + Hashcons.Make( + struct + type t = constraints + type u = univ_constraint -> univ_constraint + let hashcons huc s = + Constraint.fold (fun x -> Constraint.add (huc x)) s Constraint.empty + let equal s s' = + List.for_all2eq (==) + (Constraint.elements s) + (Constraint.elements s') + let hash = Hashtbl.hash + end) + +let hcons_constraint = Hashcons.simple_hcons Hconstraint.generate Level.hcons +let hcons_constraints = Hashcons.simple_hcons Hconstraints.generate hcons_constraint + +type universe_constraint_type = ULe | UEq | ULub + +type universe_constraint = universe * universe_constraint_type * universe +module UniverseConstraints = struct + module S = Set.Make( + struct + type t = universe_constraint + + let compare_type c c' = + match c, c' with + | ULe, ULe -> 0 + | ULe, _ -> -1 + | _, ULe -> 1 + | UEq, UEq -> 0 + | UEq, _ -> -1 + | ULub, ULub -> 0 + | ULub, _ -> 1 + + let compare (u,c,v) (u',c',v') = + let i = compare_type c c' in + if Int.equal i 0 then + let i' = Universe.compare u u' in + if Int.equal i' 0 then Universe.compare v v' + else + if c != ULe && Universe.compare u v' = 0 && Universe.compare v u' = 0 then 0 + else i' + else i + end) + + include S + + let add (l,d,r as cst) s = + if Universe.eq l r then s + else add cst s + + let tr_dir = function + | ULe -> Le + | UEq -> Eq + | ULub -> Eq + + let op_str = function ULe -> " <= " | UEq -> " = " | ULub -> " /\\ " + + let pr c = + fold (fun (u1,op,u2) pp_std -> + pp_std ++ Universe.pr u1 ++ str (op_str op) ++ + Universe.pr u2 ++ fnl ()) c (str "") + + let equal x y = + x == y || equal x y -type constraint_function = - universe -> universe -> constraints -> constraints +end + +type universe_constraints = UniverseConstraints.t +type 'a universe_constrained = 'a * universe_constraints + +(** A value with universe constraints. *) +type 'a constrained = 'a * constraints + +let level_subst_of f = + fun l -> + try let u = f l in + match Universe.level u with + | None -> l + | Some l -> l + with Not_found -> l + +module Instance = struct + type t = Level.t array + + module HInstance = + Hashcons.Make( + struct + type _t = t + type t = _t + type u = Level.t -> Level.t + let hashcons huniv a = + CArray.smartmap huniv a + + let equal t1 t2 = + t1 == t2 || + (Int.equal (Array.length t1) (Array.length t2) && + let rec aux i = + (Int.equal i (Array.length t1)) || (t1.(i) == t2.(i) && aux (i + 1)) + in aux 0) + + let hash = Hashtbl.hash + end) + + let hcons_instance = Hashcons.simple_hcons HInstance.generate Level.hcons + + let hcons = hcons_instance + let empty = [||] + let is_empty x = Int.equal (Array.length x) 0 + + let eq t u = t == u || CArray.for_all2 Level.eq t u + + let of_array a = a + let to_array a = a + + let eqeq t1 t2 = + t1 == t2 || + (Int.equal (Array.length t1) (Array.length t2) && + let rec aux i = + (Int.equal i (Array.length t1)) || (t1.(i) == t2.(i) && aux (i + 1)) + in aux 0) + + let subst_fn fn t = CArray.smartmap fn t + let subst s t = CArray.smartmap (fun x -> try LMap.find x s with Not_found -> x) t + + let levels x = LSet.of_array x + + let pr = + prvect_with_sep spc Level.pr + + let append x y = + if Array.length x = 0 then y + else if Array.length y = 0 then x + else Array.append x y + + let max_level i = + if Array.is_empty i then 0 + else + let l = CArray.last i in + match l with + | Level.Level (i,_) -> i + | _ -> assert false + + let check_eq g t1 t2 = + t1 == t2 || + (Int.equal (Array.length t1) (Array.length t2) && + let rec aux i = + (Int.equal i (Array.length t1)) || (check_eq_level g t1.(i) t2.(i) && aux (i + 1)) + in aux 0) + +end + +type universe_instance = Instance.t + +type 'a puniverses = 'a * Instance.t +let out_punivs (x, y) = x +let in_punivs x = (x, Instance.empty) + +(** A context of universe levels with universe constraints, + representiong local universe variables and constraints *) + +module UContext = +struct + type t = Instance.t constrained + + let make x = x + + (** Universe contexts (variables as a list) *) + let empty = (Instance.empty, Constraint.empty) + let is_empty (univs, cst) = Instance.is_empty univs && Constraint.is_empty cst + + let pr (univs, cst as ctx) = + if is_empty ctx then mt() else + Instance.pr univs ++ str " |= " ++ v 1 (Constraint.pr cst) + + let hcons (univs, cst) = + (Instance.hcons univs, hcons_constraints cst) + + let instance (univs, cst) = univs + let constraints (univs, cst) = cst + + let union (univs, cst) (univs', cst') = + Instance.append univs univs', Constraint.union cst cst' +end + +type universe_context = UContext.t +let hcons_universe_context = UContext.hcons + +(** A set of universes with universe constraints. + We linearize the set to a list after typechecking. + Beware, representation could change. +*) + +module ContextSet = +struct + type t = universe_set constrained + + let empty = (LSet.empty, Constraint.empty) + let is_empty (univs, cst) = LSet.is_empty univs && Constraint.is_empty cst + + let of_context (ctx,cst) = + (Instance.levels ctx, cst) + + let of_set s = (s, Constraint.empty) + let singleton l = of_set (LSet.singleton l) + let of_instance i = of_set (Instance.levels i) + + let union (univs, cst) (univs', cst') = + LSet.union univs univs', Constraint.union cst cst' + + let diff (univs, cst) (univs', cst') = + LSet.diff univs univs', Constraint.diff cst cst' + + let add_constraints (univs, cst) cst' = + univs, Constraint.union cst cst' + + let add_universes univs ctx = + union (of_instance univs) ctx + + let to_context (ctx, cst) = + (Array.of_list (LSet.elements ctx), cst) + + let of_context (ctx, cst) = + (Instance.levels ctx, cst) + + let pr (univs, cst as ctx) = + if is_empty ctx then mt() else + LSet.pr univs ++ str " |= " ++ v 1 (Constraint.pr cst) + + let constraints (univs, cst) = cst + let levels (univs, cst) = univs + +end + +type universe_context_set = ContextSet.t + +(** A value in a universe context (resp. context set). *) +type 'a in_universe_context = 'a * universe_context +type 'a in_universe_context_set = 'a * universe_context_set + +(** A universe level substitution, note that no algebraic universes are + involved *) +type universe_level_subst = universe_level universe_map + +(** A full substitution might involve algebraic universes *) +type universe_subst = universe universe_map + +(** Pretty-printing *) +let pr_constraints = Constraint.pr + +let pr_universe_context = UContext.pr + +let pr_universe_context_set = ContextSet.pr + +let pr_universe_subst = + LMap.pr (fun u -> str" := " ++ Universe.pr u ++ spc ()) + +let pr_universe_level_subst = + LMap.pr (fun u -> str" := " ++ Level.pr u ++ spc ()) + +let constraints_of (_, cst) = cst + +let constraint_depend (l,d,r) u = + Level.eq l u || Level.eq l r + +let constraint_depend_list (l,d,r) us = + List.mem l us || List.mem r us + +let constraints_depend cstr us = + Constraint.exists (fun c -> constraint_depend_list c us) cstr + +let remove_dangling_constraints dangling cst = + Constraint.fold (fun (l,d,r as cstr) cst' -> + if List.mem l dangling || List.mem r dangling then cst' + else + (** Unnecessary constraints Prop <= u *) + if Level.eq l Level.prop && d == Le then cst' + else Constraint.add cstr cst') cst Constraint.empty + +let check_context_subset (univs, cst) (univs', cst') = + let newunivs, dangling = List.partition (fun u -> LSet.mem u univs) (Array.to_list univs') in + (* Some universe variables that don't appear in the term + are still mentionned in the constraints. This is the + case for "fake" universe variables that correspond to +1s. *) + (* if not (CList.is_empty dangling) then *) + (* todo ("A non-empty set of inferred universes do not appear in the term or type"); *) + (* (not (constraints_depend cst' dangling));*) + (* TODO: check implication *) + (** Remove local universes that do not appear in any constraint, they + are really entirely parametric. *) + (* let newunivs, dangling' = List.partition (fun u -> constraints_depend cst [u]) newunivs in *) + let cst' = remove_dangling_constraints dangling cst in + Array.of_list newunivs, cst' + +(** Substitutions. *) + +let make_universe_subst inst (ctx, csts) = + try Array.fold_left2 (fun acc c i -> LMap.add c (Universe.make i) acc) + LMap.empty ctx inst + with Invalid_argument _ -> + anomaly (Pp.str "Mismatched instance and context when building universe substitution") + +let empty_subst = LMap.empty +let is_empty_subst = LMap.is_empty + +let empty_level_subst = LMap.empty +let is_empty_level_subst = LMap.is_empty + +(** Substitution functions *) + +(** With level to level substitutions. *) +let subst_univs_level_level subst l = + try LMap.find l subst + with Not_found -> l + +let rec normalize_univs_level_level subst l = + try + let l' = LMap.find l subst in + normalize_univs_level_level subst l' + with Not_found -> l + +let subst_univs_level_fail subst l = + try match Universe.level (subst l) with + | Some l' -> l' + | None -> l + with Not_found -> l + +let rec subst_univs_level_universe subst u = + let u' = Universe.smartmap (Universe.Expr.map (subst_univs_level_level subst)) u in + if u == u' then u + else Universe.sort u' + +let subst_univs_level_constraint subst (u,d,v) = + let u' = subst_univs_level_level subst u + and v' = subst_univs_level_level subst v in + if d != Lt && Level.eq u' v' then None + else Some (u',d,v') + +let subst_univs_level_constraints subst csts = + Constraint.fold + (fun c -> Option.fold_right Constraint.add (subst_univs_level_constraint subst c)) + csts Constraint.empty + +(* let subst_univs_level_constraint_key = Profile.declare_profile "subst_univs_level_constraint";; *) +(* let subst_univs_level_constraint = *) +(* Profile.profile2 subst_univs_level_constraint_key subst_univs_level_constraint *) + +(** With level to universe substitutions. *) +type universe_subst_fn = universe_level -> universe + +let make_subst subst = fun l -> LMap.find l subst + +let subst_univs_level fn l = + try fn l + with Not_found -> make l + +let subst_univs_expr_opt fn (l,n) = + try Some (Universe.addn n (fn l)) + with Not_found -> None + +let subst_univs_universe fn ul = + let subst, nosubst = + Universe.Huniv.fold (fun u (subst,nosubst) -> + match subst_univs_expr_opt fn (Hunivelt.node u) with + | Some a' -> (a' :: subst, nosubst) + | None -> (subst, u :: nosubst)) + ul ([], []) + in + if CList.is_empty subst then ul + else + let substs = + List.fold_left Universe.merge_univs Universe.empty subst + in + List.fold_left (fun acc u -> Universe.merge_univs acc (Universe.Huniv.tip u)) + substs nosubst + +let subst_univs_constraint fn (u,d,v) = + let u' = subst_univs_level fn u and v' = subst_univs_level fn v in + if d != Lt && Universe.eq u' v' then None + else Some (u',d,v') + +let subst_univs_universe_constraint fn (u,d,v) = + let u' = subst_univs_universe fn u and v' = subst_univs_universe fn v in + if Universe.eq u' v' then None + else Some (u',d,v') + +(** Constraint functions. *) + +type 'a constraint_function = 'a -> 'a -> constraints -> constraints let constraint_add_leq v u c = - (* We just discard trivial constraints like Set<=u or u<=u *) - if UniverseLevel.equal v UniverseLevel.Set || UniverseLevel.equal v u then c - else Constraint.add (v,Le,u) c + (* We just discard trivial constraints like u<=u *) + if Expr.eq v u then c + else + match v, u with + | (x,n), (y,m) -> + let j = m - n in + if j = -1 (* n = m+1, v+1 <= u <-> v < u *) then + Constraint.add (x,Lt,y) c + else if j <= -1 (* n = m+k, v+k <= u <-> v+(k-1) < u *) then + if Level.eq x y then (* u+(k+1) <= u *) + raise (UniverseInconsistency (Le, Universe.tip v, Universe.tip u, [])) + else anomaly (Pp.str"Unable to handle arbitrary u+k <= v constraints") + else if j = 0 then + Constraint.add (x,Le,y) c + else (* j >= 1 *) (* m = n + k, u <= v+k *) + if Level.eq x y then c (* u <= u+k, trivial *) + else if Level.is_small x then c (* Prop,Set <= u+S k, trivial *) + else anomaly (Pp.str"Unable to handle arbitrary u <= v+k constraints") + +let check_univ_eq u v = Universe.eq u v + +let check_univ_leq_one u v = Universe.exists (Expr.leq u) v + +let check_univ_leq u v = + Universe.for_all (fun u -> check_univ_leq_one u v) u let enforce_leq u v c = - match u, v with - | Atom u, Atom v -> constraint_add_leq u v c - | Max (gel,gtl), Atom v -> - let d = List.fold_right (fun u -> constraint_add_leq u v) gel c in - List.fold_right (fun u -> Constraint.add (u,Lt,v)) gtl d - | _ -> anomaly (Pp.str "A universe bound can only be a variable") + match Huniv.node v with + | Universe.Huniv.Cons (v, n) when Universe.is_empty n -> + Universe.Huniv.fold (fun u -> constraint_add_leq (Hunivelt.node u) (Hunivelt.node v)) u c + | _ -> anomaly (Pp.str"A universe bound can only be a variable") + +let enforce_leq u v c = + if check_univ_leq u v then c + else enforce_leq u v c + +let enforce_eq_level u v c = + (* We discard trivial constraints like u=u *) + if Level.eq u v then c + else if Level.apart u v then + error_inconsistency Eq u v [] + else Constraint.add (u,Eq,v) c let enforce_eq u v c = - match (u,v) with - | Atom u, Atom v -> - (* We discard trivial constraints like u=u *) - if UniverseLevel.equal u v then c else Constraint.add (u,Eq,v) c + match Universe.level u, Universe.level v with + | Some u, Some v -> enforce_eq_level u v c | _ -> anomaly (Pp.str "A universe comparison can only happen between variables") +let enforce_eq u v c = + if check_univ_eq u v then c + else enforce_eq u v c + +let enforce_leq_level u v c = + if Level.eq u v then c else Constraint.add (u,Le,v) c + +let enforce_eq_instances = CArray.fold_right2 enforce_eq_level + +type 'a universe_constraint_function = 'a -> 'a -> universe_constraints -> universe_constraints + +let enforce_eq_instances_univs strict t1 t2 c = + let d = if strict then ULub else UEq in + CArray.fold_right2 (fun x y -> UniverseConstraints.add (Universe.make x, d, Universe.make y)) + t1 t2 c + let merge_constraints c g = Constraint.fold enforce_constraint c g +(* let merge_constraints_key = Profile.declare_profile "merge_constraints";; *) +(* let merge_constraints = Profile.profile2 merge_constraints_key merge_constraints *) + +let check_constraint g (l,d,r) = + match d with + | Eq -> check_equal g l r + | Le -> check_smaller g false l r + | Lt -> check_smaller g true l r + +let check_constraints c g = + Constraint.for_all (check_constraint g) c + +(* let check_constraints_key = Profile.declare_profile "check_constraints";; *) +(* let check_constraints = *) +(* Profile.profile2 check_constraints_key check_constraints *) + +let enforce_univ_constraint (u,d,v) = + match d with + | Eq -> enforce_eq u v + | Le -> enforce_leq u v + | Lt -> enforce_leq (super u) v + +let subst_univs_constraints subst csts = + Constraint.fold + (fun c -> Option.fold_right enforce_univ_constraint (subst_univs_constraint subst c)) + csts Constraint.empty + +(* let subst_univs_constraints_key = Profile.declare_profile "subst_univs_constraints";; *) +(* let subst_univs_constraints = *) +(* Profile.profile2 subst_univs_constraints_key subst_univs_constraints *) + +let subst_univs_universe_constraints subst csts = + UniverseConstraints.fold + (fun c -> Option.fold_right UniverseConstraints.add (subst_univs_universe_constraint subst c)) + csts UniverseConstraints.empty + +(* let subst_univs_universe_constraints_key = Profile.declare_profile "subst_univs_universe_constraints";; *) +(* let subst_univs_universe_constraints = *) +(* Profile.profile2 subst_univs_universe_constraints_key subst_univs_universe_constraints *) + +(** Substitute instance inst for ctx in csts *) +let instantiate_univ_context subst (_, csts) = + subst_univs_constraints (make_subst subst) csts + +let check_consistent_constraints (ctx,cstrs) cstrs' = + (* TODO *) () + +let to_constraints g s = + let rec tr (x,d,y) acc = + let add l d l' acc = Constraint.add (l,UniverseConstraints.tr_dir d,l') acc in + match Universe.level x, d, Universe.level y with + | Some l, (ULe | UEq | ULub), Some l' -> add l d l' acc + | _, ULe, Some l' -> enforce_leq x y acc + | _, ULub, _ -> acc + | _, d, _ -> + let f = if d == ULe then check_leq else check_eq in + if f g x y then acc else + raise (Invalid_argument + "to_constraints: non-trivial algebraic constraint between universes") + in UniverseConstraints.fold tr s Constraint.empty + + (* Normalization *) let lookup_level u g = - try Some (UniverseLMap.find u g) with Not_found -> None + try Some (LMap.find u g) with Not_found -> None (** [normalize_universes g] returns a graph where all edges point directly to the canonical representent of their target. The output @@ -702,20 +1854,20 @@ let normalize_universes g = | Some x -> x, cache | None -> match Lazy.force arc with | None -> - u, UniverseLMap.add u u cache + u, LMap.add u u cache | Some (Canonical {univ=v; lt=_; le=_}) -> - v, UniverseLMap.add u v cache + v, LMap.add u v cache | Some (Equiv v) -> let v, cache = visit v (lazy (lookup_level v g)) cache in - v, UniverseLMap.add u v cache + v, LMap.add u v cache in - let cache = UniverseLMap.fold + let cache = LMap.fold (fun u arc cache -> snd (visit u (Lazy.lazy_from_val (Some arc)) cache)) - g UniverseLMap.empty + g LMap.empty in - let repr x = UniverseLMap.find x cache in + let repr x = LMap.find x cache in let lrepr us = List.fold_left - (fun e x -> UniverseLSet.add (repr x) e) UniverseLSet.empty us + (fun e x -> LSet.add (repr x) e) LSet.empty us in let canonicalize u = function | Equiv _ -> Equiv (repr u) @@ -723,24 +1875,24 @@ let normalize_universes g = assert (u == v); (* avoid duplicates and self-loops *) let lt = lrepr lt and le = lrepr le in - let le = UniverseLSet.filter - (fun x -> x != u && not (UniverseLSet.mem x lt)) le + let le = LSet.filter + (fun x -> x != u && not (LSet.mem x lt)) le in - UniverseLSet.iter (fun x -> assert (x != u)) lt; + LSet.iter (fun x -> assert (x != u)) lt; Canonical { univ = v; - lt = UniverseLSet.elements lt; - le = UniverseLSet.elements le; + lt = LSet.elements lt; + le = LSet.elements le; rank = rank } in - UniverseLMap.mapi canonicalize g + LMap.mapi canonicalize g (** [check_sorted g sorted]: [g] being a universe graph, [sorted] being a map to levels, checks that all constraints in [g] are satisfied in [sorted]. *) let check_sorted g sorted = - let get u = try UniverseLMap.find u sorted with + let get u = try LMap.find u sorted with | Not_found -> assert false in let iter u arc = @@ -751,7 +1903,7 @@ let check_sorted g sorted = List.iter (fun v -> assert (lu <= get v)) le; List.iter (fun v -> assert (lu < get v)) lt in - UniverseLMap.iter iter g + LMap.iter iter g (** Bellman-Ford algorithm with a few customizations: @@ -765,7 +1917,7 @@ let bellman_ford bottom g = | None -> () | Some _ -> assert false in - let ( << ) a b = match a, b with + let ( <? ) a b = match a, b with | _, None -> true | None, _ -> false | Some x, Some y -> (x : int) < y @@ -774,38 +1926,38 @@ let bellman_ford bottom g = | Some x -> Some (x-y) and push u x m = match x with | None -> m - | Some y -> UniverseLMap.add u y m + | Some y -> LMap.add u y m in let relax u v uv distances = let x = lookup_level u distances ++ uv in - if x << lookup_level v distances then push v x distances + if x <? lookup_level v distances then push v x distances else distances in - let init = UniverseLMap.add bottom 0 UniverseLMap.empty in - let vertices = UniverseLMap.fold (fun u arc res -> - let res = UniverseLSet.add u res in + let init = LMap.add bottom 0 LMap.empty in + let vertices = LMap.fold (fun u arc res -> + let res = LSet.add u res in match arc with - | Equiv e -> UniverseLSet.add e res + | Equiv e -> LSet.add e res | Canonical {univ=univ; lt=lt; le=le} -> assert (u == univ); - let add res v = UniverseLSet.add v res in + let add res v = LSet.add v res in let res = List.fold_left add res le in let res = List.fold_left add res lt in - res) g UniverseLSet.empty + res) g LSet.empty in let g = let node = Canonical { univ = bottom; lt = []; - le = UniverseLSet.elements vertices; + le = LSet.elements vertices; rank = 0 - } in UniverseLMap.add bottom node g + } in LMap.add bottom node g in let rec iter count accu = if count <= 0 then accu else - let accu = UniverseLMap.fold (fun u arc res -> match arc with + let accu = LMap.fold (fun u arc res -> match arc with | Equiv e -> relax e u 0 (relax u e 0 res) | Canonical {univ=univ; lt=lt; le=le} -> assert (u == univ); @@ -814,16 +1966,16 @@ let bellman_ford bottom g = res) g accu in iter (count-1) accu in - let distances = iter (UniverseLSet.cardinal vertices) init in - let () = UniverseLMap.iter (fun u arc -> + let distances = iter (LSet.cardinal vertices) init in + let () = LMap.iter (fun u arc -> let lu = lookup_level u distances in match arc with | Equiv v -> let lv = lookup_level v distances in - assert (not (lu << lv) && not (lv << lu)) + assert (not (lu <? lv) && not (lv <? lu)) | Canonical {univ=univ; lt=lt; le=le} -> assert (u == univ); - List.iter (fun v -> assert (not (lu ++ 0 << lookup_level v distances))) le; - List.iter (fun v -> assert (not (lu ++ 1 << lookup_level v distances))) lt) g + List.iter (fun v -> assert (not (lu ++ 0 <? lookup_level v distances))) le; + List.iter (fun v -> assert (not (lu ++ 1 <? lookup_level v distances))) lt) g in distances (** [sort_universes g] builds a map from universes in [g] to natural @@ -837,23 +1989,23 @@ let bellman_ford bottom g = let sort_universes orig = let mp = Names.DirPath.make [Names.Id.of_string "Type"] in let rec make_level accu g i = - let type0 = UniverseLevel.Level (i, mp) in + let type0 = Level.make mp i in let distances = bellman_ford type0 g in - let accu, continue = UniverseLMap.fold (fun u x (accu, continue) -> + let accu, continue = LMap.fold (fun u x (accu, continue) -> let continue = continue || x < 0 in let accu = - if Int.equal x 0 && u != type0 then UniverseLMap.add u i accu + if Int.equal x 0 && u != type0 then LMap.add u i accu else accu in accu, continue) distances (accu, false) in - let filter x = not (UniverseLMap.mem x accu) in + let filter x = not (LMap.mem x accu) in let push g u = - if UniverseLMap.mem u g then g else UniverseLMap.add u (Equiv u) g + if LMap.mem u g then g else LMap.add u (Equiv u) g in - let g = UniverseLMap.fold (fun u arc res -> match arc with + let g = LMap.fold (fun u arc res -> match arc with | Equiv v as x -> begin match filter u, filter v with - | true, true -> UniverseLMap.add u x res + | true, true -> LMap.add u x res | true, false -> push res u | false, true -> push res v | false, false -> res @@ -863,24 +2015,24 @@ let sort_universes orig = if filter u then let lt = List.filter filter lt in let le = List.filter filter le in - UniverseLMap.add u (Canonical {univ=u; lt=lt; le=le; rank=r}) res + LMap.add u (Canonical {univ=u; lt=lt; le=le; rank=r}) res else let res = List.fold_left (fun g u -> if filter u then push g u else g) res lt in let res = List.fold_left (fun g u -> if filter u then push g u else g) res le in - res) g UniverseLMap.empty + res) g LMap.empty in if continue then make_level accu g (i+1) else i, accu in - let max, levels = make_level UniverseLMap.empty orig 0 in + let max, levels = make_level LMap.empty orig 0 in (* defensively check that the result makes sense *) check_sorted orig levels; - let types = Array.init (max+1) (fun x -> UniverseLevel.Level (x, mp)) in - let g = UniverseLMap.map (fun x -> Equiv types.(x)) levels in + let types = Array.init (max+1) (fun x -> Level.make mp x) in + let g = LMap.map (fun x -> Equiv types.(x)) levels in let g = let rec aux i g = if i < max then let u = types.(i) in - let g = UniverseLMap.add u (Canonical { + let g = LMap.add u (Canonical { univ = u; le = []; lt = [types.(i+1)]; @@ -893,26 +2045,19 @@ let sort_universes orig = (**********************************************************************) (* Tools for sort-polymorphic inductive types *) -(* Temporary inductive type levels *) - -let fresh_local_univ, set_remote_fresh_local_univ = - RemoteCounter.new_counter ~name:"local_univ" 0 ~incr:((+) 1) - ~build:(fun n -> Atom (UniverseLevel.Level (n, Names.DirPath.empty))) - (* Miscellaneous functions to remove or test local univ assumed to occur only in the le constraints *) -let make_max = function - | ([u],[]) -> Atom u - | (le,lt) -> Max (le,lt) - -let remove_large_constraint u = function - | Atom u' as x -> if UniverseLevel.equal u u' then Max ([],[]) else x - | Max (le,lt) -> make_max (List.remove UniverseLevel.equal u le,lt) +let remove_large_constraint u v min = + match Universe.level v with + | Some u' -> if Level.eq u u' then min else v + | None -> Huniv.remove (Hunivelt.make (Universe.Expr.make u)) v -let is_direct_constraint u = function - | Atom u' -> UniverseLevel.equal u u' - | Max (le,lt) -> List.mem_f UniverseLevel.equal u le +(* [is_direct_constraint u v] if level [u] is a member of universe [v] *) +let is_direct_constraint u v = + match Universe.level v with + | Some u' -> Level.eq u u' + | None -> Huniv.mem (Hunivelt.make (Universe.Expr.make u)) v (* Solve a system of universe constraint of the form @@ -932,29 +2077,31 @@ let is_direct_sort_constraint s v = match s with | Some u -> is_direct_constraint u v | None -> false -let solve_constraints_system levels level_bounds = +let solve_constraints_system levels level_bounds level_min = let levels = - Array.map (Option.map (function Atom u -> u | _ -> anomaly (Pp.str "expects Atom"))) + Array.map (Option.map (fun u -> match level u with Some u -> u | _ -> anomaly (Pp.str"expects Atom"))) levels in let v = Array.copy level_bounds in let nind = Array.length v in for i=0 to nind-1 do for j=0 to nind-1 do if not (Int.equal i j) && is_direct_sort_constraint levels.(j) v.(i) then - v.(i) <- sup v.(i) level_bounds.(j) + (v.(i) <- Universe.sup v.(i) level_bounds.(j); + level_min.(i) <- Universe.sup level_min.(i) level_min.(j)) done; for j=0 to nind-1 do match levels.(j) with - | Some u -> v.(i) <- remove_large_constraint u v.(i) + | Some u -> v.(i) <- remove_large_constraint u v.(i) level_min.(i) | None -> () done done; v let subst_large_constraint u u' v = - match u with - | Atom u -> - if is_direct_constraint u v then sup u' (remove_large_constraint u v) + match level u with + | Some u -> + if is_direct_constraint u v then + Universe.sup u' (remove_large_constraint u v type0m_univ) else v | _ -> anomaly (Pp.str "expect a universe level") @@ -963,21 +2110,30 @@ let subst_large_constraints = List.fold_right (fun (u,u') -> subst_large_constraint u u') let no_upper_constraints u cst = - match u with - | Atom u -> - let test (u1, _, _) = not (UniverseLevel.equal u1 u) in + match level u with + | Some u -> + let test (u1, _, _) = + not (Int.equal (Level.compare u1 u) 0) in Constraint.for_all test cst - | Max _ -> anomaly (Pp.str "no_upper_constraints") + | _ -> anomaly (Pp.str "no_upper_constraints") (* Is u mentionned in v (or equals to v) ? *) -let level_list_mem u l = List.mem_f UniverseLevel.equal u l - let univ_depends u v = - match u, v with - | Atom u, Atom v -> UniverseLevel.equal u v - | Atom u, Max (gel,gtl) -> level_list_mem u gel || level_list_mem u gtl - | _ -> anomaly (Pp.str "univ_depends given a non-atomic 1st arg") + match atom u with + | Some u -> Huniv.mem u v + | _ -> anomaly (Pp.str"univ_depends given a non-atomic 1st arg") + +let constraints_of_universes g = + let constraints_of u v acc = + match v with + | Canonical {univ=u; lt=lt; le=le} -> + let acc = List.fold_left (fun acc v -> Constraint.add (u,Lt,v) acc) acc lt in + let acc = List.fold_left (fun acc v -> Constraint.add (u,Le,v) acc) acc le in + acc + | Equiv v -> Constraint.add (u,Eq,v) acc + in + LMap.fold constraints_of g Constraint.empty (* Pretty-printing *) @@ -989,101 +2145,67 @@ let pr_arc = function | [], _ | _, [] -> mt () | _ -> spc () in - pr_uni_level u ++ str " " ++ + Level.pr u ++ str " " ++ v 0 - (pr_sequence (fun v -> str "< " ++ pr_uni_level v) lt ++ + (pr_sequence (fun v -> str "< " ++ Level.pr v) lt ++ opt_sep ++ - pr_sequence (fun v -> str "<= " ++ pr_uni_level v) le) ++ + pr_sequence (fun v -> str "<= " ++ Level.pr v) le) ++ fnl () | u, Equiv v -> - pr_uni_level u ++ str " = " ++ pr_uni_level v ++ fnl () + Level.pr u ++ str " = " ++ Level.pr v ++ fnl () let pr_universes g = - let graph = UniverseLMap.fold (fun u a l -> (u,a)::l) g [] in + let graph = LMap.fold (fun u a l -> (u,a)::l) g [] in prlist pr_arc graph -let pr_constraints c = - Constraint.fold (fun (u1,op,u2) pp_std -> - let op_str = match op with - | Lt -> " < " - | Le -> " <= " - | Eq -> " = " - in pp_std ++ pr_uni_level u1 ++ str op_str ++ - pr_uni_level u2 ++ fnl () ) c (str "") - (* Dumping constraints to a file *) let dump_universes output g = let dump_arc u = function | Canonical {univ=u; lt=lt; le=le} -> - let u_str = UniverseLevel.to_string u in - List.iter (fun v -> output Lt u_str (UniverseLevel.to_string v)) lt; - List.iter (fun v -> output Le u_str (UniverseLevel.to_string v)) le + let u_str = Level.to_string u in + List.iter (fun v -> output Lt u_str (Level.to_string v)) lt; + List.iter (fun v -> output Le u_str (Level.to_string v)) le | Equiv v -> - output Eq (UniverseLevel.to_string u) (UniverseLevel.to_string v) + output Eq (Level.to_string u) (Level.to_string v) in - UniverseLMap.iter dump_arc g + LMap.iter dump_arc g -(* Hash-consing *) - -module Hunivlevel = +module Huniverse_set = Hashcons.Make( struct - type t = universe_level - type u = Names.DirPath.t -> Names.DirPath.t - let hashcons hdir = function - | UniverseLevel.Set -> UniverseLevel.Set - | UniverseLevel.Level (n,d) -> UniverseLevel.Level (n,hdir d) - let equal l1 l2 = - l1 == l2 || - match l1,l2 with - | UniverseLevel.Set, UniverseLevel.Set -> true - | UniverseLevel.Level (n,d), UniverseLevel.Level (n',d') -> - n == n' && d == d' - | _ -> false - let hash = UniverseLevel.hash - end) - -module Huniv = - Hashcons.Make( - struct - type t = universe + type t = universe_set type u = universe_level -> universe_level - let hashcons hdir = function - | Atom u -> Atom (hdir u) - | Max (gel,gtl) -> Max (List.map hdir gel, List.map hdir gtl) - let equal u v = - u == v || - match u, v with - | Atom u, Atom v -> u == v - | Max (gel,gtl), Max (gel',gtl') -> - (List.for_all2eq (==) gel gel') && - (List.for_all2eq (==) gtl gtl') - | _ -> false - let hash = Universe.hash + let hashcons huc s = + LSet.fold (fun x -> LSet.add (huc x)) s LSet.empty + let equal s s' = + LSet.equal s s' + let hash = Hashtbl.hash end) -let hcons_univlevel = Hashcons.simple_hcons Hunivlevel.generate Names.DirPath.hcons -let hcons_univ = Hashcons.simple_hcons Huniv.generate hcons_univlevel +let hcons_universe_set = + Hashcons.simple_hcons Huniverse_set.generate Level.hcons -module Hconstraint = - Hashcons.Make( - struct - type t = univ_constraint - type u = universe_level -> universe_level - let hashcons hul (l1,k,l2) = (hul l1, k, hul l2) - let equal (l1,k,l2) (l1',k',l2') = - l1 == l1' && k == k' && l2 == l2' - let hash = Hashtbl.hash - end) +let hcons_universe_context_set (v, c) = + (hcons_universe_set v, hcons_constraints c) -module UConstraintHash = -struct - type t = univ_constraint - let hash = Hashtbl.hash -end -module Hconstraints = Set.Hashcons(UConstraintOrd)(UConstraintHash) +let hcons_univlevel = Level.hcons +let hcons_univ x = x (* Universe.hcons (Huniv.node x) *) +let equal_universes = Universe.equal_universes -let hcons_constraint = Hashcons.simple_hcons Hconstraint.generate hcons_univlevel -let hcons_constraints = Hashcons.simple_hcons Hconstraints.generate hcons_constraint +let explain_universe_inconsistency (o,u,v,p) = + let pr_rel = function + | Eq -> str"=" | Lt -> str"<" | Le -> str"<=" + in + let reason = match p with + [] -> mt() + | _::_ -> + str " because" ++ spc() ++ pr_uni v ++ + prlist (fun (r,v) -> spc() ++ pr_rel r ++ str" " ++ pr_uni v) + p ++ + (if Universe.eq (snd (List.last p)) u then mt() else + (spc() ++ str "= " ++ pr_uni u)) + in + str "Cannot enforce" ++ spc() ++ pr_uni u ++ spc() ++ + pr_rel o ++ spc() ++ pr_uni v ++ reason ++ str")" diff --git a/kernel/univ.mli b/kernel/univ.mli index 04267de70..9e7cc18b4 100644 --- a/kernel/univ.mli +++ b/kernel/univ.mli @@ -8,30 +8,67 @@ (** Universes. *) -module UniverseLevel : +module Level : sig type t (** Type of universe levels. A universe level is essentially a unique name that will be associated to constraints later on. *) + val set : t + val prop : t + val is_small : t -> bool + val compare : t -> t -> int (** Comparison function *) - val equal : t -> t -> bool + val eq : t -> t -> bool (** Equality function *) - val hash : t -> int + (* val hash : t -> int *) (** Hash function *) val make : Names.DirPath.t -> int -> t (** Create a new universe level from a unique identifier and an associated module path. *) + val pr : t -> Pp.std_ppcmds end -type universe_level = UniverseLevel.t +type universe_level = Level.t (** Alias name. *) +module LSet : +sig + include Set.S with type elt = universe_level + + val pr : t -> Pp.std_ppcmds +end + +type universe_set = LSet.t + +module LMap : +sig + include Map.S with type key = universe_level + + (** Favorizes the bindings in the first map. *) + val union : 'a t -> 'a t -> 'a t + val diff : 'a t -> 'a t -> 'a t + + val subst_union : 'a option t -> 'a option t -> 'a option t + + val elements : 'a t -> (universe_level * 'a) list + val of_list : (universe_level * 'a) list -> 'a t + val of_set : universe_set -> 'a -> 'a t + val mem : universe_level -> 'a t -> bool + val universes : 'a t -> universe_set + + val find_opt : universe_level -> 'a t -> 'a option + + val pr : ('a -> Pp.std_ppcmds) -> 'a t -> Pp.std_ppcmds +end + +type 'a universe_map = 'a LMap.t + module Universe : sig type t @@ -41,68 +78,260 @@ sig val compare : t -> t -> int (** Comparison function *) - val equal : t -> t -> bool + val eq : t -> t -> bool (** Equality function *) - val hash : t -> int + (* val hash : t -> int *) (** Hash function *) - val make : UniverseLevel.t -> t + val make : Level.t -> t (** Create a constraint-free universe out of a given level. *) + val pr : t -> Pp.std_ppcmds + + val level : t -> Level.t option + + val levels : t -> LSet.t + + val normalize : t -> t + + (** The type of a universe *) + val super : t -> t + + (** The max of 2 universes *) + val sup : t -> t -> t + + val type0m : t (** image of Prop in the universes hierarchy *) + val type0 : t (** image of Set in the universes hierarchy *) + val type1 : t (** the universe of the type of Prop/Set *) end type universe = Universe.t -(** Alias name. *) -module UniverseLSet : Set.S with type elt = universe_level +(** Alias name. *) +val pr_uni : universe -> Pp.std_ppcmds + (** The universes hierarchy: Type 0- = Prop <= Type 0 = Set <= Type 1 <= ... Typing of universes: Type 0-, Type 0 : Type 1; Type i : Type (i+1) if i>0 *) - -val type0m_univ : universe (** image of Prop in the universes hierarchy *) -val type0_univ : universe (** image of Set in the universes hierarchy *) -val type1_univ : universe (** the universe of the type of Prop/Set *) +val type0m_univ : universe +val type0_univ : universe +val type1_univ : universe val is_type0_univ : universe -> bool val is_type0m_univ : universe -> bool val is_univ_variable : universe -> bool +val is_small_univ : universe -> bool -val universe_level : universe -> universe_level option - -(** The type of a universe *) +val sup : universe -> universe -> universe val super : universe -> universe -(** The max of 2 universes *) -val sup : universe -> universe -> universe +val universe_level : universe -> universe_level option +val compare_levels : universe_level -> universe_level -> int +val eq_levels : universe_level -> universe_level -> bool + +(** Equality of formal universe expressions. *) +val equal_universes : universe -> universe -> bool (** {6 Graphs of universes. } *) type universes -type check_function = universes -> universe -> universe -> bool -val check_leq : check_function -val check_eq : check_function -val lax_check_eq : check_function (* same, without anomaly *) +type 'a check_function = universes -> 'a -> 'a -> bool +val check_leq : universe check_function +val check_eq : universe check_function +val lax_check_eq : universe check_function (* same, without anomaly *) (** The empty graph of universes *) +val empty_universes : universes + +(** The initial graph of universes: Prop < Set *) val initial_universes : universes val is_initial_universes : universes -> bool (** {6 Constraints. } *) -type constraints +type constraint_type = Lt | Le | Eq +type univ_constraint = universe_level * constraint_type * universe_level + +module Constraint : sig + include Set.S with type elt = univ_constraint +end -val empty_constraint : constraints -val union_constraints : constraints -> constraints -> constraints +type constraints = Constraint.t -val is_empty_constraint : constraints -> bool +val empty_constraint : constraints +val union_constraint : constraints -> constraints -> constraints val eq_constraint : constraints -> constraints -> bool -type constraint_function = universe -> universe -> constraints -> constraints +type universe_constraint_type = ULe | UEq | ULub + +type universe_constraint = universe * universe_constraint_type * universe +module UniverseConstraints : sig + include Set.S with type elt = universe_constraint + + val pr : t -> Pp.std_ppcmds +end + +type universe_constraints = UniverseConstraints.t +type 'a universe_constrained = 'a * universe_constraints + +(** A value with universe constraints. *) +type 'a constrained = 'a * constraints + +type universe_subst_fn = universe_level -> universe +type universe_level_subst_fn = universe_level -> universe_level + +(** A full substitution, might involve algebraic universes *) +type universe_subst = universe universe_map +type universe_level_subst = universe_level universe_map + +val level_subst_of : universe_subst_fn -> universe_level_subst_fn + +module Instance : +sig + type t + + val hcons : t -> t + val empty : t + val is_empty : t -> bool + + val eq : t -> t -> bool + + val of_array : Level.t array -> t + val to_array : t -> Level.t array + + (** Rely on physical equality of subterms only *) + val eqeq : t -> t -> bool + + val subst_fn : universe_level_subst_fn -> t -> t + val subst : universe_level_subst -> t -> t + + val pr : t -> Pp.std_ppcmds + + val append : t -> t -> t -val enforce_leq : constraint_function -val enforce_eq : constraint_function + val levels : t -> LSet.t + + val max_level : t -> int + + val check_eq : t check_function + +end + +type universe_instance = Instance.t + +type 'a puniverses = 'a * universe_instance +val out_punivs : 'a puniverses -> 'a +val in_punivs : 'a -> 'a puniverses + +(** A list of universes with universe constraints, + representiong local universe variables and constraints *) + +module UContext : +sig + type t + + val make : Instance.t constrained -> t + val empty : t + val is_empty : t -> bool + + val instance : t -> Instance.t + val constraints : t -> constraints + + (** Keeps the order of the instances *) + val union : t -> t -> t + +end + +type universe_context = UContext.t + +(** Universe contexts (as sets) *) + +module ContextSet : +sig + type t = universe_set constrained + + val empty : t + val is_empty : t -> bool + + val singleton : universe_level -> t + val of_instance : Instance.t -> t + val of_set : universe_set -> t + + val union : t -> t -> t + val diff : t -> t -> t + val add_constraints : t -> constraints -> t + val add_universes : Instance.t -> t -> t + + (** Arbitrary choice of linear order of the variables + and normalization of the constraints *) + val to_context : t -> universe_context + val of_context : universe_context -> t + + val constraints : t -> constraints + val levels : t -> universe_set +end + +(** A set of universes with universe constraints. + We linearize the set to a list after typechecking. + Beware, representation could change. +*) +type universe_context_set = ContextSet.t + +(** A value in a universe context (resp. context set). *) +type 'a in_universe_context = 'a * universe_context +type 'a in_universe_context_set = 'a * universe_context_set + +(** Constrained *) +val constraints_of : 'a constrained -> constraints + + +(** [check_context_subset s s'] checks that [s] is implied by [s'] as a set of constraints, + and shrinks [s'] to the set of variables declared in [s]. +. *) +val check_context_subset : universe_context_set -> universe_context -> universe_context + +(** Make a universe level substitution: the list must match the context variables. *) +val make_universe_subst : Instance.t -> universe_context -> universe_subst +val empty_subst : universe_subst +val is_empty_subst : universe_subst -> bool + +val empty_level_subst : universe_level_subst +val is_empty_level_subst : universe_level_subst -> bool + +(** Get the instantiated graph. *) +val instantiate_univ_context : universe_subst -> universe_context -> constraints + +(** Substitution of universes. *) +val subst_univs_level_level : universe_level_subst -> universe_level -> universe_level +val subst_univs_level_universe : universe_level_subst -> universe -> universe +val subst_univs_level_constraints : universe_level_subst -> constraints -> constraints + +val normalize_univs_level_level : universe_level_subst -> universe_level -> universe_level + +val make_subst : universe_subst -> universe_subst_fn + +(* val subst_univs_level_fail : universe_subst_fn -> universe_level -> universe_level *) +val subst_univs_level : universe_subst_fn -> universe_level -> universe +val subst_univs_universe : universe_subst_fn -> universe -> universe +val subst_univs_constraints : universe_subst_fn -> constraints -> constraints +val subst_univs_universe_constraints : universe_subst_fn -> universe_constraints -> universe_constraints + +(** Raises universe inconsistency if not compatible. *) +val check_consistent_constraints : universe_context_set -> constraints -> unit + +type 'a constraint_function = 'a -> 'a -> constraints -> constraints + +val enforce_leq : universe constraint_function +val enforce_eq : universe constraint_function +val enforce_eq_level : universe_level constraint_function +val enforce_leq_level : universe_level constraint_function +val enforce_eq_instances : universe_instance constraint_function + +type 'a universe_constraint_function = 'a -> 'a -> universe_constraints -> universe_constraints + +val enforce_eq_instances_univs : bool -> universe_instance universe_constraint_function (** {6 ... } *) (** Merge of constraints in a universes graph. @@ -110,8 +339,6 @@ val enforce_eq : constraint_function universes graph. It raises the exception [UniverseInconsistency] if the constraints are not satisfiable. *) -type constraint_type = Lt | Le | Eq - (** Type explanation is used to decorate error messages to provide useful explanation why a given constraint is rejected. It is composed of a path of universes and relation kinds [(r1,u1);..;(rn,un)] means @@ -125,20 +352,26 @@ type constraint_type = Lt | Le | Eq constraints... *) type explanation = (constraint_type * universe) list +type univ_inconsistency = constraint_type * universe * universe * explanation -exception UniverseInconsistency of - constraint_type * universe * universe * explanation +exception UniverseInconsistency of univ_inconsistency +val enforce_constraint : univ_constraint -> universes -> universes val merge_constraints : constraints -> universes -> universes val normalize_universes : universes -> universes val sort_universes : universes -> universes -(** {6 Support for sort-polymorphic inductive types } *) +val constraints_of_universes : universes -> constraints + +val to_constraints : universes -> universe_constraints -> constraints + +val check_constraint : universes -> univ_constraint -> bool +val check_constraints : constraints -> universes -> bool -val fresh_local_univ : unit -> universe -val set_remote_fresh_local_univ : universe RemoteCounter.installer -val solve_constraints_system : universe option array -> universe array -> +(** {6 Support for sort-polymorphism } *) + +val solve_constraints_system : universe option array -> universe array -> universe array -> universe array val subst_large_constraint : universe -> universe -> universe -> universe @@ -154,10 +387,15 @@ val univ_depends : universe -> universe -> bool (** {6 Pretty-printing of universes. } *) -val pr_uni_level : universe_level -> Pp.std_ppcmds -val pr_uni : universe -> Pp.std_ppcmds val pr_universes : universes -> Pp.std_ppcmds +val pr_constraint_type : constraint_type -> Pp.std_ppcmds val pr_constraints : constraints -> Pp.std_ppcmds +(* val pr_universe_list : universe_list -> Pp.std_ppcmds *) +val pr_universe_context : universe_context -> Pp.std_ppcmds +val pr_universe_context_set : universe_context_set -> Pp.std_ppcmds +val pr_universe_level_subst : universe_level_subst -> Pp.std_ppcmds +val pr_universe_subst : universe_subst -> Pp.std_ppcmds +val explain_universe_inconsistency : univ_inconsistency -> Pp.std_ppcmds (** {6 Dumping to a file } *) @@ -170,3 +408,8 @@ val dump_universes : val hcons_univlevel : universe_level -> universe_level val hcons_univ : universe -> universe val hcons_constraints : constraints -> constraints +val hcons_universe_set : universe_set -> universe_set +val hcons_universe_context : universe_context -> universe_context +val hcons_universe_context_set : universe_context_set -> universe_context_set + +(******) diff --git a/kernel/vars.ml b/kernel/vars.ml index f23d5fc2c..3cff51ba6 100644 --- a/kernel/vars.ml +++ b/kernel/vars.ml @@ -212,3 +212,89 @@ let substn_vars p vars c = in replace_vars (List.rev subst) c let subst_vars subst c = substn_vars 1 subst c + +(** Universe substitutions *) +open Constr + +let subst_univs_puniverses subst = + if Univ.is_empty_level_subst subst then fun c -> c + else + let f = Univ.Instance.subst subst in + fun ((c, u) as x) -> let u' = f u in if u' == u then x else (c, u') + +let subst_univs_fn_puniverses fn = + let f = Univ.Instance.subst_fn fn in + fun ((c, u) as x) -> let u' = f u in if u' == u then x else (c, u') + +let subst_univs_fn_constr f c = + let changed = ref false in + let fu = Univ.subst_univs_universe f in + let fi = Univ.Instance.subst_fn (Univ.level_subst_of f) in + let rec aux t = + match kind t with + | Sort (Sorts.Type u) -> + let u' = fu u in + if u' == u then t else + (changed := true; mkSort (Sorts.sort_of_univ u')) + | Const (c, u) -> + let u' = fi u in + if u' == u then t + else (changed := true; mkConstU (c, u')) + | Ind (i, u) -> + let u' = fi u in + if u' == u then t + else (changed := true; mkIndU (i, u')) + | Construct (c, u) -> + let u' = fi u in + if u' == u then t + else (changed := true; mkConstructU (c, u')) + | _ -> map aux t + in + let c' = aux c in + if !changed then c' else c + +let subst_univs_constr subst c = + if Univ.is_empty_subst subst then c + else + let f = Univ.make_subst subst in + subst_univs_fn_constr f c + +(* let subst_univs_constr_key = Profile.declare_profile "subst_univs_constr" *) +(* let subst_univs_constr = Profile.profile2 subst_univs_constr_key subst_univs_constr *) + +let subst_univs_level_constr subst c = + if Univ.is_empty_level_subst subst then c + else + let f = Univ.Instance.subst_fn (Univ.subst_univs_level_level subst) in + let changed = ref false in + let rec aux t = + match kind t with + | Const (c, u) -> + if Univ.Instance.is_empty u then t + else + let u' = f u in + if u' == u then t + else (changed := true; mkConstU (c, u')) + | Ind (i, u) -> + if Univ.Instance.is_empty u then t + else + let u' = f u in + if u' == u then t + else (changed := true; mkIndU (i, u')) + | Construct (c, u) -> + if Univ.Instance.is_empty u then t + else + let u' = f u in + if u' == u then t + else (changed := true; mkConstructU (c, u')) + | Sort (Sorts.Type u) -> + let u' = Univ.subst_univs_level_universe subst u in + if u' == u then t else + (changed := true; mkSort (Sorts.sort_of_univ u')) + | _ -> Constr.map aux t + in + let c' = aux c in + if !changed then c' else c + +let subst_univs_context s = + map_rel_context (subst_univs_constr s) diff --git a/kernel/vars.mli b/kernel/vars.mli index ef3381ab5..9d5d16d0c 100644 --- a/kernel/vars.mli +++ b/kernel/vars.mli @@ -68,3 +68,17 @@ val subst_vars : Id.t list -> constr -> constr (** [substn_vars n [id1;...;idn] t] substitute [VAR idj] by [Rel j+n-1] in [t] if two names are identical, the one of least indice is kept *) val substn_vars : int -> Id.t list -> constr -> constr + +(** {3 Substitution of universes} *) + +open Univ + +val subst_univs_fn_constr : universe_subst_fn -> constr -> constr +val subst_univs_fn_puniverses : universe_level_subst_fn -> + 'a puniverses -> 'a puniverses + +val subst_univs_constr : universe_subst -> constr -> constr +val subst_univs_puniverses : universe_level_subst -> 'a puniverses -> 'a puniverses +val subst_univs_level_constr : universe_level_subst -> constr -> constr + +val subst_univs_context : Univ.universe_subst -> rel_context -> rel_context diff --git a/kernel/vconv.ml b/kernel/vconv.ml index 484ee2a50..62ddeb182 100644 --- a/kernel/vconv.ml +++ b/kernel/vconv.ml @@ -42,13 +42,15 @@ let conv_vect fconv vect1 vect2 cu = let infos = ref (create_clos_infos betaiotazeta Environ.empty_env) +let eq_table_key = Names.eq_table_key eq_constant + let rec conv_val pb k v1 v2 cu = if v1 == v2 then cu else conv_whd pb k (whd_val v1) (whd_val v2) cu and conv_whd pb k whd1 whd2 cu = match whd1, whd2 with - | Vsort s1, Vsort s2 -> sort_cmp pb s1 s2 cu + | Vsort s1, Vsort s2 -> ignore(sort_cmp_universes pb s1 s2 (cu,None)); cu | Vprod p1, Vprod p2 -> let cu = conv_val CONV k (dom p1) (dom p2) cu in conv_fun pb k (codom p1) (codom p2) cu @@ -169,6 +171,13 @@ and conv_arguments k args1 args2 cu = !rcu else raise NotConvertible +let rec eq_puniverses f (x,l1) (y,l2) cu = + if f x y then conv_universes l1 l2 cu + else raise NotConvertible + +and conv_universes l1 l2 cu = + if Univ.Instance.eq l1 l2 then cu else raise NotConvertible + let rec conv_eq pb t1 t2 cu = if t1 == t2 then cu else @@ -179,7 +188,7 @@ let rec conv_eq pb t1 t2 cu = if Int.equal m1 m2 then cu else raise NotConvertible | Var id1, Var id2 -> if Id.equal id1 id2 then cu else raise NotConvertible - | Sort s1, Sort s2 -> sort_cmp pb s1 s2 cu + | Sort s1, Sort s2 -> ignore(sort_cmp_universes pb s1 s2 (cu,None)); cu | Cast (c1,_,_), _ -> conv_eq pb c1 t2 cu | _, Cast (c2,_,_) -> conv_eq pb t1 c2 cu | Prod (_,t1,c1), Prod (_,t2,c2) -> @@ -192,12 +201,13 @@ let rec conv_eq pb t1 t2 cu = | Evar (e1,l1), Evar (e2,l2) -> if Evar.equal e1 e2 then conv_eq_vect l1 l2 cu else raise NotConvertible - | Const c1, Const c2 -> - if eq_constant c1 c2 then cu else raise NotConvertible + | Const c1, Const c2 -> eq_puniverses eq_constant c1 c2 cu + | Proj (p1,c1), Proj (p2,c2) -> + if eq_constant p1 p2 then conv_eq pb c1 c2 cu else raise NotConvertible | Ind c1, Ind c2 -> - if eq_ind c1 c2 then cu else raise NotConvertible + eq_puniverses eq_ind c1 c2 cu | Construct c1, Construct c2 -> - if eq_constructor c1 c2 then cu else raise NotConvertible + eq_puniverses eq_constructor c1 c2 cu | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) -> let pcu = conv_eq CONV p1 p2 cu in let ccu = conv_eq CONV c1 c2 pcu in @@ -221,14 +231,14 @@ and conv_eq_vect vt1 vt2 cu = let vconv pb env t1 t2 = infos := create_clos_infos betaiotazeta env; - let cu = - try conv_eq pb t1 t2 empty_constraint + let _cu = + try conv_eq pb t1 t2 (universes env) with NotConvertible -> let v1 = val_of_constr env t1 in let v2 = val_of_constr env t2 in - let cu = conv_val pb (nb_rel env) v1 v2 empty_constraint in + let cu = conv_val pb (nb_rel env) v1 v2 (universes env) in cu - in cu + in () let _ = Reduction.set_vm_conv vconv diff --git a/lia.cache b/lia.cache Binary files differnew file mode 100644 index 000000000..b878cf355 --- /dev/null +++ b/lia.cache diff --git a/lib/cList.ml b/lib/cList.ml index 36dad3235..93ba0637e 100644 --- a/lib/cList.ml +++ b/lib/cList.ml @@ -479,14 +479,14 @@ let rec find_map f = function let uniquize l = let visited = Hashtbl.create 23 in - let rec aux acc = function - | h::t -> if Hashtbl.mem visited h then aux acc t else + let rec aux acc changed = function + | h::t -> if Hashtbl.mem visited h then aux acc true t else begin Hashtbl.add visited h h; - aux (h::acc) t + aux (h::acc) changed t end - | [] -> List.rev acc - in aux [] l + | [] -> if changed then List.rev acc else l + in aux [] false l (** [sort_uniquize] might be an alternative to the hashtbl-based [uniquize], when the order of the elements is irrelevant *) diff --git a/lib/cList.mli b/lib/cList.mli index 15900260c..01ae83960 100644 --- a/lib/cList.mli +++ b/lib/cList.mli @@ -127,7 +127,8 @@ sig there is none. *) val uniquize : 'a list -> 'a list - (** Return the list of elements without duplicates. *) + (** Return the list of elements without duplicates. + This is the list unchanged if there was none. *) val sort_uniquize : 'a cmp -> 'a list -> 'a list (** Return a sorted and de-duplicated version of a list, diff --git a/lib/flags.ml b/lib/flags.ml index 9b932946c..530617b0c 100644 --- a/lib/flags.ml +++ b/lib/flags.ml @@ -60,6 +60,8 @@ let async_proofs_is_worker () = let debug = ref false +let profile = false + let print_emacs = ref false let term_quality = ref false @@ -134,6 +136,21 @@ let auto_intros = ref true let make_auto_intros flag = auto_intros := flag let is_auto_intros () = version_strictly_greater V8_2 && !auto_intros +let universe_polymorphism = ref false +let make_universe_polymorphism b = universe_polymorphism := b +let is_universe_polymorphism () = !universe_polymorphism + +let local_polymorphic_flag = ref None +let use_polymorphic_flag () = + match !local_polymorphic_flag with + | Some p -> local_polymorphic_flag := None; p + | None -> is_universe_polymorphism () +let make_polymorphic_flag b = + local_polymorphic_flag := Some b + +(** [program_mode] tells that Program mode has been activated, either + globally via [Set Program] or locally via the Program command prefix. *) + let program_mode = ref false let is_program_mode () = !program_mode diff --git a/lib/flags.mli b/lib/flags.mli index ebd11ee77..57e31394e 100644 --- a/lib/flags.mli +++ b/lib/flags.mli @@ -24,6 +24,8 @@ val async_proofs_is_worker : unit -> bool val debug : bool ref +val profile : bool + val print_emacs : bool ref val term_quality : bool ref @@ -72,6 +74,14 @@ val is_term_color : unit -> bool val program_mode : bool ref val is_program_mode : unit -> bool +(** Global universe polymorphism flag. *) +val make_universe_polymorphism : bool -> unit +val is_universe_polymorphism : unit -> bool + +(** Local universe polymorphism flag. *) +val make_polymorphic_flag : bool -> unit +val use_polymorphic_flag : unit -> bool + val make_warn : bool -> unit val if_warn : ('a -> unit) -> 'a -> unit diff --git a/lib/profile.ml b/lib/profile.ml index 6a1b45a39..798f895fa 100644 --- a/lib/profile.ml +++ b/lib/profile.ml @@ -657,6 +657,48 @@ let profile7 e f a b c d g h i = last_alloc := get_alloc (); raise reraise +let profile8 e f a b c d g h i j = + let dw = spent_alloc () in + match !stack with [] -> assert false | p::_ -> + (* We add spent alloc since last measure to current caller own/total alloc *) + ajoute_ownalloc p dw; + ajoute_totalloc p dw; + e.owncount <- e.owncount + 1; + if not (p==e) then stack := e::!stack; + let totalloc0 = e.totalloc in + let intcount0 = e.intcount in + let t = get_time () in + try + last_alloc := get_alloc (); + let r = f a b c d g h i j in + let dw = spent_alloc () in + let dt = get_time () - t in + e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt; + ajoute_ownalloc e dw; + ajoute_totalloc e dw; + p.owntime <- p.owntime - dt; + ajoute_totalloc p (e.totalloc -. totalloc0); + p.intcount <- p.intcount + e.intcount - intcount0 + 1; + p.immcount <- p.immcount + 1; + if not (p==e) then + (match !stack with [] -> assert false | _::s -> stack := s); + last_alloc := get_alloc (); + r + with reraise -> + let dw = spent_alloc () in + let dt = get_time () - t in + e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt; + ajoute_ownalloc e dw; + ajoute_totalloc e dw; + p.owntime <- p.owntime - dt; + ajoute_totalloc p (e.totalloc -. totalloc0); + p.intcount <- p.intcount + e.intcount - intcount0 + 1; + p.immcount <- p.immcount + 1; + if not (p==e) then + (match !stack with [] -> assert false | _::s -> stack := s); + last_alloc := get_alloc (); + raise reraise + let print_logical_stats a = let (c, s, d) = CObj.obj_stats a in Printf.printf "Expanded size: %10d (str: %8d) Depth: %6d\n" (s+c) c d diff --git a/lib/profile.mli b/lib/profile.mli index 812fd8b1e..a7d9cabe5 100644 --- a/lib/profile.mli +++ b/lib/profile.mli @@ -100,6 +100,10 @@ val profile7 : profile_key -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h) -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h +val profile8 : + profile_key -> + ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h -> 'i) + -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h -> 'i (** Some utilities to compute the logical and physical sizes and depth diff --git a/library/assumptions.ml b/library/assumptions.ml index b1f133ac3..9cfe531ce 100644 --- a/library/assumptions.ml +++ b/library/assumptions.ml @@ -204,7 +204,7 @@ let assumptions ?(add_opaque=false) ?(add_transparent=false) st (* t *) = | Case (_,e1,e2,e_array) -> (iter e1)**(iter e2)**(iter_array e_array) | Fix (_,(_, e1_array, e2_array)) | CoFix (_,(_,e1_array, e2_array)) -> (iter_array e1_array) ** (iter_array e2_array) - | Const kn -> do_memoize_kn kn + | Const (kn,_) -> do_memoize_kn kn | _ -> identity2 (* closed atomic types + rel *) and iter_array a = Array.fold_right (fun e f -> (iter e)**f) a identity2 in iter t s acc @@ -222,11 +222,7 @@ let assumptions ?(add_opaque=false) ?(add_transparent=false) st (* t *) = and add_kn kn s acc = let cb = lookup_constant kn in let do_type cst = - let ctype = - match cb.Declarations.const_type with - | PolymorphicArity (ctx,a) -> mkArity (ctx, Type a.poly_level) - | NonPolymorphicType t -> t - in + let ctype = cb.Declarations.const_type in (s,ContextObjectMap.add cst ctype acc) in let (s,acc) = diff --git a/library/declare.ml b/library/declare.ml index c0c4dd571..452504bf0 100644 --- a/library/declare.ml +++ b/library/declare.ml @@ -44,36 +44,40 @@ let if_xml f x = if !Flags.xml_export then f x else () type section_variable_entry = | SectionLocalDef of definition_entry - | SectionLocalAssum of types * bool (* Implicit status *) + | SectionLocalAssum of types Univ.in_universe_context_set * polymorphic * bool (** Implicit status *) type variable_declaration = DirPath.t * section_variable_entry * logical_kind let cache_variable ((sp,_),o) = match o with - | Inl cst -> Global.add_constraints cst + | Inl ctx -> Global.push_context_set ctx | Inr (id,(p,d,mk)) -> (* Constr raisonne sur les noms courts *) if variable_exists id then alreadydeclared (pr_id id ++ str " already exists"); - let impl,opaq,cst = match d with (* Fails if not well-typed *) - | SectionLocalAssum (ty, impl) -> - let cst = Global.push_named_assum (id,ty) in - let impl = if impl then Implicit else Explicit in - impl, true, cst - | SectionLocalDef de -> - let cst = Global.push_named_def (id,de) in - Explicit, de.const_entry_opaque, cst in + + let impl,opaq,poly,ctx = match d with (* Fails if not well-typed *) + | SectionLocalAssum ((ty,ctx),poly,impl) -> + let () = Global.push_named_assum ((id,ty),ctx) in + let impl = if impl then Implicit else Explicit in + impl, true, poly, ctx + | SectionLocalDef (de) -> + let () = Global.push_named_def (id,de) in + Explicit, de.const_entry_opaque, de.const_entry_polymorphic, + (Univ.ContextSet.of_context de.const_entry_universes) in Nametab.push (Nametab.Until 1) (restrict_path 0 sp) (VarRef id); - add_section_variable id impl; + add_section_variable id impl poly ctx; Dischargedhypsmap.set_discharged_hyps sp []; - add_variable_data id (p,opaq,cst,mk) + add_variable_data id (p,opaq,ctx,poly,mk) let discharge_variable (_,o) = match o with - | Inr (id,_) -> Some (Inl (variable_constraints id)) + | Inr (id,_) -> + if variable_polymorphic id then None + else Some (Inl (variable_context id)) | Inl _ -> Some o type variable_obj = - (Univ.constraints, Id.t * variable_declaration) union + (Univ.ContextSet.t, Id.t * variable_declaration) union let inVariable : variable_obj -> obj = declare_object { (default_object "VARIABLE") with @@ -139,7 +143,8 @@ let cache_constant ((sp,kn), obj) = let kn' = Global.add_constant dir id obj.cst_decl in assert (eq_constant kn' (constant_of_kn kn)); Nametab.push (Nametab.Until 1) sp (ConstRef (constant_of_kn kn)); - add_section_constant kn' (Global.lookup_constant kn').const_hyps; + let cst = Global.lookup_constant kn' in + add_section_constant (cst.const_proj <> None) kn' cst.const_hyps; Dischargedhypsmap.set_discharged_hyps sp obj.cst_hyps; add_constant_kind (constant_of_kn kn) obj.cst_kind @@ -150,16 +155,18 @@ let discharged_hyps kn sechyps = let discharge_constant ((sp, kn), obj) = let con = constant_of_kn kn in + let from = Global.lookup_constant con in let modlist = replacement_context () in - let hyps = section_segment_of_constant con in + let hyps,uctx = section_segment_of_constant con in let new_hyps = (discharged_hyps kn hyps) @ obj.cst_hyps in - let abstract = named_of_variable_context hyps in + let abstract = (named_of_variable_context hyps, uctx) in let new_decl = GlobalRecipe{ from; info = { Opaqueproof.modlist; abstract}} in Some { obj with cst_hyps = new_hyps; cst_decl = new_decl; } (* Hack to reduce the size of .vo: we keep only what load/open needs *) -let dummy_constant_entry = ConstantEntry (ParameterEntry (None,mkProp,None)) +let dummy_constant_entry = + ConstantEntry (ParameterEntry (None,false,(mkProp,Univ.UContext.empty),None)) let dummy_constant cst = { cst_decl = dummy_constant_entry; @@ -187,6 +194,18 @@ let declare_constant_common id cst = Notation.declare_ref_arguments_scope (ConstRef c); c +let definition_entry ?(opaque=false) ?types + ?(poly=false) ?(univs=Univ.UContext.empty) body = + { const_entry_body = Future.from_val (body,Declareops.no_seff); + const_entry_secctx = None; + const_entry_type = types; + const_entry_proj = None; + const_entry_polymorphic = poly; + const_entry_universes = univs; + const_entry_opaque = opaque; + const_entry_feedback = None; + const_entry_inline_code = false} + let declare_scheme = ref (fun _ _ -> assert false) let set_declare_scheme f = declare_scheme := f let declare_sideff se = @@ -203,8 +222,7 @@ let declare_sideff se = in let ty_of cb = match cb.Declarations.const_type with - | Declarations.NonPolymorphicType t -> Some t - | _ -> None in + | (* Declarations.NonPolymorphicType *)t -> Some t in let cst_of cb = let pt, opaque = pt_opaque_of cb in let ty = ty_of cb in @@ -215,6 +233,9 @@ let declare_sideff se = const_entry_opaque = opaque; const_entry_inline_code = false; const_entry_feedback = None; + const_entry_polymorphic = cb.const_polymorphic; + const_entry_universes = Future.join cb.const_universes; + const_entry_proj = None; }); cst_hyps = [] ; cst_kind = Decl_kinds.IsDefinition Decl_kinds.Definition; @@ -252,16 +273,11 @@ let declare_constant ?(internal = UserVerbose) ?(local = false) id (cd, kind) = let () = if_xml (Hook.get f_xml_declare_constant) (internal, kn) in kn -let declare_definition ?(internal=UserVerbose) +let declare_definition ?(internal=UserVerbose) ?(opaque=false) ?(kind=Decl_kinds.Definition) ?(local = false) - id ?types body = + ?(poly=false) id ?types (body,ctx) = let cb = - { Entries.const_entry_body = body; - const_entry_type = types; - const_entry_opaque = opaque; - const_entry_inline_code = false; - const_entry_secctx = None; - const_entry_feedback = None } + definition_entry ?types ~poly ~univs:(Univ.ContextSet.to_context ctx) ~opaque body in declare_constant ~internal ~local id (Entries.DefinitionEntry cb, Decl_kinds.IsDefinition kind) @@ -311,7 +327,8 @@ let cache_inductive ((sp,kn),(dhyps,mie)) = let _,dir,_ = repr_kn kn in let kn' = Global.add_mind dir id mie in assert (eq_mind kn' (mind_of_kn kn)); - add_section_kn kn' (Global.lookup_mind kn').mind_hyps; + let mind = Global.lookup_mind kn' in + add_section_kn kn' mind.mind_hyps; Dischargedhypsmap.set_discharged_hyps sp dhyps; List.iter (fun (sp, ref) -> Nametab.push (Nametab.Until 1) sp ref) names @@ -319,9 +336,9 @@ let discharge_inductive ((sp,kn),(dhyps,mie)) = let mind = Global.mind_of_delta_kn kn in let mie = Global.lookup_mind mind in let repl = replacement_context () in - let sechyps = section_segment_of_mutual_inductive mind in + let sechyps,uctx = section_segment_of_mutual_inductive mind in Some (discharged_hyps kn sechyps, - Discharge.process_inductive (named_of_variable_context sechyps) repl mie) + Discharge.process_inductive (named_of_variable_context sechyps,uctx) repl mie) let dummy_one_inductive_entry mie = { mind_entry_typename = mie.mind_entry_typename; @@ -335,7 +352,9 @@ let dummy_inductive_entry (_,m) = ([],{ mind_entry_params = []; mind_entry_record = false; mind_entry_finite = true; - mind_entry_inds = List.map dummy_one_inductive_entry m.mind_entry_inds }) + mind_entry_inds = List.map dummy_one_inductive_entry m.mind_entry_inds; + mind_entry_polymorphic = false; + mind_entry_universes = Univ.UContext.empty }) type inductive_obj = Dischargedhypsmap.discharged_hyps * mutual_inductive_entry diff --git a/library/declare.mli b/library/declare.mli index 663d240dc..848bab618 100644 --- a/library/declare.mli +++ b/library/declare.mli @@ -23,7 +23,7 @@ open Decl_kinds type section_variable_entry = | SectionLocalDef of definition_entry - | SectionLocalAssum of types * bool (** Implicit status *) + | SectionLocalAssum of types Univ.in_universe_context_set * polymorphic * bool (** Implicit status *) type variable_declaration = DirPath.t * section_variable_entry * logical_kind @@ -47,12 +47,18 @@ type internal_flag = | KernelSilent | UserVerbose +(* Defaut definition entries, transparent with no secctx or proj information *) +val definition_entry : ?opaque:bool -> ?types:types -> + ?poly:polymorphic -> ?univs:Univ.universe_context -> + constr -> definition_entry + val declare_constant : ?internal:internal_flag -> ?local:bool -> Id.t -> constant_declaration -> constant val declare_definition : ?internal:internal_flag -> ?opaque:bool -> ?kind:definition_object_kind -> - ?local:bool -> Id.t -> ?types:constr -> Entries.const_entry_body -> constant + ?local:bool -> ?poly:polymorphic -> Id.t -> ?types:constr -> + constr Univ.in_universe_context_set -> constant (** Since transparent constant's side effects are globally declared, we * need that *) diff --git a/library/decls.ml b/library/decls.ml index 2d8807f80..811d09667 100644 --- a/library/decls.ml +++ b/library/decls.ml @@ -18,17 +18,18 @@ open Libnames (** Datas associated to section variables and local definitions *) type variable_data = - DirPath.t * bool (* opacity *) * Univ.constraints * logical_kind + DirPath.t * bool (* opacity *) * Univ.universe_context_set * polymorphic * logical_kind let vartab = Summary.ref (Id.Map.empty : variable_data Id.Map.t) ~name:"VARIABLE" let add_variable_data id o = vartab := Id.Map.add id o !vartab -let variable_path id = let (p,_,_,_) = Id.Map.find id !vartab in p -let variable_opacity id = let (_,opaq,_,_) = Id.Map.find id !vartab in opaq -let variable_kind id = let (_,_,_,k) = Id.Map.find id !vartab in k -let variable_constraints id = let (_,_,cst,_) = Id.Map.find id !vartab in cst +let variable_path id = let (p,_,_,_,_) = Id.Map.find id !vartab in p +let variable_opacity id = let (_,opaq,_,_,_) = Id.Map.find id !vartab in opaq +let variable_kind id = let (_,_,_,_,k) = Id.Map.find id !vartab in k +let variable_context id = let (_,_,ctx,_,_) = Id.Map.find id !vartab in ctx +let variable_polymorphic id = let (_,_,_,p,_) = Id.Map.find id !vartab in p let variable_secpath id = let dir = drop_dirpath_prefix (Lib.library_dp()) (variable_path id) in diff --git a/library/decls.mli b/library/decls.mli index f45e4f121..6e9d4a4ab 100644 --- a/library/decls.mli +++ b/library/decls.mli @@ -17,14 +17,15 @@ open Decl_kinds (** Registration and access to the table of variable *) type variable_data = - DirPath.t * bool (** opacity *) * Univ.constraints * logical_kind + DirPath.t * bool (** opacity *) * Univ.universe_context_set * polymorphic * logical_kind val add_variable_data : variable -> variable_data -> unit val variable_path : variable -> DirPath.t val variable_secpath : variable -> qualid val variable_kind : variable -> logical_kind val variable_opacity : variable -> bool -val variable_constraints : variable -> Univ.constraints +val variable_context : variable -> Univ.universe_context_set +val variable_polymorphic : variable -> polymorphic val variable_exists : variable -> bool (** Registration and access to the table of constants *) diff --git a/library/global.ml b/library/global.ml index a8121d15f..c56bc9e77 100644 --- a/library/global.ml +++ b/library/global.ml @@ -70,9 +70,12 @@ let globalize_with_summary fs f = let i2l = Label.of_id -let push_named_assum a = globalize (Safe_typing.push_named_assum a) -let push_named_def d = globalize (Safe_typing.push_named_def d) +let push_named_assum a = globalize0 (Safe_typing.push_named_assum a) +let push_named_def d = globalize0 (Safe_typing.push_named_def d) let add_constraints c = globalize0 (Safe_typing.add_constraints c) +let push_context_set c = globalize0 (Safe_typing.push_context_set c) +let push_context c = globalize0 (Safe_typing.push_context c) + let set_engagement c = globalize0 (Safe_typing.set_engagement c) let add_constant dir id d = globalize (Safe_typing.add_constant dir (i2l id) d) let add_mind dir id mie = globalize (Safe_typing.add_mind dir (i2l id) mie) @@ -101,6 +104,7 @@ let named_context_val () = named_context_val (env()) let lookup_named id = lookup_named id (env()) let lookup_constant kn = lookup_constant kn (env()) let lookup_inductive ind = Inductive.lookup_mind_specif (env()) ind +let lookup_pinductive (ind,_) = Inductive.lookup_mind_specif (env()) ind let lookup_mind kn = lookup_mind kn (env()) let lookup_module mp = lookup_module mp (env()) @@ -139,19 +143,43 @@ let env_of_context hyps = open Globnames -let type_of_reference env = function +(** Build a fresh instance for a given context, its associated substitution and + the instantiated constraints. *) + +let type_of_global_unsafe r = + let env = env() in + match r with | VarRef id -> Environ.named_type id env - | ConstRef c -> Typeops.type_of_constant env c + | ConstRef c -> + let cb = Environ.lookup_constant c env in cb.Declarations.const_type + | IndRef ind -> + let (mib, oib) = Inductive.lookup_mind_specif env ind in + oib.Declarations.mind_arity.Declarations.mind_user_arity + | ConstructRef cstr -> + let (mib,oib as specif) = Inductive.lookup_mind_specif env (inductive_of_constructor cstr) in + let inst = Univ.UContext.instance mib.Declarations.mind_universes in + Inductive.type_of_constructor (cstr,inst) specif + + +let is_polymorphic r = + let env = env() in + match r with + | VarRef id -> false + | ConstRef c -> + let cb = Environ.lookup_constant c env in cb.Declarations.const_polymorphic | IndRef ind -> - let specif = Inductive.lookup_mind_specif env ind in - Inductive.type_of_inductive env specif + let (mib, oib) = Inductive.lookup_mind_specif env ind in + mib.Declarations.mind_polymorphic | ConstructRef cstr -> - let specif = - Inductive.lookup_mind_specif env (inductive_of_constructor cstr) in - Inductive.type_of_constructor cstr specif + let (mib,oib as specif) = Inductive.lookup_mind_specif env (inductive_of_constructor cstr) in + mib.Declarations.mind_polymorphic -let type_of_global t = type_of_reference (env ()) t +let current_dirpath () = + Safe_typing.current_dirpath (safe_env ()) +let with_global f = + let (a, ctx) = f (env ()) (current_dirpath ()) in + push_context_set ctx; a (* spiwack: register/unregister functions for retroknowledge *) let register field value by_clause = diff --git a/library/global.mli b/library/global.mli index e11e1c017..b6825ffa5 100644 --- a/library/global.mli +++ b/library/global.mli @@ -33,13 +33,19 @@ val add_constraints : Univ.constraints -> unit (** Variables, Local definitions, constants, inductive types *) -val push_named_assum : (Id.t * Term.types) -> Univ.constraints -val push_named_def : (Id.t * Entries.definition_entry) -> Univ.constraints +val push_named_assum : (Id.t * Constr.types) Univ.in_universe_context_set -> unit +val push_named_def : (Id.t * Entries.definition_entry) -> unit + val add_constant : DirPath.t -> Id.t -> Safe_typing.global_declaration -> constant val add_mind : DirPath.t -> Id.t -> Entries.mutual_inductive_entry -> mutual_inductive +val add_constraints : Univ.constraints -> unit + +val push_context : Univ.universe_context -> unit +val push_context_set : Univ.universe_context_set -> unit + (** Non-interactive modules and module types *) val add_module : @@ -72,6 +78,8 @@ val lookup_named : variable -> Context.named_declaration val lookup_constant : constant -> Declarations.constant_body val lookup_inductive : inductive -> Declarations.mutual_inductive_body * Declarations.one_inductive_body +val lookup_pinductive : Constr.pinductive -> + Declarations.mutual_inductive_body * Declarations.one_inductive_body val lookup_mind : mutual_inductive -> Declarations.mutual_inductive_body val lookup_module : module_path -> Declarations.module_body val lookup_modtype : module_path -> Declarations.module_type_body @@ -94,11 +102,14 @@ val import : (** Function to get an environment from the constants part of the global * environment and a given context. *) -val type_of_global : Globnames.global_reference -> Term.types val env_of_context : Environ.named_context_val -> Environ.env val join_safe_environment : unit -> unit +val is_polymorphic : Globnames.global_reference -> bool + +(* val type_of_global : Globnames.global_reference -> types Univ.in_universe_context_set *) +val type_of_global_unsafe : Globnames.global_reference -> Constr.types (** {6 Retroknowledge } *) @@ -109,5 +120,10 @@ val register_inline : constant -> unit (** {6 Oracle } *) -val set_strategy : 'a Names.tableKey -> Conv_oracle.level -> unit +val set_strategy : Names.constant Names.tableKey -> Conv_oracle.level -> unit + +(* Modifies the global state, registering new universes *) + +val current_dirpath : unit -> Names.dir_path +val with_global : (Environ.env -> Names.dir_path -> 'a Univ.in_universe_context_set) -> 'a diff --git a/library/globnames.ml b/library/globnames.ml index 8a9e99621..c881e797e 100644 --- a/library/globnames.ml +++ b/library/globnames.ml @@ -38,19 +38,31 @@ let destConstRef = function ConstRef ind -> ind | _ -> failwith "destConstRef" let destIndRef = function IndRef ind -> ind | _ -> failwith "destIndRef" let destConstructRef = function ConstructRef ind -> ind | _ -> failwith "destConstructRef" -let subst_constructor subst ((kn,i),j as ref) = - let kn' = subst_ind subst kn in - if kn==kn' then ref, mkConstruct ref - else ((kn',i),j), mkConstruct ((kn',i),j) +let subst_constructor subst (ind,j as ref) = + let ind' = subst_ind subst ind in + if ind==ind' then ref, mkConstruct ref + else (ind',j), mkConstruct (ind',j) + +let subst_global_reference subst ref = match ref with + | VarRef var -> ref + | ConstRef kn -> + let kn' = subst_constant subst kn in + if kn==kn' then ref else ConstRef kn' + | IndRef ind -> + let ind' = subst_ind subst ind in + if ind==ind' then ref else IndRef ind' + | ConstructRef ((kn,i),j as c) -> + let c',t = subst_constructor subst c in + if c'==c then ref else ConstructRef c' let subst_global subst ref = match ref with | VarRef var -> ref, mkVar var | ConstRef kn -> - let kn',t = subst_con subst kn in + let kn',t = subst_con_kn subst kn in if kn==kn' then ref, mkConst kn else ConstRef kn', t - | IndRef (kn,i) -> - let kn' = subst_ind subst kn in - if kn==kn' then ref, mkInd (kn,i) else IndRef(kn',i), mkInd (kn',i) + | IndRef ind -> + let ind' = subst_ind subst ind in + if ind==ind' then ref, mkInd ind else IndRef ind', mkInd ind' | ConstructRef ((kn,i),j as c) -> let c',t = subst_constructor subst c in if c'==c then ref,t else ConstructRef c', t @@ -62,19 +74,26 @@ let canonical_gr = function | VarRef id -> VarRef id let global_of_constr c = match kind_of_term c with - | Const sp -> ConstRef sp - | Ind ind_sp -> IndRef ind_sp - | Construct cstr_cp -> ConstructRef cstr_cp + | Const (sp,u) -> ConstRef sp + | Ind (ind_sp,u) -> IndRef ind_sp + | Construct (cstr_cp,u) -> ConstructRef cstr_cp | Var id -> VarRef id | _ -> raise Not_found -let constr_of_global = function +let is_global c t = + match c, kind_of_term t with + | ConstRef c, Const (c', _) -> eq_constant c c' + | IndRef i, Ind (i', _) -> eq_ind i i' + | ConstructRef i, Construct (i', _) -> eq_constructor i i' + | VarRef id, Var id' -> id_eq id id' + | _ -> false + +let printable_constr_of_global = function | VarRef id -> mkVar id | ConstRef sp -> mkConst sp | ConstructRef sp -> mkConstruct sp | IndRef sp -> mkInd sp -let constr_of_reference = constr_of_global let reference_of_constr = global_of_constr let global_eq_gen eq_cst eq_ind eq_cons x y = @@ -179,10 +198,6 @@ type global_reference_or_constr = | IsGlobal of global_reference | IsConstr of constr -let constr_of_global_or_constr = function - | IsConstr c -> c - | IsGlobal gr -> constr_of_global gr - (** {6 Temporary function to brutally form kernel names from section paths } *) let encode_mind dir id = MutInd.make2 (MPfile dir) (Label.of_id id) diff --git a/library/globnames.mli b/library/globnames.mli index 5d717965e..5ea0c9de0 100644 --- a/library/globnames.mli +++ b/library/globnames.mli @@ -31,19 +31,21 @@ val destConstRef : global_reference -> constant val destIndRef : global_reference -> inductive val destConstructRef : global_reference -> constructor +val is_global : global_reference -> constr -> bool val subst_constructor : substitution -> constructor -> constructor * constr val subst_global : substitution -> global_reference -> global_reference * constr +val subst_global_reference : substitution -> global_reference -> global_reference -(** Turn a global reference into a construction *) -val constr_of_global : global_reference -> constr +(** This constr is not safe to be typechecked, universe polymorphism is not + handled here: just use for printing *) +val printable_constr_of_global : global_reference -> constr (** Turn a construction denoting a global reference into a global reference; raise [Not_found] if not a global reference *) val global_of_constr : constr -> global_reference (** Obsolete synonyms for constr_of_global and global_of_constr *) -val constr_of_reference : global_reference -> constr val reference_of_constr : constr -> global_reference module RefOrdered : sig @@ -87,8 +89,6 @@ type global_reference_or_constr = | IsGlobal of global_reference | IsConstr of constr -val constr_of_global_or_constr : global_reference_or_constr -> constr - (** {6 Temporary function to brutally form kernel names from section paths } *) val encode_mind : DirPath.t -> Id.t -> mutual_inductive diff --git a/library/heads.ml b/library/heads.ml index f64cdb05a..0faad827e 100644 --- a/library/heads.ml +++ b/library/heads.ml @@ -58,7 +58,7 @@ let variable_head id = Evalrefmap.find (EvalVarRef id) !head_map let constant_head cst = Evalrefmap.find (EvalConstRef cst) !head_map let kind_of_head env t = - let rec aux k l t b = match kind_of_term (Reduction.whd_betaiotazeta t) with + let rec aux k l t b = match kind_of_term (Reduction.whd_betaiotazeta env t) with | Rel n when n > k -> NotImmediatelyComputableHead | Rel n -> FlexibleHead (k,k+1-n,List.length l,b) | Var id -> @@ -68,7 +68,7 @@ let kind_of_head env t = match pi2 (lookup_named id env) with | Some c -> aux k l c b | None -> NotImmediatelyComputableHead) - | Const cst -> + | Const (cst,_) -> (try on_subterm k l b (constant_head cst) with Not_found -> assert false) | Construct _ | CoFix _ -> @@ -85,6 +85,10 @@ let kind_of_head env t = | LetIn _ -> assert false | Meta _ | Evar _ -> NotImmediatelyComputableHead | App (c,al) -> aux k (Array.to_list al @ l) c b + | Proj (p,c) -> + (try on_subterm k (c :: l) b (constant_head p) + with Not_found -> assert false) + | Case (_,_,c,_) -> aux k [] c true | Fix ((i,j),_) -> let n = i.(j) in @@ -113,11 +117,18 @@ let kind_of_head env t = | x -> x in aux 0 [] t false +(* FIXME: maybe change interface here *) let compute_head = function | EvalConstRef cst -> - (match constant_opt_value (Global.env()) cst with + let env = Global.env() in + let cb = Environ.lookup_constant cst env in + let body = + if cb.Declarations.const_proj = None + then Declareops.body_of_constant cb else None + in + (match body with | None -> RigidHead (RigidParameter cst) - | Some c -> kind_of_head (Global.env()) c) + | Some c -> kind_of_head env c) | EvalVarRef id -> (match pi2 (Global.lookup_named id) with | Some c when not (Decls.variable_opacity id) -> @@ -140,8 +151,8 @@ let cache_head o = let subst_head_approximation subst = function | RigidHead (RigidParameter cst) as k -> - let cst,c = subst_con subst cst in - if isConst c && eq_constant (destConst c) cst then + let cst,c = subst_con_kn subst cst in + if isConst c && eq_constant (fst (destConst c)) cst then (* A change of the prefix of the constant *) k else diff --git a/library/impargs.ml b/library/impargs.ml index 1bcff8695..5a44b5bdb 100644 --- a/library/impargs.ml +++ b/library/impargs.ml @@ -169,7 +169,7 @@ let is_flexible_reference env bound depth f = | Rel n when n >= bound+depth -> (* inductive type *) false | Rel n when n >= depth -> (* previous argument *) true | Rel n -> (* since local definitions have been expanded *) false - | Const kn -> + | Const (kn,_) -> let cb = Environ.lookup_constant kn env in (match cb.const_body with Def _ -> true | _ -> false) | Var id -> @@ -214,6 +214,7 @@ let rec is_rigid_head t = match kind_of_term t with | Rel _ | Evar _ -> false | Ind _ | Const _ | Var _ | Sort _ -> true | Case (_,_,f,_) -> is_rigid_head f + | Proj (p,c) -> true | App (f,args) -> (match kind_of_term f with | Fix ((fi,i),_) -> is_rigid_head (args.(fi.(i))) @@ -401,7 +402,14 @@ let compute_semi_auto_implicits env f manual t = let compute_constant_implicits flags manual cst = let env = Global.env () in - compute_semi_auto_implicits env flags manual (Typeops.type_of_constant env cst) + let cb = Environ.lookup_constant cst env in + let ty = cb.const_type in + let impls = compute_semi_auto_implicits env flags manual ty in + impls + (* match cb.const_proj with *) + (* | None -> impls *) + (* | Some {proj_npars = n} -> *) + (* List.map (fun (x,args) -> x, CList.skipn_at_least n args) impls *) (*s Inductives and constructors. Their implicit arguments are stored in an array, indexed by the inductive number, of pairs $(i,v)$ where @@ -413,14 +421,15 @@ let compute_mib_implicits flags manual kn = let mib = lookup_mind kn env in let ar = Array.to_list - (Array.map (* No need to lift, arities contain no de Bruijn *) - (fun mip -> - (Name mip.mind_typename, None, type_of_inductive env (mib,mip))) + (Array.mapi (* No need to lift, arities contain no de Bruijn *) + (fun i mip -> + (** No need to care about constraints here *) + (Name mip.mind_typename, None, Global.type_of_global_unsafe (IndRef (kn,i)))) mib.mind_packets) in let env_ar = push_rel_context ar env in let imps_one_inductive i mip = let ind = (kn,i) in - let ar = type_of_inductive env (mib,mip) in + let ar = Global.type_of_global_unsafe (IndRef ind) in ((IndRef ind,compute_semi_auto_implicits env flags manual ar), Array.mapi (fun j c -> (ConstructRef (ind,j+1),compute_semi_auto_implicits env_ar flags manual c)) @@ -517,7 +526,7 @@ let section_segment_of_reference = function | ConstRef con -> section_segment_of_constant con | IndRef (kn,_) | ConstructRef ((kn,_),_) -> section_segment_of_mutual_inductive kn - | _ -> [] + | _ -> [], Univ.UContext.empty let adjust_side_condition p = function | LessArgsThan n -> LessArgsThan (n+p) @@ -532,24 +541,36 @@ let discharge_implicits (_,(req,l)) = | ImplLocal -> None | ImplInteractive (ref,flags,exp) -> (try - let vars = section_segment_of_reference ref in + let vars,_ = section_segment_of_reference ref in + (* let isproj = *) + (* match ref with *) + (* | ConstRef cst -> is_projection cst (Global.env ()) *) + (* | _ -> false *) + (* in *) let ref' = if isVarRef ref then ref else pop_global_reference ref in let extra_impls = impls_of_context vars in - let l' = [ref', List.map (add_section_impls vars extra_impls) (snd (List.hd l))] in + let l' = + (* if isproj then [ref',snd (List.hd l)] *) + (* else *) + [ref', List.map (add_section_impls vars extra_impls) (snd (List.hd l))] in Some (ImplInteractive (ref',flags,exp),l') with Not_found -> (* ref not defined in this section *) Some (req,l)) | ImplConstant (con,flags) -> (try let con' = pop_con con in - let vars = section_segment_of_constant con in + let vars,_ = section_segment_of_constant con in let extra_impls = impls_of_context vars in - let l' = [ConstRef con',List.map (add_section_impls vars extra_impls) (snd (List.hd l))] in + let newimpls = + (* if is_projection con (Global.env()) then (snd (List.hd l)) *) + (* else *) List.map (add_section_impls vars extra_impls) (snd (List.hd l)) + in + let l' = [ConstRef con',newimpls] in Some (ImplConstant (con',flags),l') with Not_found -> (* con not defined in this section *) Some (req,l)) | ImplMutualInductive (kn,flags) -> (try let l' = List.map (fun (gr, l) -> - let vars = section_segment_of_reference gr in + let vars,_ = section_segment_of_reference gr in let extra_impls = impls_of_context vars in ((if isVarRef gr then gr else pop_global_reference gr), List.map (add_section_impls vars extra_impls) l)) l @@ -659,10 +680,14 @@ let check_rigidity isrigid = if not isrigid then errorlabstrm "" (strbrk "Multiple sequences of implicit arguments available only for references that cannot be applied to an arbitrarily large number of arguments.") +let projection_implicits env p (x, impls) = + let pb = Environ.lookup_projection p env in + x, CList.skipn_at_least pb.Declarations.proj_npars impls + let declare_manual_implicits local ref ?enriching l = let flags = !implicit_args in let env = Global.env () in - let t = Global.type_of_global ref in + let t = Global.type_of_global_unsafe ref in let enriching = Option.default flags.auto enriching in let isrigid,autoimpls = compute_auto_implicits env flags enriching t in let l' = match l with diff --git a/library/impargs.mli b/library/impargs.mli index e70cff838..8ad86bdff 100644 --- a/library/impargs.mli +++ b/library/impargs.mli @@ -129,6 +129,8 @@ val make_implicits_list : implicit_status list -> implicits_list list val drop_first_implicits : int -> implicits_list -> implicits_list +val projection_implicits : env -> projection -> implicits_list -> implicits_list + val select_impargs_size : int -> implicits_list list -> implicit_status list val select_stronger_impargs : implicits_list list -> implicit_status list diff --git a/library/kindops.ml b/library/kindops.ml index 6e6c7527b..b8337f5d7 100644 --- a/library/kindops.ml +++ b/library/kindops.ml @@ -24,7 +24,7 @@ let string_of_theorem_kind = function | Corollary -> "Corollary" let string_of_definition_kind def = - let (locality, kind) = def in + let (locality, poly, kind) = def in let error () = Errors.anomaly (Pp.str "Internal definition kind") in match kind with | Definition -> diff --git a/library/lib.ml b/library/lib.ml index 331196565..31f983595 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -380,11 +380,14 @@ let find_opening_node id = *) type variable_info = Names.Id.t * Decl_kinds.binding_kind * Term.constr option * Term.types + type variable_context = variable_info list -type abstr_list = variable_context Names.Cmap.t * variable_context Names.Mindmap.t +type abstr_list = variable_context Univ.in_universe_context Names.Cmap.t * + variable_context Univ.in_universe_context Names.Mindmap.t let sectab = - Summary.ref ([] : ((Names.Id.t * Decl_kinds.binding_kind) list * + Summary.ref ([] : ((Names.Id.t * Decl_kinds.binding_kind * + Decl_kinds.polymorphic * Univ.universe_context_set) list * Opaqueproof.work_list * abstr_list) list) ~name:"section-context" @@ -392,18 +395,19 @@ let add_section () = sectab := ([],(Names.Cmap.empty,Names.Mindmap.empty), (Names.Cmap.empty,Names.Mindmap.empty)) :: !sectab -let add_section_variable id impl = +let add_section_variable id impl poly ctx = match !sectab with | [] -> () (* because (Co-)Fixpoint temporarily uses local vars *) | (vars,repl,abs)::sl -> - sectab := ((id,impl)::vars,repl,abs)::sl + sectab := ((id,impl,poly,ctx)::vars,repl,abs)::sl let extract_hyps (secs,ohyps) = let rec aux = function - | ((id,impl)::idl,(id',b,t)::hyps) when Names.Id.equal id id' -> - (id',impl,b,t) :: aux (idl,hyps) + | ((id,impl,poly,ctx)::idl,(id',b,t)::hyps) when Names.Id.equal id id' -> + let l, r = aux (idl,hyps) in + (id',impl,b,t) :: l, if poly then Univ.ContextSet.union r ctx else r | (id::idl,hyps) -> aux (idl,hyps) - | [], _ -> [] + | [], _ -> [],Univ.ContextSet.empty in aux (secs,ohyps) let instance_from_variable_context sign = @@ -413,23 +417,26 @@ let instance_from_variable_context sign = | [] -> [] in Array.of_list (inst_rec sign) -let named_of_variable_context = List.map (fun (id,_,b,t) -> (id,b,t)) - +let named_of_variable_context ctx = List.map (fun (id,_,b,t) -> (id,b,t)) ctx + let add_section_replacement f g hyps = match !sectab with | [] -> () | (vars,exps,abs)::sl -> - let sechyps = extract_hyps (vars,hyps) in + let sechyps,ctx = extract_hyps (vars,hyps) in + let ctx = Univ.ContextSet.to_context ctx in let args = instance_from_variable_context (List.rev sechyps) in - sectab := (vars,f args exps,g sechyps abs)::sl + sectab := (vars,f (Univ.UContext.instance ctx,args) exps,g (sechyps,ctx) abs)::sl let add_section_kn kn = let f x (l1,l2) = (l1,Names.Mindmap.add kn x l2) in add_section_replacement f f -let add_section_constant kn = +let add_section_constant is_projection kn = + (* let g x (l1,l2) = (Names.Cmap.add kn (Univ.Instance.empty,[||]) l1,l2) in *) let f x (l1,l2) = (Names.Cmap.add kn x l1,l2) in - add_section_replacement f f + (* if is_projection then add_section_replacement g f *) + (* else *) add_section_replacement f f let replacement_context () = pi2 (List.hd !sectab) @@ -445,7 +452,9 @@ let rec list_mem_assoc x = function let section_instance = function | VarRef id -> - if list_mem_assoc id (pi1 (List.hd !sectab)) then [||] + if List.exists (fun (id',_,_,_) -> Names.id_eq id id') + (pi1 (List.hd !sectab)) + then Univ.Instance.empty, [||] else raise Not_found | ConstRef con -> Names.Cmap.find con (fst (pi2 (List.hd !sectab))) @@ -459,8 +468,8 @@ let full_replacement_context () = List.map pi2 !sectab let full_section_segment_of_constant con = List.map (fun (vars,_,(x,_)) -> fun hyps -> named_of_variable_context - (try Names.Cmap.find con x - with Not_found -> extract_hyps (vars, hyps))) !sectab + (try fst (Names.Cmap.find con x) + with Not_found -> fst (extract_hyps (vars, hyps)))) !sectab (*************) (* Sections. *) diff --git a/library/lib.mli b/library/lib.mli index 8975acd9a..759a1a135 100644 --- a/library/lib.mli +++ b/library/lib.mli @@ -161,23 +161,23 @@ val xml_close_section : (Names.Id.t -> unit) Hook.t (** {6 Section management for discharge } *) type variable_info = Names.Id.t * Decl_kinds.binding_kind * Term.constr option * Term.types -type variable_context = variable_info list +type variable_context = variable_info list val instance_from_variable_context : variable_context -> Names.Id.t array val named_of_variable_context : variable_context -> Context.named_context -val section_segment_of_constant : Names.constant -> variable_context -val section_segment_of_mutual_inductive: Names.mutual_inductive -> variable_context +val section_segment_of_constant : Names.constant -> variable_context Univ.in_universe_context +val section_segment_of_mutual_inductive: Names.mutual_inductive -> variable_context Univ.in_universe_context -val section_instance : Globnames.global_reference -> Names.Id.t array +val section_instance : Globnames.global_reference -> Univ.universe_instance * Names.Id.t array val is_in_section : Globnames.global_reference -> bool -val add_section_variable : Names.Id.t -> Decl_kinds.binding_kind -> unit +val add_section_variable : Names.Id.t -> Decl_kinds.binding_kind -> Decl_kinds.polymorphic -> Univ.universe_context_set -> unit -val add_section_constant : Names.constant -> Context.named_context -> unit +val add_section_constant : bool (* is_projection *) -> + Names.constant -> Context.named_context -> unit val add_section_kn : Names.mutual_inductive -> Context.named_context -> unit -val replacement_context : unit -> - (Names.Id.t array Names.Cmap.t * Names.Id.t array Names.Mindmap.t) +val replacement_context : unit -> Opaqueproof.work_list (** {6 Discharge: decrease the section level if in the current section } *) diff --git a/library/library.mllib b/library/library.mllib index 2568bcc18..6a58a1057 100644 --- a/library/library.mllib +++ b/library/library.mllib @@ -5,6 +5,7 @@ Libobject Summary Nametab Global +Universes Lib Declaremods Loadpath diff --git a/library/universes.ml b/library/universes.ml new file mode 100644 index 000000000..79286792d --- /dev/null +++ b/library/universes.ml @@ -0,0 +1,647 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Util +open Pp +open Names +open Term +open Context +open Environ +open Locus +open Univ + +(* Generator of levels *) +let new_univ_level, set_remote_new_univ_level = + RemoteCounter.new_counter ~name:"Universes" 0 ~incr:((+) 1) + ~build:(fun n -> Univ.Level.make (Global.current_dirpath ()) n) + +let new_univ_level _ = new_univ_level () + (* Univ.Level.make db (new_univ_level ()) *) + +let fresh_level () = new_univ_level (Global.current_dirpath ()) + +(* TODO: remove *) +let new_univ dp = Univ.Universe.make (new_univ_level dp) +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 ())) + (UContext.instance ctx) + +let fresh_instance_from_context ctx = + let inst = fresh_universe_instance ctx in + let subst = make_universe_subst inst ctx in + let constraints = instantiate_univ_context subst ctx in + (inst, subst), constraints + +let fresh_instance ctx = + let s = ref LSet.empty in + let inst = + Instance.subst_fn (fun _ -> + let u = new_univ_level (Global.current_dirpath ()) in + s := LSet.add u !s; u) + (UContext.instance ctx) + in !s, inst + +let fresh_instance_from ctx = + let ctx', inst = fresh_instance ctx in + let subst = make_universe_subst inst ctx in + let constraints = instantiate_univ_context subst ctx in + (inst, subst), (ctx', constraints) + +(** Fresh universe polymorphic construction *) + +let fresh_constant_instance env c = + let cb = lookup_constant c env in + if cb.Declarations.const_polymorphic then + let (inst,_), ctx = fresh_instance_from (Future.join cb.Declarations.const_universes) in + ((c, inst), ctx) + else ((c,Instance.empty), ContextSet.empty) + +let fresh_inductive_instance env ind = + let mib, mip = Inductive.lookup_mind_specif env ind in + if mib.Declarations.mind_polymorphic then + let (inst,_), ctx = fresh_instance_from mib.Declarations.mind_universes in + ((ind,inst), ctx) + else ((ind,Instance.empty), ContextSet.empty) + +let fresh_constructor_instance env (ind,i) = + let mib, mip = Inductive.lookup_mind_specif env ind in + if mib.Declarations.mind_polymorphic then + let (inst,_), ctx = fresh_instance_from mib.Declarations.mind_universes in + (((ind,i),inst), ctx) + else (((ind,i),Instance.empty), ContextSet.empty) + +open Globnames +let fresh_global_instance env gr = + match gr with + | VarRef id -> mkVar id, ContextSet.empty + | ConstRef sp -> + let c, ctx = fresh_constant_instance env sp in + mkConstU c, ctx + | ConstructRef sp -> + let c, ctx = fresh_constructor_instance env sp in + mkConstructU c, ctx + | IndRef sp -> + let c, ctx = fresh_inductive_instance env sp in + mkIndU c, ctx + +let constr_of_global gr = + let c, ctx = fresh_global_instance (Global.env ()) gr in + Global.push_context_set ctx; c + +let constr_of_global_univ (gr,u) = + match gr with + | VarRef id -> mkVar id + | ConstRef sp -> mkConstU (sp,u) + | ConstructRef sp -> mkConstructU (sp,u) + | IndRef sp -> mkIndU (sp,u) + +let fresh_global_or_constr_instance env = function + | IsConstr c -> c, ContextSet.empty + | IsGlobal gr -> fresh_global_instance env gr + +let global_of_constr c = + match kind_of_term c with + | Const (c, u) -> ConstRef c, u + | Ind (i, u) -> IndRef i, u + | Construct (c, u) -> ConstructRef c, u + | Var id -> VarRef id, Instance.empty + | _ -> raise Not_found + +let global_app_of_constr c = + match kind_of_term c with + | Const (c, u) -> (ConstRef c, u), None + | Ind (i, u) -> (IndRef i, u), None + | Construct (c, u) -> (ConstructRef c, u), None + | Var id -> (VarRef id, Instance.empty), None + | Proj (p, c) -> (ConstRef p, Instance.empty), Some c + | _ -> raise Not_found + +open Declarations + +let type_of_reference env r = + match r with + | VarRef id -> Environ.named_type id env, ContextSet.empty + | ConstRef c -> + let cb = Environ.lookup_constant c env in + if cb.const_polymorphic then + let (inst, subst), ctx = fresh_instance_from (Future.join cb.const_universes) in + Vars.subst_univs_constr subst cb.const_type, ctx + else cb.const_type, ContextSet.empty + + | IndRef ind -> + let (mib, oib) = Inductive.lookup_mind_specif env ind in + if mib.mind_polymorphic then + let (inst, subst), ctx = fresh_instance_from mib.mind_universes in + Vars.subst_univs_constr subst oib.mind_arity.mind_user_arity, ctx + else oib.mind_arity.mind_user_arity, ContextSet.empty + | ConstructRef cstr -> + let (mib,oib as specif) = Inductive.lookup_mind_specif env (inductive_of_constructor cstr) in + if mib.mind_polymorphic then + let (inst, subst), ctx = fresh_instance_from mib.mind_universes in + Inductive.type_of_constructor (cstr,inst) specif, ctx + else Inductive.type_of_constructor (cstr,Instance.empty) specif, ContextSet.empty + +let type_of_global t = type_of_reference (Global.env ()) t + +let fresh_sort_in_family env = function + | InProp -> prop_sort, ContextSet.empty + | InSet -> set_sort, ContextSet.empty + | InType -> + let u = fresh_level () in + Type (Univ.Universe.make u), ContextSet.singleton u + +let new_sort_in_family sf = + fst (fresh_sort_in_family (Global.env ()) sf) + +let extend_context (a, ctx) (ctx') = + (a, ContextSet.union ctx ctx') + +let new_global_univ () = + let u = fresh_level () in + (Univ.Universe.make u, ContextSet.singleton u) + +(** Simplification *) + +module LevelUnionFind = Unionfind.Make (Univ.LSet) (Univ.LMap) + +let remove_trivial_constraints cst = + Constraint.fold (fun (l,d,r as cstr) nontriv -> + if d != Lt && eq_levels l r then nontriv + else if d == Le && is_type0m_univ (Univ.Universe.make l) then nontriv + else Constraint.add cstr nontriv) + cst Constraint.empty + +let add_list_map u t map = + let l, d, r = LMap.split u map in + let d' = match d with None -> [t] | Some l -> t :: l in + let lr = + LMap.merge (fun k lm rm -> + match lm with Some t -> lm | None -> + match rm with Some t -> rm | None -> None) l r + in LMap.add u d' lr + +let find_list_map u map = + try LMap.find u map with Not_found -> [] + +module UF = LevelUnionFind +type universe_full_subst = (universe_level * universe) list + +(** Precondition: flexible <= ctx *) +let choose_canonical ctx flexible algs s = + let global = LSet.diff s ctx in + let flexible, rigid = LSet.partition (fun x -> LMap.mem x flexible) (LSet.inter s ctx) in + (** If there is a global universe in the set, choose it *) + if not (LSet.is_empty global) then + let canon = LSet.choose global in + canon, (LSet.remove canon global, rigid, flexible) + else (** No global in the equivalence class, choose a rigid one *) + if not (LSet.is_empty rigid) then + let canon = LSet.choose rigid in + canon, (global, LSet.remove canon rigid, flexible) + else (** There are only flexible universes in the equivalence + class, choose a non-algebraic. *) + let algs, nonalgs = LSet.partition (fun x -> LSet.mem x algs) flexible in + if not (LSet.is_empty nonalgs) then + let canon = LSet.choose nonalgs in + canon, (global, rigid, LSet.remove canon flexible) + else + let canon = LSet.choose algs in + canon, (global, rigid, LSet.remove canon flexible) + +open Universe + +let subst_puniverses subst (c, u as cu) = + let u' = Instance.subst subst u in + if u' == u then cu else (c, u') + +let nf_evars_and_universes_local f subst = + let rec aux c = + match kind_of_term c with + | Evar (evdk, _ as ev) -> + (match f ev with + | None -> c + | Some c -> aux c) + | Const pu -> + let pu' = subst_puniverses subst pu in + if pu' == pu then c else mkConstU pu' + | Ind pu -> + let pu' = subst_puniverses subst pu in + if pu' == pu then c else mkIndU pu' + | Construct pu -> + let pu' = subst_puniverses subst pu in + if pu' == pu then c else mkConstructU pu' + | Sort (Type u) -> + let u' = Univ.subst_univs_level_universe subst u in + if u' == u then c else mkSort (sort_of_univ u') + | _ -> map_constr aux c + in aux + +let subst_univs_fn_puniverses lsubst (c, u as cu) = + let u' = Instance.subst_fn lsubst u in + if u' == u then cu else (c, u') + +let subst_univs_puniverses subst cu = + subst_univs_fn_puniverses (Univ.level_subst_of (Univ.make_subst subst)) cu + +let nf_evars_and_universes_gen f subst = + let lsubst = Univ.level_subst_of subst in + let rec aux c = + match kind_of_term c with + | Evar (evdk, _ as ev) -> + (match try f ev with Not_found -> None with + | None -> c + | Some c -> aux c) + | Const pu -> + let pu' = subst_univs_fn_puniverses lsubst pu in + if pu' == pu then c else mkConstU pu' + | Ind pu -> + let pu' = subst_univs_fn_puniverses lsubst pu in + if pu' == pu then c else mkIndU pu' + | Construct pu -> + let pu' = subst_univs_fn_puniverses lsubst pu in + if pu' == pu then c else mkConstructU pu' + | Sort (Type u) -> + let u' = Univ.subst_univs_universe subst u in + if u' == u then c else mkSort (sort_of_univ u') + | _ -> map_constr aux c + in aux + +let nf_evars_and_universes_subst f subst = + nf_evars_and_universes_gen f (Univ.make_subst subst) + +let nf_evars_and_universes_opt_subst f subst = + let subst = fun l -> match LMap.find l subst with None -> raise Not_found | Some l' -> l' in + nf_evars_and_universes_gen f subst + +let subst_univs_full_constr subst c = + nf_evars_and_universes_subst (fun _ -> None) subst c + +let fresh_universe_context_set_instance ctx = + if ContextSet.is_empty ctx then LMap.empty, ctx + else + let (univs, cst) = ContextSet.levels ctx, ContextSet.constraints ctx in + let univs',subst = LSet.fold + (fun u (univs',subst) -> + let u' = fresh_level () in + (LSet.add u' univs', LMap.add u u' subst)) + univs (LSet.empty, LMap.empty) + in + let cst' = subst_univs_level_constraints subst cst in + subst, (univs', cst') + +let normalize_univ_variable ~find ~update = + let rec aux cur = + let b = find cur in + let b' = subst_univs_universe aux b in + if Universe.eq b' b then b + else update cur b' + in fun b -> try aux b with Not_found -> Universe.make b + +let normalize_univ_variable_opt_subst ectx = + let find l = + match Univ.LMap.find l !ectx with + | Some b -> b + | None -> raise Not_found + in + let update l b = + assert (match Universe.level b with Some l' -> not (Level.eq l l') | None -> true); + ectx := Univ.LMap.add l (Some b) !ectx; b + in normalize_univ_variable ~find ~update + +let normalize_univ_variable_subst subst = + let find l = Univ.LMap.find l !subst in + let update l b = + assert (match Universe.level b with Some l' -> not (Level.eq l l') | None -> true); + subst := Univ.LMap.add l b !subst; b in + normalize_univ_variable ~find ~update + +let normalize_universe_opt_subst subst = + let normlevel = normalize_univ_variable_opt_subst subst in + subst_univs_universe normlevel + +let normalize_universe_subst subst = + let normlevel = normalize_univ_variable_subst subst in + subst_univs_universe normlevel + +type universe_opt_subst = universe option universe_map + +let make_opt_subst s = + fun x -> + (match Univ.LMap.find x s with + | Some u -> u + | None -> raise Not_found) + +let subst_opt_univs_constr s = + let f = make_opt_subst s in + Vars.subst_univs_fn_constr f + +let normalize_univ_variables ctx = + let ectx = ref ctx in + let normalize = normalize_univ_variable_opt_subst ectx in + let _ = Univ.LMap.iter (fun u _ -> ignore(normalize u)) ctx in + let undef, def, subst = + Univ.LMap.fold (fun u v (undef, def, subst) -> + match v with + | None -> (Univ.LSet.add u undef, def, subst) + | Some b -> (undef, Univ.LSet.add u def, Univ.LMap.add u b subst)) + !ectx (Univ.LSet.empty, Univ.LSet.empty, Univ.LMap.empty) + in !ectx, undef, def, subst + +let pr_universe_body = function + | None -> mt () + | Some v -> str" := " ++ Univ.Universe.pr v + +let pr_universe_opt_subst = Univ.LMap.pr pr_universe_body + +let is_defined_var u l = + try + match LMap.find u l with + | Some _ -> true + | None -> false + with Not_found -> false + +let subst_univs_subst u l s = + LMap.add u l s + +exception Found of Level.t +let find_inst insts v = + try LMap.iter (fun k (enf,alg,v') -> + if not alg && enf && Universe.eq v' v then raise (Found k)) + insts; raise Not_found + with Found l -> l + +let add_inst u (enf,b,lbound) insts = + match lbound with + | Some v -> LMap.add u (enf,b,v) insts + | None -> insts + +exception Stays + +let compute_lbound left = + (** The universe variable was not fixed yet. + Compute its level using its lower bound. *) + if CList.is_empty left then None + else + let lbound = List.fold_left (fun lbound (d, l) -> + if d == Le (* l <= ?u *) then (Universe.sup l lbound) + else (* l < ?u *) + (assert (d == Lt); + (Universe.sup (Universe.super l) lbound))) + Universe.type0m left + in + Some lbound + +let maybe_enforce_leq lbound u cstrs = + match lbound with + | Some lbound -> enforce_leq lbound (Universe.make u) cstrs + | None -> cstrs + +let instantiate_with_lbound u lbound alg enforce (ctx, us, algs, insts, cstrs) = + if enforce then + let inst = Universe.make u in + let cstrs' = enforce_leq lbound inst cstrs in + (ctx, us, LSet.remove u algs, + LMap.add u (enforce,alg,lbound) insts, cstrs'), (enforce, alg, inst) + else (* Actually instantiate *) + (Univ.LSet.remove u ctx, Univ.LMap.add u (Some lbound) us, algs, + LMap.add u (enforce,alg,lbound) insts, cstrs), (enforce, alg, lbound) + +type constraints_map = (Univ.constraint_type * Univ.LMap.key) list Univ.LMap.t + +let pr_constraints_map cmap = + LMap.fold (fun l cstrs acc -> + Level.pr l ++ str " => " ++ + prlist_with_sep spc (fun (d,r) -> pr_constraint_type d ++ Level.pr r) cstrs ++ fnl () + ++ acc) + cmap (mt ()) + +let minimize_univ_variables ctx us algs left right cstrs = + let left, lbounds = + Univ.LMap.fold (fun r lower (left, lbounds as acc) -> + if Univ.LMap.mem r us || not (Univ.LSet.mem r ctx) then acc + else (* Fixed universe, just compute its glb for sharing *) + let lbounds' = + match compute_lbound (List.map (fun (d,l) -> d, Universe.make l) lower) with + | None -> lbounds + | Some lbound -> LMap.add r (true, false, lbound) lbounds + in (Univ.LMap.remove r left, lbounds')) + left (left, Univ.LMap.empty) + in + let rec instance (ctx', us, algs, insts, cstrs as acc) u = + let acc, left = + try let l = LMap.find u left in + List.fold_left (fun (acc, left') (d, l) -> + let acc', (enf,alg,l') = aux acc l in + (* if alg then assert(not alg); *) + let l' = + if enf then Universe.make l + else l' + (* match Universe.level l' with Some _ -> l' | None -> Universe.make l *) + in + acc', (d, l') :: left') (acc, []) l + with Not_found -> acc, [] + and right = + try Some (LMap.find u right) + with Not_found -> None + in + let instantiate_lbound lbound = + let alg = LSet.mem u algs in + if alg then + (* u is algebraic and has no upper bound constraints: we + instantiate it with it's lower bound, if any *) + instantiate_with_lbound u lbound true false acc + else (* u is non algebraic *) + match Universe.level lbound with + | Some l -> (* The lowerbound is directly a level *) + (* u is not algebraic but has no upper bounds, + we instantiate it with its lower bound if it is a + different level, otherwise we keep it. *) + if not (Level.eq l u) && not (LSet.mem l algs) then + (* if right = None then. Should check that u does not + have upper constraints that are not already in right *) + instantiate_with_lbound u lbound false false acc + (* else instantiate_with_lbound u lbound false true acc *) + else + (* assert false: l can't be alg *) + acc, (true, false, lbound) + | None -> + try + (* if right <> None then raise Not_found; *) + (* Another universe represents the same lower bound, + we can share them with no harm. *) + let can = find_inst insts lbound in + instantiate_with_lbound u (Universe.make can) false false acc + with Not_found -> + (* We set u as the canonical universe representing lbound *) + instantiate_with_lbound u lbound false true acc + in + let acc' acc = + match right with + | None -> acc + | Some cstrs -> + let dangling = List.filter (fun (d, r) -> not (LMap.mem r us)) cstrs in + if List.is_empty dangling then acc + else + let ((ctx', us, algs, insts, cstrs), (enf,_,inst as b)) = acc in + let cstrs' = List.fold_left (fun cstrs (d, r) -> + if d == Univ.Le then + enforce_leq inst (Universe.make r) cstrs + else + try let lev = Option.get (Universe.level inst) in + Constraint.add (lev, d, r) cstrs + with Option.IsNone -> assert false) + cstrs dangling + in + (ctx', us, algs, insts, cstrs'), b + in + if not (LSet.mem u ctx) then acc' (acc, (true, false, Universe.make u)) + else + let lbound = compute_lbound left in + match lbound with + | None -> (* Nothing to do *) + acc' (acc, (true, false, Universe.make u)) + | Some lbound -> + acc' (instantiate_lbound lbound) + and aux (ctx', us, algs, seen, cstrs as acc) u = + try acc, LMap.find u seen + with Not_found -> instance acc u + in + LMap.fold (fun u v (ctx', us, algs, seen, cstrs as acc) -> + if v == None then fst (aux acc u) + else LSet.remove u ctx', us, LSet.remove u algs, seen, cstrs) + us (ctx, us, algs, lbounds, cstrs) + +let normalize_context_set ctx us algs = + let (ctx, csts) = ContextSet.levels ctx, ContextSet.constraints ctx in + let uf = UF.create () in + let csts = + (* We first put constraints in a normal-form: all self-loops are collapsed + to equalities. *) + let g = Univ.merge_constraints csts Univ.empty_universes in + Univ.constraints_of_universes (Univ.normalize_universes g) + in + let noneqs = + Constraint.fold (fun (l,d,r) noneqs -> + if d == Eq then (UF.union l r uf; noneqs) + else Constraint.add (l,d,r) noneqs) + csts Constraint.empty + in + let partition = UF.partition uf in + let subst, eqs = List.fold_left (fun (subst, cstrs) s -> + let canon, (global, rigid, flexible) = choose_canonical ctx us algs s in + (* Add equalities for globals which can't be merged anymore. *) + let cstrs = LSet.fold (fun g cst -> + Constraint.add (canon, Univ.Eq, g) cst) global cstrs + in + (** Should this really happen? *) + let subst' = LSet.fold (fun f -> LMap.add f canon) + (LSet.union rigid flexible) LMap.empty + in + let subst = LMap.union subst' subst in + (subst, cstrs)) + (LMap.empty, Constraint.empty) partition + in + (* Noneqs is now in canonical form w.r.t. equality constraints, + and contains only inequality constraints. *) + let noneqs = subst_univs_level_constraints subst noneqs in + let us = + LMap.subst_union (LMap.map (fun v -> Some (Universe.make v)) subst) us + in + (* Compute the left and right set of flexible variables, constraints + mentionning other variables remain in noneqs. *) + let noneqs, ucstrsl, ucstrsr = + Constraint.fold (fun (l,d,r as cstr) (noneq, ucstrsl, ucstrsr) -> + let lus = LMap.mem l us + and rus = LMap.mem r us + in + let ucstrsl' = + if lus then add_list_map l (d, r) ucstrsl + else ucstrsl + and ucstrsr' = + add_list_map r (d, l) ucstrsr + in + let noneqs = + if lus || rus then noneq + else Constraint.add cstr noneq + in (noneqs, ucstrsl', ucstrsr')) + noneqs (Constraint.empty, LMap.empty, LMap.empty) + in + (* Now we construct the instanciation of each variable. *) + let ctx', us, algs, inst, noneqs = + minimize_univ_variables ctx us algs ucstrsr ucstrsl noneqs + in + let us = ref us in + let norm = normalize_univ_variable_opt_subst us in + let _normalize_subst = LMap.iter (fun u v -> ignore(norm u)) !us in + (!us, algs), (ctx', Constraint.union noneqs eqs) + +(* let normalize_conkey = Profile.declare_profile "normalize_context_set" *) +(* let normalize_context_set a b c = Profile.profile3 normalize_conkey normalize_context_set a b c *) + +let universes_of_constr c = + let rec aux s c = + match kind_of_term c with + | Const (_, u) | Ind (_, u) | Construct (_, u) -> + LSet.union (Instance.levels u) s + | Sort u -> + let u = univ_of_sort u in + LSet.union (Universe.levels u) s + | _ -> fold_constr aux s c + in aux LSet.empty c + +let shrink_universe_context (univs,csts) s = + let univs' = LSet.inter univs s in + Constraint.fold (fun (l,d,r as c) (univs',csts) -> + if LSet.mem l univs' then + let univs' = if LSet.mem r univs then LSet.add r univs' else univs' in + (univs', Constraint.add c csts) + else if LSet.mem r univs' then + let univs' = if LSet.mem l univs then LSet.add l univs' else univs' in + (univs', Constraint.add c csts) + else (univs', csts)) + csts (univs',Constraint.empty) + +let restrict_universe_context (univs,csts) s = + let univs' = LSet.inter univs s in + (* Universes that are not necessary to typecheck the term. + E.g. univs introduced by tactics and not used in the proof term. *) + let diff = LSet.diff univs s in + let csts' = + Constraint.fold (fun (l,d,r as c) csts -> + if LSet.mem l diff || LSet.mem r diff then csts + else Constraint.add c csts) + csts Constraint.empty + in (univs', csts') + +let is_prop_leq (l,d,r) = + Level.eq Level.prop l && d == Univ.Le + +(* Prop < i <-> Set+1 <= i <-> Set < i *) +let translate_cstr (l,d,r as cstr) = + if Level.eq Level.prop l && d == Univ.Lt then + (Level.set, d, r) + else cstr + +let refresh_constraints univs (ctx, cstrs) = + let cstrs', univs' = + Univ.Constraint.fold (fun c (cstrs', univs as acc) -> + let c = translate_cstr c in + if Univ.check_constraint univs c && not (is_prop_leq c) then acc + else (Univ.Constraint.add c cstrs', Univ.enforce_constraint c univs)) + cstrs (Univ.Constraint.empty, univs) + in ((ctx, cstrs'), univs') + +let remove_trivial_constraints (ctx, cstrs) = + let cstrs' = + Univ.Constraint.fold (fun c acc -> + if is_prop_leq c then Univ.Constraint.remove c acc + else acc) cstrs cstrs + in (ctx, cstrs') diff --git a/library/universes.mli b/library/universes.mli new file mode 100644 index 000000000..47876269a --- /dev/null +++ b/library/universes.mli @@ -0,0 +1,170 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Util +open Pp +open Names +open Term +open Context +open Environ +open Locus +open Univ + +(** Universes *) +val new_univ_level : Names.dir_path -> universe_level +val set_remote_new_univ_level : universe_level RemoteCounter.installer +val new_univ : Names.dir_path -> universe +val new_Type : Names.dir_path -> types +val new_Type_sort : Names.dir_path -> sorts + +(** Build a fresh instance for a given context, its associated substitution and + the instantiated constraints. *) + +val fresh_instance_from_context : universe_context -> + (universe_instance * universe_subst) constrained + +val fresh_instance_from : universe_context -> + (universe_instance * universe_subst) in_universe_context_set + +val new_global_univ : unit -> universe in_universe_context_set +val new_sort_in_family : sorts_family -> sorts + +val fresh_sort_in_family : env -> sorts_family -> + sorts in_universe_context_set +val fresh_constant_instance : env -> constant -> + pconstant in_universe_context_set +val fresh_inductive_instance : env -> inductive -> + pinductive in_universe_context_set +val fresh_constructor_instance : env -> constructor -> + pconstructor in_universe_context_set + +val fresh_global_instance : env -> Globnames.global_reference -> + constr in_universe_context_set + +val fresh_global_or_constr_instance : env -> Globnames.global_reference_or_constr -> + constr in_universe_context_set + +(** Raises [Not_found] if not a global reference. *) +val global_of_constr : constr -> Globnames.global_reference puniverses + +val global_app_of_constr : constr -> Globnames.global_reference puniverses * constr option + +val constr_of_global_univ : Globnames.global_reference puniverses -> constr + +val extend_context : 'a in_universe_context_set -> universe_context_set -> + 'a in_universe_context_set + +(** Simplification and pruning of constraints: + [normalize_context_set ctx us] + + - Instantiate the variables in [us] with their most precise + universe levels respecting the constraints. + + - Normalizes the context [ctx] w.r.t. equality constraints, + choosing a canonical universe in each equivalence class + (a global one if there is one) and transitively saturate + the constraints w.r.t to the equalities. *) + +module UF : Unionfind.PartitionSig with type elt = universe_level + +type universe_opt_subst = universe option universe_map + +val make_opt_subst : universe_opt_subst -> universe_subst_fn + +val subst_opt_univs_constr : universe_opt_subst -> constr -> constr + +val choose_canonical : universe_set -> universe_opt_subst -> universe_set -> universe_set -> + universe_level * (universe_set * universe_set * universe_set) + +val instantiate_with_lbound : + Univ.LMap.key -> + Univ.universe -> + bool -> + bool -> + Univ.LSet.t * Univ.universe option Univ.LMap.t * + Univ.LSet.t * + (bool * bool * Univ.universe) Univ.LMap.t * Univ.constraints -> + (Univ.LSet.t * Univ.universe option Univ.LMap.t * + Univ.LSet.t * + (bool * bool * Univ.universe) Univ.LMap.t * Univ.constraints) * + (bool * bool * Univ.universe) + +val compute_lbound : (constraint_type * Univ.universe) list -> universe option + +type constraints_map = (Univ.constraint_type * Univ.LMap.key) list Univ.LMap.t + +val pr_constraints_map : constraints_map -> Pp.std_ppcmds + +val minimize_univ_variables : + Univ.LSet.t -> + Univ.universe option Univ.LMap.t -> + Univ.LSet.t -> + constraints_map -> constraints_map -> + Univ.constraints -> + Univ.LSet.t * Univ.universe option Univ.LMap.t * + Univ.LSet.t * + (bool * bool * Univ.universe) Univ.LMap.t * Univ.constraints + + +val normalize_context_set : universe_context_set -> + universe_opt_subst (* The defined and undefined variables *) -> + universe_set (* univ variables that can be substituted by algebraics *) -> + (universe_opt_subst * universe_set) in_universe_context_set + +val normalize_univ_variables : universe_opt_subst -> + universe_opt_subst * universe_set * universe_set * universe_subst + +val normalize_univ_variable : + find:(universe_level -> universe) -> + update:(universe_level -> universe -> universe) -> + universe_level -> universe + +val normalize_univ_variable_opt_subst : universe_opt_subst ref -> + (universe_level -> universe) + +val normalize_univ_variable_subst : universe_subst ref -> + (universe_level -> universe) + +val normalize_universe_opt_subst : universe_opt_subst ref -> + (universe -> universe) + +val normalize_universe_subst : universe_subst ref -> + (universe -> universe) + +(** Create a fresh global in the global environment, shouldn't be done while + building polymorphic values as the constraints are added to the global + environment already. *) + +val constr_of_global : Globnames.global_reference -> constr + +val type_of_global : Globnames.global_reference -> types in_universe_context_set + +(** Full universes substitutions into terms *) + +val nf_evars_and_universes_local : (existential -> constr option) -> universe_level_subst -> + constr -> constr + +val nf_evars_and_universes_opt_subst : (existential -> constr option) -> + universe_opt_subst -> constr -> constr + +(** Get fresh variables for the universe context. + Useful to make tactics that manipulate constrs in universe contexts polymorphic. *) +val fresh_universe_context_set_instance : universe_context_set -> + universe_level_subst * universe_context_set + +val pr_universe_opt_subst : universe_opt_subst -> Pp.std_ppcmds + +(** Shrink a universe context to a restricted set of variables *) + +val universes_of_constr : constr -> universe_set +val shrink_universe_context : universe_context_set -> universe_set -> universe_context_set +val restrict_universe_context : universe_context_set -> universe_set -> universe_context_set + +val refresh_constraints : universes -> universe_context_set -> universe_context_set * universes + +val remove_trivial_constraints : universe_context_set -> universe_context_set diff --git a/parsing/egramcoq.ml b/parsing/egramcoq.ml index 3245c642f..e2b78d725 100644 --- a/parsing/egramcoq.ml +++ b/parsing/egramcoq.ml @@ -47,7 +47,7 @@ open Egramml let constr_expr_of_name (loc,na) = match na with | Anonymous -> CHole (loc,None,None) - | Name id -> CRef (Ident (loc,id)) + | Name id -> CRef (Ident (loc,id), None) let cases_pattern_expr_of_name (loc,na) = match na with | Anonymous -> CPatAtom (loc,None) @@ -76,7 +76,7 @@ let make_constr_action make (v :: constrs, constrlists, binders) tl) | ETReference -> Gram.action (fun (v:reference) -> - make (CRef v :: constrs, constrlists, binders) tl) + make (CRef (v,None) :: constrs, constrlists, binders) tl) | ETName -> Gram.action (fun (na:Loc.t * Name.t) -> make (constr_expr_of_name na :: constrs, constrlists, binders) tl) diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4 index cdaa809d2..499e7b053 100644 --- a/parsing/g_constr.ml4 +++ b/parsing/g_constr.ml4 @@ -159,7 +159,7 @@ GEXTEND Gram ; constr: [ [ c = operconstr LEVEL "8" -> c - | "@"; f=global -> CAppExpl(!@loc,(None,f),[]) ] ] + | "@"; f=global -> CAppExpl(!@loc,(None,f,None),[]) ] ] ; operconstr: [ "200" RIGHTA @@ -183,20 +183,20 @@ GEXTEND Gram | "90" RIGHTA [ ] | "10" LEFTA [ f=operconstr; args=LIST1 appl_arg -> CApp(!@loc,(None,f),args) - | "@"; f=global; args=LIST0 NEXT -> CAppExpl(!@loc,(None,f),args) + | "@"; f=global; args=LIST0 NEXT -> CAppExpl(!@loc,(None,f,None),args) | "@"; (locid,id) = pattern_identref; args=LIST1 identref -> - let args = List.map (fun x -> CRef (Ident x), None) args in + let args = List.map (fun x -> CRef (Ident x,None), None) args in CApp(!@loc,(None,CPatVar(locid,(true,id))),args) ] | "9" [ ".."; c = operconstr LEVEL "0"; ".." -> - CAppExpl (!@loc,(None,Ident (!@loc,ldots_var)),[c]) ] + CAppExpl (!@loc,(None,Ident (!@loc,ldots_var),None),[c]) ] | "8" [ ] | "1" LEFTA [ c=operconstr; ".("; f=global; args=LIST0 appl_arg; ")" -> - CApp(!@loc,(Some (List.length args+1),CRef f),args@[c,None]) + CApp(!@loc,(Some (List.length args+1),CRef (f,None)),args@[c,None]) | c=operconstr; ".("; "@"; f=global; args=LIST0 (operconstr LEVEL "9"); ")" -> - CAppExpl(!@loc,(Some (List.length args+1),f),args@[c]) + CAppExpl(!@loc,(Some (List.length args+1),f,None),args@[c]) | c=operconstr; "%"; key=IDENT -> CDelimiters (!@loc,key,c) ] | "0" [ c=atomic_constr -> c @@ -277,7 +277,7 @@ GEXTEND Gram | c=operconstr LEVEL "9" -> (c,None) ] ] ; atomic_constr: - [ [ g=global -> CRef g + [ [ g=global -> CRef (g,None) | s=sort -> CSort (!@loc,s) | n=INT -> CPrim (!@loc, Numeral (Bigint.of_string n)) | s=string -> CPrim (!@loc, String s) diff --git a/parsing/g_obligations.ml4 b/parsing/g_obligations.ml4 new file mode 100644 index 000000000..2354aa332 --- /dev/null +++ b/parsing/g_obligations.ml4 @@ -0,0 +1,135 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i camlp4deps: "grammar/grammar.cma" i*) + +(* + Syntax for the subtac terms and types. + Elaborated from correctness/psyntax.ml4 by Jean-Christophe Fillitre *) + + +open Libnames +open Constrexpr +open Constrexpr_ops + +(* We define new entries for programs, with the use of this module + * Subtac. These entries are named Subtac.<foo> + *) + +module Gram = Pcoq.Gram +module Vernac = Pcoq.Vernac_ +module Tactic = Pcoq.Tactic + +open Pcoq + +let sigref = mkRefC (Qualid (Loc.ghost, Libnames.qualid_of_string "Coq.Init.Specif.sig")) + +type 'a withtac_argtype = (Tacexpr.raw_tactic_expr option, 'a) Genarg.abstract_argument_type + +let wit_withtac : Tacexpr.raw_tactic_expr option Genarg.uniform_genarg_type = + Genarg.create_arg None "withtac" + +let withtac = Pcoq.create_generic_entry "withtac" (Genarg.rawwit wit_withtac) + +GEXTEND Gram + GLOBAL: withtac; + + withtac: + [ [ "with"; t = Tactic.tactic -> Some t + | -> None ] ] + ; + + Constr.closed_binder: + [[ "("; id=Prim.name; ":"; t=Constr.lconstr; "|"; c=Constr.lconstr; ")" -> + let typ = mkAppC (sigref, [mkLambdaC ([id], default_binder_kind, t, c)]) in + [LocalRawAssum ([id], default_binder_kind, typ)] + ] ]; + + END + +open Obligations + +let classify_obbl _ = Vernacexpr.(VtStartProof ("Classic",GuaranteesOpacity,[]), VtLater) + +VERNAC COMMAND EXTEND Obligations CLASSIFIED BY classify_obbl +| [ "Obligation" integer(num) "of" ident(name) ":" lconstr(t) withtac(tac) ] -> + [ obligation (num, Some name, Some t) tac ] +| [ "Obligation" integer(num) "of" ident(name) withtac(tac) ] -> + [ obligation (num, Some name, None) tac ] +| [ "Obligation" integer(num) ":" lconstr(t) withtac(tac) ] -> + [ obligation (num, None, Some t) tac ] +| [ "Obligation" integer(num) withtac(tac) ] -> + [ obligation (num, None, None) tac ] +| [ "Next" "Obligation" "of" ident(name) withtac(tac) ] -> + [ next_obligation (Some name) tac ] +| [ "Next" "Obligation" withtac(tac) ] -> [ next_obligation None tac ] +END + +VERNAC COMMAND EXTEND Solve_Obligation CLASSIFIED AS SIDEFF +| [ "Solve" "Obligation" integer(num) "of" ident(name) "with" tactic(t) ] -> + [ try_solve_obligation num (Some name) (Some (Tacinterp.interp t)) ] +| [ "Solve" "Obligation" integer(num) "with" tactic(t) ] -> + [ try_solve_obligation num None (Some (Tacinterp.interp t)) ] +END + +VERNAC COMMAND EXTEND Solve_Obligations CLASSIFIED AS SIDEFF +| [ "Solve" "Obligations" "of" ident(name) "with" tactic(t) ] -> + [ try_solve_obligations (Some name) (Some (Tacinterp.interp t)) ] +| [ "Solve" "Obligations" "with" tactic(t) ] -> + [ try_solve_obligations None (Some (Tacinterp.interp t)) ] +| [ "Solve" "Obligations" ] -> + [ try_solve_obligations None None ] +END + +VERNAC COMMAND EXTEND Solve_All_Obligations CLASSIFIED AS SIDEFF +| [ "Solve" "All" "Obligations" "with" tactic(t) ] -> + [ solve_all_obligations (Some (Tacinterp.interp t)) ] +| [ "Solve" "All" "Obligations" ] -> + [ solve_all_obligations None ] +END + +VERNAC COMMAND EXTEND Admit_Obligations CLASSIFIED AS SIDEFF +| [ "Admit" "Obligations" "of" ident(name) ] -> [ admit_obligations (Some name) ] +| [ "Admit" "Obligations" ] -> [ admit_obligations None ] +END + +VERNAC COMMAND EXTEND Set_Solver CLASSIFIED AS SIDEFF +| [ "Obligation" "Tactic" ":=" tactic(t) ] -> [ + set_default_tactic + (Locality.make_section_locality (Locality.LocalityFixme.consume ())) + (Tacintern.glob_tactic t) ] +END + +open Pp + +VERNAC COMMAND EXTEND Show_Solver CLASSIFIED AS QUERY +| [ "Show" "Obligation" "Tactic" ] -> [ + msg_info (str"Program obligation tactic is " ++ print_default_tactic ()) ] +END + +VERNAC COMMAND EXTEND Show_Obligations CLASSIFIED AS QUERY +| [ "Obligations" "of" ident(name) ] -> [ show_obligations (Some name) ] +| [ "Obligations" ] -> [ show_obligations None ] +END + +VERNAC COMMAND EXTEND Show_Preterm CLASSIFIED AS QUERY +| [ "Preterm" "of" ident(name) ] -> [ msg_info (show_term (Some name)) ] +| [ "Preterm" ] -> [ msg_info (show_term None) ] +END + +open Pp + +(* Declare a printer for the content of Program tactics *) +let () = + let printer _ _ _ = function + | None -> mt () + | Some tac -> str "with" ++ spc () ++ Pptactic.pr_raw_tactic tac + in + (* should not happen *) + let dummy _ _ _ expr = assert false in + Pptactic.declare_extra_genarg_pprule wit_withtac printer dummy dummy diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index 6b989b6ba..65e046fb8 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -146,7 +146,7 @@ let mkTacCase with_evar = function (* Reinterpret ident as notations for variables in the context *) (* because we don't know if they are quantified or not *) | [ElimOnIdent id,(None,None)],None,None -> - TacCase (with_evar,(CRef (Ident id),NoBindings)) + TacCase (with_evar,(CRef (Ident id,None),NoBindings)) | ic -> if List.exists (function (ElimOnAnonHyp _,_) -> true | _ -> false) (pi1 ic) then diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index 73b26b02d..df3c18d10 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -72,8 +72,9 @@ GEXTEND Gram [ [ IDENT "Time"; v = vernac -> VernacTime v | IDENT "Timeout"; n = natural; v = vernac -> VernacTimeout(n,v) | IDENT "Fail"; v = vernac -> VernacFail v - | IDENT "Local"; v = vernac_aux -> VernacLocal (true, v) - | IDENT "Global"; v = vernac_aux -> VernacLocal (false, v) + + | IDENT "Local"; v = vernac_poly -> VernacLocal (true, v) + | IDENT "Global"; v = vernac_poly -> VernacLocal (false, v) (* Stm backdoor *) | IDENT "Stm"; IDENT "JoinDocument"; "." -> VernacStm JoinDocument @@ -85,7 +86,13 @@ GEXTEND Gram | IDENT "Stm"; IDENT "Command"; v = vernac_aux -> VernacStm (Command v) | IDENT "Stm"; IDENT "PGLast"; v = vernac_aux -> VernacStm (PGLast v) - | v = vernac_aux -> v ] + | v = vernac_poly -> v ] + ] + ; + vernac_poly: + [ [ IDENT "Polymorphic"; v = vernac_aux -> VernacPolymorphic (true, v) + | IDENT "Monomorphic"; v = vernac_aux -> VernacPolymorphic (false, v) + | v = vernac_aux -> v ] ] ; vernac_aux: @@ -171,8 +178,8 @@ GEXTEND Gram [ [ thm = thm_token; id = identref; bl = binders; ":"; c = lconstr; l = LIST0 [ "with"; id = identref; bl = binders; ":"; c = lconstr -> - (Some id,(bl,c,None)) ] -> - VernacStartTheoremProof (thm,(Some id,(bl,c,None))::l, false) + (Some id,(bl,c,None)) ] -> + VernacStartTheoremProof (thm, (Some id,(bl,c,None))::l, false) | stre = assumption_token; nl = inline; bl = assum_list -> VernacAssumption (stre, nl, bl) | stre = assumptions_token; nl = inline; bl = assum_list -> @@ -203,6 +210,7 @@ GEXTEND Gram VernacRegister(id, RegisterInline) ] ] ; + gallina_ext: [ [ b = record_token; infer = infer_token; oc = opt_coercion; name = identref; ps = binders; diff --git a/parsing/g_xml.ml4 b/parsing/g_xml.ml4 index 820d44392..99cfa7083 100644 --- a/parsing/g_xml.ml4 +++ b/parsing/g_xml.ml4 @@ -179,7 +179,7 @@ let rec interp_xml_constr = function | XmlTag (loc,"META",al,xl) -> GEvar (loc, get_xml_no al, Some (List.map interp_xml_substitution xl)) | XmlTag (loc,"CONST",al,[]) -> - GRef (loc, ConstRef (get_xml_constant al)) + GRef (loc, ConstRef (get_xml_constant al), None) | XmlTag (loc,"MUTCASE",al,x::y::yl) -> let ind = get_xml_inductive al in let p = interp_xml_patternsType x in @@ -192,9 +192,9 @@ let rec interp_xml_constr = function let nal,rtn = return_type_of_predicate ind n p in GCases (loc,RegularStyle,rtn,[tm,nal],mat) | XmlTag (loc,"MUTIND",al,[]) -> - GRef (loc, IndRef (get_xml_inductive al)) + GRef (loc, IndRef (get_xml_inductive al), None) | XmlTag (loc,"MUTCONSTRUCT",al,[]) -> - GRef (loc, ConstructRef (get_xml_constructor al)) + GRef (loc, ConstructRef (get_xml_constructor al), None) | XmlTag (loc,"FIX",al,xl) -> let li,lnct = List.split (List.map interp_xml_FixFunction xl) in let ln,lc,lt = List.split3 lnct in diff --git a/plugins/Derive/derive.ml b/plugins/Derive/derive.ml index c6a96b31a..906f5e383 100644 --- a/plugins/Derive/derive.ml +++ b/plugins/Derive/derive.ml @@ -7,14 +7,14 @@ (************************************************************************) let interp_init_def_and_relation env sigma init_def r = - let init_def = Constrintern.interp_constr sigma env init_def in + let init_def, _ = Constrintern.interp_constr sigma env init_def in let init_type = Typing.type_of env sigma init_def in let r_type = let open Term in mkProd (Names.Anonymous,init_type, mkProd (Names.Anonymous,init_type,mkProp)) in - let r = Constrintern.interp_casted_constr sigma env r r_type in + let r, _ = Constrintern.interp_casted_constr sigma env r r_type in init_def , init_type , r @@ -23,7 +23,7 @@ let interp_init_def_and_relation env sigma init_def r = [lemma] as the proof. *) let start_deriving f init_def r lemma = let env = Global.env () in - let kind = Decl_kinds.(Global,DefinitionBody Definition) in + let kind = Decl_kinds.(Global,false,DefinitionBody Definition) in let ( init_def , init_type , r ) = interp_init_def_and_relation env Evd.empty init_def r in diff --git a/plugins/btauto/Algebra.v b/plugins/btauto/Algebra.v index a515deefd..795211c20 100644 --- a/plugins/btauto/Algebra.v +++ b/plugins/btauto/Algebra.v @@ -8,11 +8,37 @@ repeat match goal with apply <- andb_true_iff; split end. +Arguments decide P /H. + Hint Extern 5 => progress bool. Ltac define t x H := set (x := t) in *; assert (H : t = x) by reflexivity; clearbody x. +Lemma Decidable_sound : forall P (H : Decidable P), + decide P = true -> P. +Proof. +intros P H Hp; apply -> Decidable_spec; assumption. +Qed. + +Lemma Decidable_complete : forall P (H : Decidable P), + P -> decide P = true. +Proof. +intros P H Hp; apply <- Decidable_spec; assumption. +Qed. + +Lemma Decidable_sound_alt : forall P (H : Decidable P), + ~ P -> decide P = false. +Proof. +intros P [wit spec] Hd; destruct wit; simpl; tauto. +Qed. + +Lemma Decidable_complete_alt : forall P (H : Decidable P), + decide P = false -> ~ P. +Proof. + intros P [wit spec] Hd Hc; simpl in *; intuition congruence. +Qed. + Ltac try_rewrite := repeat match goal with | [ H : ?P |- _ ] => rewrite H @@ -142,6 +168,7 @@ end. Program Instance Decidable_eq_poly : forall (p q : poly), Decidable (eq p q) := { Decidable_witness := beq_poly p q }. + Next Obligation. split. revert q; induction p; intros [] ?; simpl in *; bool; try_decide; @@ -185,8 +212,8 @@ Program Instance Decidable_valid : forall n p, Decidable (valid n p) := { }. Next Obligation. split. - revert n; induction p; simpl in *; intuition; bool; try_decide; auto. - intros H; induction H; simpl in *; bool; try_decide; auto. + revert n; induction p; unfold valid_dec in *; intuition; bool; try_decide; auto. + intros H; induction H; unfold valid_dec in *; bool; try_decide; auto. Qed. (** Basic algebra *) diff --git a/plugins/btauto/refl_btauto.ml b/plugins/btauto/refl_btauto.ml index b81821a2e..6a0f4d852 100644 --- a/plugins/btauto/refl_btauto.ml +++ b/plugins/btauto/refl_btauto.ml @@ -3,7 +3,7 @@ let contrib_name = "btauto" let init_constant dir s = let find_constant contrib dir s = - Globnames.constr_of_global (Coqlib.find_reference contrib dir s) + Universes.constr_of_global (Coqlib.find_reference contrib dir s) in find_constant contrib_name dir s diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml index 046ecf775..c726fd5de 100644 --- a/plugins/cc/ccalgo.ml +++ b/plugins/cc/ccalgo.ml @@ -123,7 +123,7 @@ module PacMap=Map.Make(PacOrd) module PafMap=Map.Make(PafOrd) type cinfo= - {ci_constr: constructor; (* inductive type *) + {ci_constr: pconstructor; (* inductive type *) ci_arity: int; (* # args *) ci_nhyps: int} (* # projectable args *) @@ -142,13 +142,13 @@ type term= let rec term_equal t1 t2 = match t1, t2 with - | Symb c1, Symb c2 -> eq_constr c1 c2 + | Symb c1, Symb c2 -> eq_constr_nounivs c1 c2 | Product (s1, t1), Product (s2, t2) -> family_eq s1 s2 && family_eq t1 t2 | Eps i1, Eps i2 -> Id.equal i1 i2 | Appli (t1, u1), Appli (t2, u2) -> term_equal t1 t2 && term_equal u1 u2 - | Constructor {ci_constr=c1; ci_arity=i1; ci_nhyps=j1}, - Constructor {ci_constr=c2; ci_arity=i2; ci_nhyps=j2} -> - Int.equal i1 i2 && Int.equal j1 j2 && eq_constructor c1 c2 + | Constructor {ci_constr=(c1,u1); ci_arity=i1; ci_nhyps=j1}, + Constructor {ci_constr=(c2,u2); ci_arity=i2; ci_nhyps=j2} -> + Int.equal i1 i2 && Int.equal j1 j2 && eq_constructor c1 c2 (* FIXME check eq? *) | _ -> false open Hashset.Combine @@ -163,7 +163,7 @@ let rec hash_term = function | Product (s1, s2) -> combine3 2 (hash_sorts_family s1) (hash_sorts_family s2) | Eps i -> combine 3 (Id.hash i) | Appli (t1, t2) -> combine3 4 (hash_term t1) (hash_term t2) - | Constructor {ci_constr=c; ci_arity=i; ci_nhyps=j} -> combine4 5 (constructor_hash c) i j + | Constructor {ci_constr=(c,u); ci_arity=i; ci_nhyps=j} -> combine4 5 (constructor_hash c) i j type ccpattern = PApp of term * ccpattern list (* arguments are reversed *) @@ -234,7 +234,7 @@ type node = module Constrhash = Hashtbl.Make (struct type t = constr - let equal = eq_constr + let equal = eq_constr_nounivs let hash = hash_constr end) module Typehash = Constrhash @@ -404,32 +404,50 @@ let _B_ = Name (Id.of_string "A") let _body_ = mkProd(Anonymous,mkRel 2,mkRel 2) let cc_product s1 s2 = - mkLambda(_A_,mkSort(Termops.new_sort_in_family s1), - mkLambda(_B_,mkSort(Termops.new_sort_in_family s2),_body_)) + mkLambda(_A_,mkSort(Universes.new_sort_in_family s1), + mkLambda(_B_,mkSort(Universes.new_sort_in_family s2),_body_)) let rec constr_of_term = function - Symb s->s + Symb s-> applist_projection s [] | Product(s1,s2) -> cc_product s1 s2 | Eps id -> mkVar id - | Constructor cinfo -> mkConstruct cinfo.ci_constr + | Constructor cinfo -> mkConstructU cinfo.ci_constr | Appli (s1,s2)-> make_app [(constr_of_term s2)] s1 and make_app l=function Appli (s1,s2)->make_app ((constr_of_term s2)::l) s1 - | other -> applistc (constr_of_term other) l + | other -> + applist_proj other l +and applist_proj c l = + match c with + | Symb s -> applist_projection s l + | _ -> applistc (constr_of_term c) l +and applist_projection c l = + match kind_of_term c with + | Const c when Environ.is_projection (fst c) (Global.env()) -> + (match l with + | [] -> (* Expand the projection *) + let kn = fst c in + let ty,_ = Typeops.type_of_constant (Global.env ()) c in + let pb = Environ.lookup_projection kn (Global.env()) in + let ctx,_ = Term.decompose_prod_n_assum (pb.Declarations.proj_npars + 1) ty in + it_mkLambda_or_LetIn (mkProj(kn,mkRel 1)) ctx + | hd :: tl -> + applistc (mkProj (fst c, hd)) tl) + | _ -> applistc c l let rec canonize_name c = let func = canonize_name in match kind_of_term c with - | Const kn -> + | Const (kn,u) -> let canon_const = constant_of_kn (canonical_con kn) in - (mkConst canon_const) - | Ind (kn,i) -> + (mkConstU (canon_const,u)) + | Ind ((kn,i),u) -> let canon_mind = mind_of_kn (canonical_mind kn) in - (mkInd (canon_mind,i)) - | Construct ((kn,i),j) -> + (mkIndU ((canon_mind,i),u)) + | Construct (((kn,i),j),u) -> let canon_mind = mind_of_kn (canonical_mind kn) in - mkConstruct ((canon_mind,i),j) + mkConstructU (((canon_mind,i),j),u) | Prod (na,t,ct) -> mkProd (na,func t, func ct) | Lambda (na,t,ct) -> @@ -438,6 +456,9 @@ let rec canonize_name c = mkLetIn (na, func b,func t,func ct) | App (ct,l) -> mkApp (func ct,Array.smartmap func l) + | Proj(kn,c) -> + let canon_const = constant_of_kn (canonical_con kn) in + (mkProj (canon_const, func c)) | _ -> c (* rebuild a term from a pattern and a substitution *) @@ -469,7 +490,7 @@ let rec add_term state t= try Termhash.find uf.syms t with Not_found -> let b=next uf in - let trm = Termops.refresh_universes (constr_of_term t) in + let trm = constr_of_term t in let typ = pf_type_of state.gls trm in let typ = canonize_name typ in let new_node= diff --git a/plugins/cc/ccalgo.mli b/plugins/cc/ccalgo.mli index 5d286c732..0c5d6ca1f 100644 --- a/plugins/cc/ccalgo.mli +++ b/plugins/cc/ccalgo.mli @@ -11,7 +11,7 @@ open Term open Names type cinfo = - {ci_constr: constructor; (* inductive type *) + {ci_constr: pconstructor; (* inductive type *) ci_arity: int; (* # args *) ci_nhyps: int} (* # projectable args *) diff --git a/plugins/cc/ccproof.ml b/plugins/cc/ccproof.ml index 5244dcf17..4e1806f5a 100644 --- a/plugins/cc/ccproof.ml +++ b/plugins/cc/ccproof.ml @@ -20,7 +20,7 @@ type rule= | Refl of term | Trans of proof*proof | Congr of proof*proof - | Inject of proof*constructor*int*int + | Inject of proof*pconstructor*int*int and proof = {p_lhs:term;p_rhs:term;p_rule:rule} diff --git a/plugins/cc/ccproof.mli b/plugins/cc/ccproof.mli index b8a8d229a..50e3624d0 100644 --- a/plugins/cc/ccproof.mli +++ b/plugins/cc/ccproof.mli @@ -16,7 +16,7 @@ type rule= | Refl of term | Trans of proof*proof | Congr of proof*proof - | Inject of proof*constructor*int*int + | Inject of proof*pconstructor*int*int and proof = private {p_lhs:term;p_rhs:term;p_rule:rule} diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index ac148fe18..783abc5d8 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -23,21 +23,17 @@ open Pp open Errors open Util -let constant dir s = lazy (Coqlib.gen_constant "CC" dir s) - -let _f_equal = constant ["Init";"Logic"] "f_equal" - -let _eq_rect = constant ["Init";"Logic"] "eq_rect" - -let _refl_equal = constant ["Init";"Logic"] "eq_refl" - -let _sym_eq = constant ["Init";"Logic"] "eq_sym" - -let _trans_eq = constant ["Init";"Logic"] "eq_trans" - -let _eq = constant ["Init";"Logic"] "eq" - -let _False = constant ["Init";"Logic"] "False" +let reference dir s = Coqlib.gen_reference "CC" dir s + +let _f_equal = reference ["Init";"Logic"] "f_equal" +let _eq_rect = reference ["Init";"Logic"] "eq_rect" +let _refl_equal = reference ["Init";"Logic"] "eq_refl" +let _sym_eq = reference ["Init";"Logic"] "eq_sym" +let _trans_eq = reference ["Init";"Logic"] "eq_trans" +let _eq = reference ["Init";"Logic"] "eq" +let _False = reference ["Init";"Logic"] "False" +let _True = reference ["Init";"Logic"] "True" +let _I = reference ["Init";"Logic"] "I" let whd env= let infos=Closure.create_clos_infos Closure.betaiotazeta env in @@ -64,32 +60,36 @@ let rec decompose_term env sigma t= Appli(Appli(Product (sort_a,sort_b) , decompose_term env sigma a), decompose_term env sigma b) - | Construct c-> - let (mind,i_ind),i_con = c in + | Construct c -> + let (((mind,i_ind),i_con),u)= c in let canon_mind = mind_of_kn (canonical_mind mind) in let canon_ind = canon_mind,i_ind in let (oib,_)=Global.lookup_inductive (canon_ind) in let nargs=mis_constructor_nargs_env env (canon_ind,i_con) in - Constructor {ci_constr= (canon_ind,i_con); + Constructor {ci_constr= ((canon_ind,i_con),u); ci_arity=nargs; ci_nhyps=nargs-oib.mind_nparams} | Ind c -> - let mind,i_ind = c in + let (mind,i_ind),u = c in let canon_mind = mind_of_kn (canonical_mind mind) in - let canon_ind = canon_mind,i_ind in (Symb (mkInd canon_ind)) - | Const c -> + let canon_ind = canon_mind,i_ind in (Symb (mkIndU (canon_ind,u))) + | Const (c,u) -> let canon_const = constant_of_kn (canonical_con c) in - (Symb (mkConst canon_const)) + (Symb (mkConstU (canon_const,u))) + | Proj (p, c) -> + let canon_const = constant_of_kn (canonical_con p) in + (Appli (Symb (mkConst canon_const), decompose_term env sigma c)) | _ ->if closed0 t then (Symb t) else raise Not_found (* decompose equality in members and type *) +open Globnames let atom_of_constr env sigma term = let wh = (whd_delta env term) in let kot = kind_of_term wh in match kot with App (f,args)-> - if eq_constr f (Lazy.force _eq) && Int.equal (Array.length args) 3 + if is_global _eq f && Int.equal (Array.length args) 3 then `Eq (args.(0), decompose_term env sigma args.(1), decompose_term env sigma args.(2)) @@ -124,7 +124,7 @@ let non_trivial = function let patterns_of_constr env sigma nrels term= let f,args= try destApp (whd_delta env term) with DestKO -> raise Not_found in - if eq_constr f (Lazy.force _eq) && Int.equal (Array.length args) 3 + if is_global _eq f && Int.equal (Array.length args) 3 then let patt1,rels1 = pattern_of_constr env sigma args.(1) and patt2,rels2 = pattern_of_constr env sigma args.(2) in @@ -145,7 +145,7 @@ let patterns_of_constr env sigma nrels term= let rec quantified_atom_of_constr env sigma nrels term = match kind_of_term (whd_delta env term) with Prod (id,atom,ff) -> - if eq_constr ff (Lazy.force _False) then + if is_global _False ff then let patts=patterns_of_constr env sigma nrels atom in `Nrule patts else @@ -157,7 +157,7 @@ let rec quantified_atom_of_constr env sigma nrels term = let litteral_of_constr env sigma term= match kind_of_term (whd_delta env term) with | Prod (id,atom,ff) -> - if eq_constr ff (Lazy.force _False) then + if is_global _False ff then match (atom_of_constr env sigma atom) with `Eq(t,a,b) -> `Neq(t,a,b) | `Other(p) -> `Nother(p) @@ -218,13 +218,13 @@ let make_prb gls depth additionnal_terms = (* indhyps builds the array of arrays of constructor hyps for (ind largs) *) -let build_projection intype outtype (cstr:constructor) special default gls= +let build_projection intype outtype (cstr:pconstructor) special default gls= let env=pf_env gls in let (h,argv) = try destApp intype with DestKO -> (intype,[||]) in - let ind=destInd h in - let types=Inductiveops.arities_of_constructors env ind in + let ind,u=destInd h in + let types=Inductiveops.arities_of_constructors env (ind,u) in let lp=Array.length types in - let ci=pred (snd cstr) in + let ci=pred (snd(fst cstr)) in let branch i= let ti= prod_appvect types.(i) argv in let rc=fst (decompose_prod_assum ti) in @@ -243,60 +243,67 @@ let build_projection intype outtype (cstr:constructor) special default gls= let _M =mkMeta +let app_global f args k = + Tacticals.pf_constr_of_global f (fun fc -> k (mkApp (fc, args))) + +let new_app_global f args k = + Tacticals.New.pf_constr_of_global f (fun fc -> k (mkApp (fc, args))) + +let new_exact_check c = Proofview.V82.tactic (exact_check c) +let new_refine c = Proofview.V82.tactic (refine c) + let rec proof_tac p : unit Proofview.tactic = Proofview.Goal.enter begin fun gl -> let type_of = Tacmach.New.pf_type_of gl in + try (* type_of can raise exceptions *) match p.p_rule with - Ax c -> Proofview.V82.tactic (exact_check c) + Ax c -> new_exact_check c | SymAx c -> Proofview.V82.tactic begin fun gls -> - let l=constr_of_term p.p_lhs and - r=constr_of_term p.p_rhs in - let typ = Termops.refresh_universes (pf_type_of gls l) in - exact_check - (mkApp(Lazy.force _sym_eq,[|typ;r;l;c|])) gls + let l=constr_of_term p.p_lhs and + r=constr_of_term p.p_rhs in + let typ = (* Termops.refresh_universes *)pf_type_of gls l in + (app_global _sym_eq [|typ;r;l;c|] exact_check) gls end | Refl t -> Proofview.V82.tactic begin fun gls -> - let lr = constr_of_term t in - let typ = Termops.refresh_universes (pf_type_of gls lr) in - exact_check - (mkApp(Lazy.force _refl_equal,[|typ;constr_of_term t|])) gls + let lr = constr_of_term t in + let typ = (* Termops.refresh_universes *) (pf_type_of gls lr) in + (app_global _refl_equal [|typ;constr_of_term t|] exact_check) gls end | Trans (p1,p2)-> let t1 = constr_of_term p1.p_lhs and t2 = constr_of_term p1.p_rhs and t3 = constr_of_term p2.p_rhs in - let typ = Termops.refresh_universes (type_of t2) in - let prf = - mkApp(Lazy.force _trans_eq,[|typ;t1;t2;t3;_M 1;_M 2|]) in - Tacticals.New.tclTHENS (Proofview.V82.tactic (refine prf)) [(proof_tac p1);(proof_tac p2)] + let typ = (* Termops.refresh_universes *) (type_of t2) in + let prf = new_app_global _trans_eq [|typ;t1;t2;t3;_M 1;_M 2|] in + Tacticals.New.tclTHENS (prf new_refine) [(proof_tac p1);(proof_tac p2)] | Congr (p1,p2)-> let tf1=constr_of_term p1.p_lhs and tx1=constr_of_term p2.p_lhs and tf2=constr_of_term p1.p_rhs and tx2=constr_of_term p2.p_rhs in - let typf = Termops.refresh_universes (type_of tf1) in - let typx = Termops.refresh_universes (type_of tx1) in - let typfx = Termops.refresh_universes (type_of (mkApp (tf1,[|tx1|]))) in + let typf = (* Termops.refresh_universes *)(type_of tf1) in + let typx = (* Termops.refresh_universes *) (type_of tx1) in + let typfx = (* Termops.refresh_universes *) (type_of (mkApp (tf1,[|tx1|]))) in let id = Tacmach.New.of_old (fun gls -> pf_get_new_id (Id.of_string "f") gls) gl in let appx1 = mkLambda(Name id,typf,mkApp(mkRel 1,[|tx1|])) in let lemma1 = - mkApp(Lazy.force _f_equal, - [|typf;typfx;appx1;tf1;tf2;_M 1|]) in + app_global _f_equal + [|typf;typfx;appx1;tf1;tf2;_M 1|] in let lemma2= - mkApp(Lazy.force _f_equal, - [|typx;typfx;tf2;tx1;tx2;_M 1|]) in + app_global _f_equal + [|typx;typfx;tf2;tx1;tx2;_M 1|] in let prf = - mkApp(Lazy.force _trans_eq, + app_global _trans_eq [|typfx; mkApp(tf1,[|tx1|]); mkApp(tf2,[|tx1|]); - mkApp(tf2,[|tx2|]);_M 2;_M 3|]) in - Tacticals.New.tclTHENS (Proofview.V82.tactic (refine prf)) - [Tacticals.New.tclTHEN (Proofview.V82.tactic (refine lemma1)) (proof_tac p1); + mkApp(tf2,[|tx2|]);_M 2;_M 3|] in + Tacticals.New.tclTHENS (Proofview.V82.tactic (prf refine)) + [Tacticals.New.tclTHEN (Proofview.V82.tactic (lemma1 refine)) (proof_tac p1); Tacticals.New.tclFIRST - [Tacticals.New.tclTHEN (Proofview.V82.tactic (refine lemma2)) (proof_tac p2); + [Tacticals.New.tclTHEN (Proofview.V82.tactic (lemma2 refine)) (proof_tac p2); reflexivity; Proofview.tclZERO (UserError ("Congruence" , (Pp.str @@ -305,46 +312,48 @@ let rec proof_tac p : unit Proofview.tactic = let ti=constr_of_term prf.p_lhs in let tj=constr_of_term prf.p_rhs in let default=constr_of_term p.p_lhs in - let intype = Termops.refresh_universes (type_of ti) in - let outtype = Termops.refresh_universes (type_of default) in + let intype = (* Termops.refresh_universes *) (type_of ti) in + let outtype = (* Termops.refresh_universes *) (type_of default) in let special=mkRel (1+nargs-argind) in let proj = Tacmach.New.of_old (build_projection intype outtype cstr special default) gl in let injt= - mkApp (Lazy.force _f_equal,[|intype;outtype;proj;ti;tj;_M 1|]) in - Tacticals.New.tclTHEN (Proofview.V82.tactic (refine injt)) (proof_tac prf) + app_global _f_equal [|intype;outtype;proj;ti;tj;_M 1|] in + Tacticals.New.tclTHEN (Proofview.V82.tactic (injt refine)) (proof_tac prf) + with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e end let refute_tac c t1 t2 p = Proofview.Goal.enter begin fun gl -> let tt1=constr_of_term t1 and tt2=constr_of_term t2 in let intype = - Tacmach.New.of_old (fun gls -> Termops.refresh_universes (pf_type_of gls tt1)) gl + Tacmach.New.of_old (fun gls -> (* Termops.refresh_universes *) (pf_type_of gls tt1)) gl in - let neweq= - mkApp(Lazy.force _eq, - [|intype;tt1;tt2|]) in + let neweq= new_app_global _eq [|intype;tt1;tt2|] in let hid = Tacmach.New.of_old (pf_get_new_id (Id.of_string "Heq")) gl in let false_t=mkApp (c,[|mkVar hid|]) in - Tacticals.New.tclTHENS (assert_tac (Name hid) neweq) + Tacticals.New.tclTHENS (neweq (assert_tac (Name hid))) [proof_tac p; simplest_elim false_t] end +let refine_exact_check c gl = + let evm, _ = pf_apply e_type_of gl c in + Tacticals.tclTHEN (Refiner.tclEVARS evm) (exact_check c) gl + let convert_to_goal_tac c t1 t2 p = Proofview.Goal.enter begin fun gl -> let tt1=constr_of_term t1 and tt2=constr_of_term t2 in let sort = - Tacmach.New.of_old (fun gls -> Termops.refresh_universes (pf_type_of gls tt2)) gl + Tacmach.New.of_old (fun gls -> (* Termops.refresh_universes *) (pf_type_of gls tt2)) gl in - let neweq=mkApp(Lazy.force _eq,[|sort;tt1;tt2|]) in + let neweq= new_app_global _eq [|sort;tt1;tt2|] in let e = Tacmach.New.of_old (pf_get_new_id (Id.of_string "e")) gl in let x = Tacmach.New.of_old (pf_get_new_id (Id.of_string "X")) gl in let identity=mkLambda (Name x,sort,mkRel 1) in - let endt=mkApp (Lazy.force _eq_rect, - [|sort;tt1;identity;c;tt2;mkVar e|]) in - Tacticals.New.tclTHENS (assert_tac (Name e) neweq) - [proof_tac p; Proofview.V82.tactic (exact_check endt)] + let endt=app_global _eq_rect [|sort;tt1;identity;c;tt2;mkVar e|] in + Tacticals.New.tclTHENS (neweq (assert_tac (Name e))) + [proof_tac p; Proofview.V82.tactic (endt refine_exact_check)] end let convert_to_hyp_tac c1 t1 c2 t2 p = @@ -357,29 +366,36 @@ let convert_to_hyp_tac c1 t1 c2 t2 p = simplest_elim false_t] end -let discriminate_tac cstr p = +let discriminate_tac (cstr,u as cstru) p = Proofview.Goal.enter begin fun gl -> let t1=constr_of_term p.p_lhs and t2=constr_of_term p.p_rhs in let intype = - Tacmach.New.of_old (fun gls -> Termops.refresh_universes (pf_type_of gls t1)) gl + Tacmach.New.of_old (fun gls -> (* Termops.refresh_universes *) (pf_type_of gls t1)) gl in let concl = Proofview.Goal.concl gl in - let outsort = mkType (Termops.new_univ ()) in + (* let evm,outsort = Evd.new_sort_variable Evd.univ_rigid (project gls) in *) + (* let outsort = mkSort outsort in *) let xid = Tacmach.New.of_old (pf_get_new_id (Id.of_string "X")) gl in - let tid = Tacmach.New.of_old (pf_get_new_id (Id.of_string "t")) gl in - let identity=mkLambda(Name xid,outsort,mkLambda(Name tid,mkRel 1,mkRel 1)) in - let trivial = Tacmach.New.of_old (fun gls -> pf_type_of gls identity) gl in - let outtype = mkType (Termops.new_univ ()) in + (* let tid = Tacmach.New.of_old (pf_get_new_id (Id.of_string "t")) gl in *) + (* let identity=mkLambda(Name xid,outsort,mkLambda(Name tid,mkRel 1,mkRel 1)) in *) + let identity = Universes.constr_of_global _I in + (* let trivial=pf_type_of gls identity in *) + let trivial = Universes.constr_of_global _True in + let evm, outtype = Evd.new_sort_variable Evd.univ_flexible (Proofview.Goal.sigma gl) in + let outtype = mkSort outtype in let pred=mkLambda(Name xid,outtype,mkRel 1) in let hid = Tacmach.New.of_old (pf_get_new_id (Id.of_string "Heq")) gl in - let proj = Tacmach.New.of_old (build_projection intype outtype cstr trivial concl) gl in - let injt=mkApp (Lazy.force _f_equal, - [|intype;outtype;proj;t1;t2;mkVar hid|]) in - let endt=mkApp (Lazy.force _eq_rect, - [|outtype;trivial;pred;identity;concl;injt|]) in - let neweq=mkApp(Lazy.force _eq,[|intype;t1;t2|]) in - Tacticals.New.tclTHENS (assert_tac (Name hid) neweq) - [proof_tac p; Proofview.V82.tactic (exact_check endt)] + let proj = Tacmach.New.of_old (build_projection intype outtype cstru trivial concl) gl in + let injt=app_global _f_equal + [|intype;outtype;proj;t1;t2;mkVar hid|] in + let endt k = + injt (fun injt -> + app_global _eq_rect + [|outtype;trivial;pred;identity;concl;injt|] k) in + let neweq=new_app_global _eq [|intype;t1;t2|] in + Tacticals.New.tclTHEN (Proofview.V82.tclEVARS evm) + (Tacticals.New.tclTHENS (neweq (assert_tac (Name hid))) + [proof_tac p; Proofview.V82.tactic (endt exact_check)]) end (* wrap everything *) @@ -389,7 +405,7 @@ let build_term_to_complete uf meta pac = let real_args = List.map (fun i -> constr_of_term (term uf i)) pac.args in let dummy_args = List.rev (List.init pac.arity meta) in let all_args = List.rev_append real_args dummy_args in - applistc (mkConstruct cinfo.ci_constr) all_args + applistc (mkConstructU cinfo.ci_constr) all_args let cc_tactic depth additionnal_terms = Proofview.Goal.enter begin fun gl -> @@ -457,7 +473,7 @@ let congruence_tac depth l = might be slow now, let's rather do something equivalent to a "simple apply refl_equal" *) -let simple_reflexivity () = apply (Lazy.force _refl_equal) +let simple_reflexivity () = apply (Universes.constr_of_global _refl_equal) (* The [f_equal] tactic. @@ -472,15 +488,17 @@ let f_equal = let type_of = Tacmach.New.pf_type_of gl in let cut_eq c1 c2 = try (* type_of can raise an exception *) - let ty = Termops.refresh_universes (type_of c1) in - Tacticals.New.tclTRY (Tacticals.New.tclTHEN - (Tactics.cut (mkApp (Lazy.force _eq, [|ty; c1; c2|]))) - (Tacticals.New.tclTRY (Proofview.V82.tactic (simple_reflexivity ())))) + let ty = (* Termops.refresh_universes *) (type_of c1) in + if eq_constr_nounivs c1 c2 then Proofview.tclUNIT () + else + Tacticals.New.tclTRY (Tacticals.New.tclTHEN + ((new_app_global _eq [|ty; c1; c2|]) Tactics.cut) + (Tacticals.New.tclTRY ((new_app_global _refl_equal [||]) (fun c -> Proofview.V82.tactic (apply c))))) with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e in Proofview.tclORELSE begin match kind_of_term concl with - | App (r,[|_;t;t'|]) when eq_constr r (Lazy.force _eq) -> + | App (r,[|_;t;t'|]) when Globnames.is_global _eq r -> begin match kind_of_term t, kind_of_term t' with | App (f,v), App (f',v') when Int.equal (Array.length v) (Array.length v') -> let rec cuts i = diff --git a/plugins/cc/cctac.mli b/plugins/cc/cctac.mli index a022a07da..7c1d9f1c0 100644 --- a/plugins/cc/cctac.mli +++ b/plugins/cc/cctac.mli @@ -1,3 +1,4 @@ + (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) diff --git a/plugins/decl_mode/decl_interp.ml b/plugins/decl_mode/decl_interp.ml index 505d7dba5..e0aee15e6 100644 --- a/plugins/decl_mode/decl_interp.ml +++ b/plugins/decl_mode/decl_interp.ml @@ -144,26 +144,26 @@ let intern_proof_instr globs instr= (* INTERP *) let interp_justification_items sigma env = - Option.map (List.map (fun c ->understand sigma env (fst c))) + Option.map (List.map (fun c -> fst (*FIXME*)(understand sigma env (fst c)))) let interp_constr check_sort sigma env c = if check_sort then - understand sigma env ~expected_type:IsType (fst c) + fst (understand sigma env ~expected_type:IsType (fst c) (* FIXME *)) else - understand sigma env (fst c) + fst (understand sigma env (fst c)) let special_whd env = let infos=Closure.create_clos_infos Closure.betadeltaiota env in (fun t -> Closure.whd_val infos (Closure.inject t)) -let _eq = Globnames.constr_of_global (Coqlib.glob_eq) +let _eq = lazy (Universes.constr_of_global (Coqlib.glob_eq)) let decompose_eq env id = let typ = Environ.named_type id env in let whd = special_whd env typ in match kind_of_term whd with App (f,args)-> - if eq_constr f _eq && Int.equal (Array.length args) 3 + if eq_constr f (Lazy.force _eq) && Int.equal (Array.length args) 3 then args.(0) else error "Previous step is not an equality." | _ -> error "Previous step is not an equality." @@ -173,7 +173,7 @@ let get_eq_typ info env = typ let interp_constr_in_type typ sigma env c = - understand sigma env (fst c) ~expected_type:(OfType typ) + fst (understand sigma env (fst c) ~expected_type:(OfType typ))(*FIXME*) let interp_statement interp_it sigma env st = {st_label=st.st_label; @@ -213,7 +213,7 @@ let rec match_hyps blend names constr = function qhyp::rhyps,head let interp_hyps_gen inject blend sigma env hyps head = - let constr=understand sigma env (glob_constr_of_hyps inject hyps head) in + let constr= fst(*FIXME*) (understand sigma env (glob_constr_of_hyps inject hyps head)) in match_hyps blend [] constr hyps let interp_hyps sigma env hyps = fst (interp_hyps_gen fst (fun x _ -> x) sigma env hyps glob_prop) @@ -246,7 +246,7 @@ let rec glob_of_pat = add_params (pred n) (GHole(Loc.ghost, Evar_kinds.TomatchTypeParameter(ind,n), None)::q) in let args = List.map glob_of_pat lpat in - glob_app(loc,GRef(Loc.ghost,Globnames.ConstructRef cstr), + glob_app(loc,GRef(Loc.ghost,Globnames.ConstructRef cstr,None), add_params mind.Declarations.mind_nparams args) let prod_one_hyp = function @@ -333,7 +333,7 @@ let interp_cases info sigma env params (pat:cases_pattern_expr) hyps = (if Int.equal expected 0 then str "none" else int expected) ++ spc () ++ str "expected.") in let app_ind = - let rind = GRef (Loc.ghost,Globnames.IndRef pinfo.per_ind) in + let rind = GRef (Loc.ghost,Globnames.IndRef pinfo.per_ind,None) in let rparams = List.map detype_ground pinfo.per_params in let rparams_rec = List.map @@ -365,7 +365,7 @@ let interp_cases info sigma env params (pat:cases_pattern_expr) hyps = let term3=List.fold_right let_in_one_alias aliases term2 in let term4=List.fold_right prod_one_id loc_ids term3 in let term5=List.fold_right prod_one_hyp params term4 in - let constr = understand sigma env term5 in + let constr = fst (understand sigma env term5)(*FIXME*) in let tparams,nam4,rest4 = match_args destProd [] constr params in let tpatvars,nam3,rest3 = match_args destProd nam4 rest4 loc_ids in let taliases,nam2,rest2 = match_aliases nam3 rest3 aliases in @@ -409,7 +409,7 @@ let interp_suffices_clause sigma env (hyps,cot)= nenv,res let interp_casee sigma env = function - Real c -> Real (understand sigma env (fst c)) + Real c -> Real (fst (understand sigma env (fst c)))(*FIXME*) | Virtual cut -> Virtual (interp_cut (interp_no_bind (interp_statement (interp_constr true))) sigma env cut) let abstract_one_arg = function @@ -425,7 +425,7 @@ let glob_constr_of_fun args body = List.fold_right abstract_one_arg args (fst body) let interp_fun sigma env args body = - let constr=understand sigma env (glob_constr_of_fun args body) in + let constr=fst (*FIXME*) (understand sigma env (glob_constr_of_fun args body)) in match_args destLambda [] constr args let rec interp_bare_proof_instr info (sigma:Evd.evar_map) (env:Environ.env) = function @@ -448,7 +448,7 @@ let rec interp_bare_proof_instr info (sigma:Evd.evar_map) (env:Environ.env) = fu let tparams,tpat,thyps = interp_cases info sigma env params pat hyps in Pcase (tparams,tpat,thyps) | Ptake witl -> - Ptake (List.map (fun c -> understand sigma env (fst c)) witl) + Ptake (List.map (fun c -> fst (*FIXME*) (understand sigma env (fst c))) witl) | Pconsider (c,hyps) -> Pconsider (interp_constr false sigma env c, interp_hyps sigma env hyps) | Pper (et,c) -> Pper (et,interp_casee sigma env c) diff --git a/plugins/decl_mode/decl_proof_instr.ml b/plugins/decl_mode/decl_proof_instr.ml index de57330ec..8647ca676 100644 --- a/plugins/decl_mode/decl_proof_instr.ml +++ b/plugins/decl_mode/decl_proof_instr.ml @@ -292,13 +292,13 @@ let rec replace_in_list m l = function let enstack_subsubgoals env se stack gls= let hd,params = decompose_app (special_whd gls se.se_type) in match kind_of_term hd with - Ind ind when is_good_inductive env ind -> + Ind (ind,u as indu) when is_good_inductive env ind -> (* MS: FIXME *) let mib,oib= Inductive.lookup_mind_specif env ind in let gentypes= - Inductive.arities_of_constructors ind (mib,oib) in + Inductive.arities_of_constructors indu (mib,oib) in let process i gentyp = - let constructor = mkConstruct(ind,succ i) + let constructor = mkConstructU ((ind,succ i),u) (* constructors numbering*) in let appterm = applist (constructor,params) in let apptype = prod_applist gentyp params in @@ -357,7 +357,7 @@ let find_subsubgoal c ctyp skip submetas gls = try let unifier = Unification.w_unify env se.se_evd Reduction.CUMUL - ~flags:Unification.elim_flags ctyp se.se_type in + ~flags:(Unification.elim_flags ()) ctyp se.se_type in if n <= 0 then {se with se_evd=meta_assign se.se_meta @@ -488,14 +488,14 @@ let instr_cut mkstat _thus _then cut gls0 = (* iterated equality *) -let _eq = Globnames.constr_of_global (Coqlib.glob_eq) +let _eq = lazy (Universes.constr_of_global (Coqlib.glob_eq)) let decompose_eq id gls = let typ = pf_get_hyp_typ gls id in let whd = (special_whd gls typ) in match kind_of_term whd with App (f,args)-> - if eq_constr f _eq && Int.equal (Array.length args) 3 + if eq_constr f (Lazy.force _eq) && Int.equal (Array.length args) 3 then (args.(0), args.(1), args.(2)) @@ -530,14 +530,14 @@ let instr_rew _thus rew_side cut gls0 = else tclIDTAC gls in match rew_side with Lhs -> - let new_eq = mkApp(_eq,[|typ;cut.cut_stat.st_it;rhs|]) in + let new_eq = mkApp(Lazy.force _eq,[|typ;cut.cut_stat.st_it;rhs|]) in tclTHENS (Proofview.V82.of_tactic (assert_postpone c_id new_eq)) [tclTHEN tcl_erase_info (tclTHENS (Proofview.V82.of_tactic (transitivity lhs)) [just_tac;exact_check (mkVar last_id)]); thus_tac new_eq] gls0 | Rhs -> - let new_eq = mkApp(_eq,[|typ;lhs;cut.cut_stat.st_it|]) in + let new_eq = mkApp(Lazy.force _eq,[|typ;lhs;cut.cut_stat.st_it|]) in tclTHENS (Proofview.V82.of_tactic (assert_postpone c_id new_eq)) [tclTHEN tcl_erase_info (tclTHENS (Proofview.V82.of_tactic (transitivity rhs)) @@ -663,11 +663,11 @@ let conjunction_arity id gls = let hd,params = decompose_app (special_whd gls typ) in let env =pf_env gls in match kind_of_term hd with - Ind ind when is_good_inductive env ind -> + Ind (ind,u as indu) when is_good_inductive env ind -> let mib,oib= Inductive.lookup_mind_specif env ind in let gentypes= - Inductive.arities_of_constructors ind (mib,oib) in + Inductive.arities_of_constructors indu (mib,oib) in let _ = if not (Int.equal (Array.length gentypes) 1) then raise Not_found in let apptype = prod_applist gentypes.(0) params in let rc,_ = Reduction.dest_prod env apptype in @@ -832,7 +832,7 @@ let build_per_info etype casee gls = let ctyp=pf_type_of gls casee in let is_dep = dependent casee concl in let hd,args = decompose_app (special_whd gls ctyp) in - let ind = + let (ind,u as indu) = try destInd hd with DestKO -> @@ -1031,7 +1031,7 @@ let rec st_assoc id = function let thesis_for obj typ per_info env= let rc,hd1=decompose_prod typ in let cind,all_args=decompose_app typ in - let ind = destInd cind in + let ind,u = destInd cind in let _ = if not (eq_ind ind per_info.per_ind) then errorlabstrm "thesis_for" ((Printer.pr_constr_env env obj) ++ spc () ++ @@ -1166,7 +1166,7 @@ let hrec_for fix_id per_info gls obj_id = let typ=pf_get_hyp_typ gls obj_id in let rc,hd1=decompose_prod typ in let cind,all_args=decompose_app typ in - let ind = destInd cind in assert (eq_ind ind per_info.per_ind); + let ind,u = destInd cind in assert (eq_ind ind per_info.per_ind); let params,args= List.chop per_info.per_nparams all_args in assert begin try List.for_all2 eq_constr params per_info.per_params with @@ -1205,7 +1205,8 @@ let rec execute_cases fix_name per_info tacnext args objs nhrec tree gls = let env=pf_env gls in let ctyp=pf_type_of gls casee in let hd,all_args = decompose_app (special_whd gls ctyp) in - let _ = assert (eq_ind (destInd hd) ind) in (* just in case *) + let ind', u = destInd hd in + let _ = assert (eq_ind ind' ind) in (* just in case *) let params,real_args = List.chop nparams all_args in let abstract_obj c body = let typ=pf_type_of gls c in @@ -1213,7 +1214,7 @@ let rec execute_cases fix_name per_info tacnext args objs nhrec tree gls = let elim_pred = List.fold_right abstract_obj real_args (lambda_create env (ctyp,subst_term casee concl)) in let case_info = Inductiveops.make_case_info env ind RegularStyle in - let gen_arities = Inductive.arities_of_constructors ind spec in + let gen_arities = Inductive.arities_of_constructors (ind,u) spec in let f_ids typ = let sign = (prod_assum (prod_applist typ params)) in diff --git a/plugins/decl_mode/g_decl_mode.ml4 b/plugins/decl_mode/g_decl_mode.ml4 index 7c9ef3c2a..36abb86cc 100644 --- a/plugins/decl_mode/g_decl_mode.ml4 +++ b/plugins/decl_mode/g_decl_mode.ml4 @@ -176,7 +176,7 @@ GLOBAL: proof_instr; statement : [[ i=ident ; ":" ; c=constr -> {st_label=Name i;st_it=c} | i=ident -> {st_label=Anonymous; - st_it=Constrexpr.CRef (Libnames.Ident (!@loc, i))} + st_it=Constrexpr.CRef (Libnames.Ident (!@loc, i), None)} | c=constr -> {st_label=Anonymous;st_it=c} ]]; constr_or_thesis : @@ -189,7 +189,7 @@ GLOBAL: proof_instr; | [ i=ident ; ":" ; cot=constr_or_thesis -> {st_label=Name i;st_it=cot} | i=ident -> {st_label=Anonymous; - st_it=This (Constrexpr.CRef (Libnames.Ident (!@loc, i)))} + st_it=This (Constrexpr.CRef (Libnames.Ident (!@loc, i), None))} | c=constr -> {st_label=Anonymous;st_it=This c} ] ]; diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index 791294902..74de31368 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -131,7 +131,7 @@ end exception Impossible let check_arity env cb = - let t = Typeops.type_of_constant_type env cb.const_type in + let t = cb.const_type in if Reduction.is_arity env t then raise Impossible let check_fix env cb i = diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index 3927ad328..5b79f6d78 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -203,27 +203,28 @@ let oib_equal o1 o2 = Id.equal o1.mind_typename o2.mind_typename && List.equal eq_rel_declaration o1.mind_arity_ctxt o2.mind_arity_ctxt && begin match o1.mind_arity, o2.mind_arity with - | Monomorphic {mind_user_arity=c1; mind_sort=s1}, - Monomorphic {mind_user_arity=c2; mind_sort=s2} -> + (* | Monomorphic {mind_user_arity=c1; mind_sort=s1}, *) + (* Monomorphic {mind_user_arity=c2; mind_sort=s2} -> *) + (* eq_constr c1 c2 && Sorts.equal s1 s2 *) + (* | ma1, ma2 -> Pervasives.(=) ma1 ma2 (\** FIXME: this one is surely wrong *\) end && *) + (* Array.equal Id.equal o1.mind_consnames o2.mind_consnames *) + | {mind_user_arity=c1; mind_sort=s1}, + {mind_user_arity=c2; mind_sort=s2} -> eq_constr c1 c2 && Sorts.equal s1 s2 - | Polymorphic p1, Polymorphic p2 -> - let eq o1 o2 = Option.equal Univ.Universe.equal o1 o2 in - List.equal eq p1.poly_param_levels p2.poly_param_levels && - Univ.Universe.equal p1.poly_level p2.poly_level - | Monomorphic _, Polymorphic _ | Polymorphic _, Monomorphic _ -> false end && Array.equal Id.equal o1.mind_consnames o2.mind_consnames let mib_equal m1 m2 = Array.equal oib_equal m1.mind_packets m1.mind_packets && - (m1.mind_record : bool) == m2.mind_record && + (m1.mind_record) = m2.mind_record && (*FIXME*) (m1.mind_finite : bool) == m2.mind_finite && Int.equal m1.mind_ntypes m2.mind_ntypes && List.equal eq_named_declaration m1.mind_hyps m2.mind_hyps && Int.equal m1.mind_nparams m2.mind_nparams && Int.equal m1.mind_nparams_rec m2.mind_nparams_rec && List.equal eq_rel_declaration m1.mind_params_ctxt m2.mind_params_ctxt && - Univ.eq_constraint m1.mind_constraints m2.mind_constraints + Pervasives.(=) m1.mind_universes m2.mind_universes (** FIXME *) + (* m1.mind_universes = m2.mind_universes *) (*S Extraction of a type. *) @@ -278,10 +279,10 @@ let rec extract_type env db j c args = if n > List.length db then Tunknown else let n' = List.nth db (n-1) in if Int.equal n' 0 then Tunknown else Tvar n') - | Const kn -> + | Const (kn,u as c) -> let r = ConstRef kn in let cb = lookup_constant kn env in - let typ = Typeops.type_of_constant_type env cb.const_type in + let typ,_ = Typeops.type_of_constant env c in (match flag_of_type env typ with | (Logic,_) -> assert false (* Cf. logical cases above *) | (Info, TypeScheme) -> @@ -306,7 +307,7 @@ let rec extract_type env db j c args = (* We try to reduce. *) let newc = applist (Mod_subst.force_constr lbody, args) in extract_type env db j newc [])) - | Ind (kn,i) -> + | Ind ((kn,i),u) -> let s = (extract_ind env kn).ind_packets.(i).ip_sign in extract_type_app env db (IndRef (kn,i),s) args | Case _ | Fix _ | CoFix _ -> Tunknown @@ -388,8 +389,10 @@ and extract_ind env kn = (* kn is supposed to be in long form *) let packets = Array.mapi (fun i mip -> - let ar = Inductive.type_of_inductive env (mib,mip) in - let info = (fst (flag_of_type env ar) == Info) in + let (ind,u), ctx = + Universes.fresh_inductive_instance env (kn,i) in + let ar = Inductive.type_of_inductive env ((mib,mip),u) in + let info = (fst (flag_of_type env ar) = Info) in let s,v = if info then type_sign_vl env ar else [],[] in let t = Array.make (Array.length mip.mind_nf_lc) [] in { ip_typename = mip.mind_typename; @@ -397,21 +400,21 @@ and extract_ind env kn = (* kn is supposed to be in long form *) ip_logical = not info; ip_sign = s; ip_vars = v; - ip_types = t }) + ip_types = t }, u) mib.mind_packets in add_ind kn mib {ind_kind = Standard; ind_nparams = npar; - ind_packets = packets; + ind_packets = Array.map fst packets; ind_equiv = equiv }; (* Second pass: we extract constructors *) for i = 0 to mib.mind_ntypes - 1 do - let p = packets.(i) in + let p,u = packets.(i) in if not p.ip_logical then - let types = arities_of_constructors env (kn,i) in + let types = arities_of_constructors env ((kn,i),u) in for j = 0 to Array.length types - 1 do let t = snd (decompose_prod_n npar types.(j)) in let prods,head = dest_prod epar t in @@ -433,7 +436,7 @@ and extract_ind env kn = (* kn is supposed to be in long form *) if is_custom r then raise (I Standard); if not mib.mind_finite then raise (I Coinductive); if not (Int.equal mib.mind_ntypes 1) then raise (I Standard); - let p = packets.(0) in + let p,u = packets.(0) in if p.ip_logical then raise (I Standard); if not (Int.equal (Array.length p.ip_types) 1) then raise (I Standard); let typ = p.ip_types.(0) in @@ -442,7 +445,7 @@ and extract_ind env kn = (* kn is supposed to be in long form *) Int.equal (List.length l) 1 && not (type_mem_kn kn (List.hd l)) then raise (I Singleton); if List.is_empty l then raise (I Standard); - if not mib.mind_record then raise (I Standard); + if Option.is_empty mib.mind_record then raise (I Standard); (* Now we're sure it's a record. *) (* First, we find its field names. *) let rec names_prod t = match kind_of_term t with @@ -476,7 +479,7 @@ and extract_ind env kn = (* kn is supposed to be in long form *) (* If so, we use this information. *) begin try let n = nb_default_params env - (Inductive.type_of_inductive env (mib,mip0)) + (Inductive.type_of_inductive env ((mib,mip0),u)) in let check_proj kn = if Cset.mem kn !projs then add_projection n kn in List.iter (Option.iter check_proj) (lookup_projections ip) @@ -487,7 +490,7 @@ and extract_ind env kn = (* kn is supposed to be in long form *) in let i = {ind_kind = ind_info; ind_nparams = npar; - ind_packets = packets; + ind_packets = Array.map fst packets; ind_equiv = equiv } in add_ind kn mib i; @@ -522,7 +525,7 @@ and mlt_env env r = match r with | _ -> None with Not_found -> let cb = Environ.lookup_constant kn env in - let typ = Typeops.type_of_constant_type env cb.const_type in + let typ = cb.const_type (* FIXME not sure if we should instantiate univs here *) in match cb.const_body with | Undef _ | OpaqueDef _ -> None | Def l_body -> @@ -550,7 +553,7 @@ let record_constant_type env kn opt_typ = lookup_type kn with Not_found -> let typ = match opt_typ with - | None -> Typeops.type_of_constant env kn + | None -> (lookup_constant kn env).const_type | Some typ -> typ in let mlt = extract_type env [] 1 typ [] in let schema = (type_maxvar mlt, mlt) @@ -605,10 +608,12 @@ let rec extract_term env mle mlt c args = with NotDefault d -> let mle' = Mlenv.push_std_type mle (Tdummy d) in ast_pop (extract_term env' mle' mlt c2 args')) - | Const kn -> - extract_cst_app env mle mlt kn args - | Construct cp -> - extract_cons_app env mle mlt cp args + | Const (kn,u) -> + extract_cst_app env mle mlt kn u args + | Construct (cp,u) -> + extract_cons_app env mle mlt cp u args + | Proj (p, c) -> + extract_cst_app env mle mlt p Univ.Instance.empty (c :: args) | Rel n -> (* As soon as the expected [mlt] for the head is known, *) (* we unify it with an fresh copy of the stored type of [Rel n]. *) @@ -656,7 +661,7 @@ and make_mlargs env e s args typs = (*s Extraction of a constant applied to arguments. *) -and extract_cst_app env mle mlt kn args = +and extract_cst_app env mle mlt kn u args = (* First, the [ml_schema] of the constant, in expanded version. *) let nb,t = record_constant_type env kn None in let schema = nb, expand env t in @@ -729,7 +734,7 @@ and extract_cst_app env mle mlt kn args = they are fixed, and thus are not used for the computation. \end{itemize} *) -and extract_cons_app env mle mlt (((kn,i) as ip,j) as cp) args = +and extract_cons_app env mle mlt (((kn,i) as ip,j) as cp) u args = (* First, we build the type of the constructor, stored in small pieces. *) let mi = extract_ind env kn in let params_nb = mi.ind_nparams in @@ -971,7 +976,7 @@ let extract_fixpoint env vkn (fi,ti,ci) = let extract_constant env kn cb = let r = ConstRef kn in - let typ = Typeops.type_of_constant_type env cb.const_type in + let typ = cb.const_type in let warn_info () = if not (is_custom r) then add_info_axiom r in let warn_log () = if not (constant_has_body cb) then add_log_axiom r in @@ -1018,7 +1023,7 @@ let extract_constant env kn cb = let extract_constant_spec env kn cb = let r = ConstRef kn in - let typ = Typeops.type_of_constant_type env cb.const_type in + let typ = cb.const_type in match flag_of_type env typ with | (Logic, TypeScheme) -> Stype (r, [], Some (Tdummy Ktype)) | (Logic, Default) -> Sval (r, Tdummy Kother) diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml index ba21c6cbf..133f4ada9 100644 --- a/plugins/extraction/table.ml +++ b/plugins/extraction/table.ml @@ -645,7 +645,7 @@ let implicits_of_global r = try Refmap'.find r !implicits_table with Not_found -> [] let add_implicits r l = - let typ = Global.type_of_global r in + let typ = Global.type_of_global_unsafe r in let rels,_ = decompose_prod (Reduction.whd_betadeltaiota (Global.env ()) typ) in let names = List.rev_map fst rels in @@ -816,7 +816,7 @@ let extract_constant_inline inline r ids s = match g with | ConstRef kn -> let env = Global.env () in - let typ = Typeops.type_of_constant env kn in + let typ = (Environ.lookup_constant kn env).const_type in let typ = Reduction.whd_betadeltaiota env typ in if Reduction.is_arity env typ then begin diff --git a/plugins/firstorder/formula.ml b/plugins/firstorder/formula.ml index 03a832e90..430b549d9 100644 --- a/plugins/firstorder/formula.ml +++ b/plugins/firstorder/formula.ml @@ -43,7 +43,7 @@ let rec nb_prod_after n c= | _ -> 0 let construct_nhyps ind gls = - let nparams = (fst (Global.lookup_inductive ind)).mind_nparams in + let nparams = (fst (Global.lookup_inductive (fst ind))).mind_nparams in let constr_types = Inductiveops.arities_of_constructors (pf_env gls) ind in let hyp = nb_prod_after nparams in Array.map hyp constr_types @@ -67,10 +67,10 @@ let special_whd gl= type kind_of_formula= Arrow of constr*constr - | False of inductive*constr list - | And of inductive*constr list*bool - | Or of inductive*constr list*bool - | Exists of inductive*constr list + | False of pinductive*constr list + | And of pinductive*constr list*bool + | Or of pinductive*constr list*bool + | Exists of pinductive*constr list | Forall of constr*constr | Atom of constr @@ -85,11 +85,11 @@ let kind_of_formula gl term = |_-> match match_with_nodep_ind cciterm with Some (i,l,n)-> - let ind=destInd i in + let ind,u=destInd i in let (mib,mip) = Global.lookup_inductive ind in let nconstr=Array.length mip.mind_consnames in if Int.equal nconstr 0 then - False(ind,l) + False((ind,u),l) else let has_realargs=(n>0) in let is_trivial= @@ -102,9 +102,9 @@ let kind_of_formula gl term = Atom cciterm else if Int.equal nconstr 1 then - And(ind,l,is_trivial) + And((ind,u),l,is_trivial) else - Or(ind,l,is_trivial) + Or((ind,u),l,is_trivial) | _ -> match match_with_sigma_type cciterm with Some (i,l)-> Exists((destInd i),l) @@ -186,19 +186,19 @@ type right_pattern = type left_arrow_pattern= LLatom - | LLfalse of inductive*constr list - | LLand of inductive*constr list - | LLor of inductive*constr list + | LLfalse of pinductive*constr list + | LLand of pinductive*constr list + | LLor of pinductive*constr list | LLforall of constr - | LLexists of inductive*constr list + | LLexists of pinductive*constr list | LLarrow of constr*constr*constr type left_pattern= Lfalse - | Land of inductive - | Lor of inductive + | Land of pinductive + | Lor of pinductive | Lforall of metavariable*constr*bool - | Lexists of inductive + | Lexists of pinductive | LA of constr*left_arrow_pattern type t={id:global_reference; diff --git a/plugins/firstorder/formula.mli b/plugins/firstorder/formula.mli index 59b363393..d12b106cc 100644 --- a/plugins/firstorder/formula.mli +++ b/plugins/firstorder/formula.mli @@ -25,9 +25,9 @@ type ('a,'b) sum = Left of 'a | Right of 'b type counter = bool -> metavariable -val construct_nhyps : inductive -> Proof_type.goal Tacmach.sigma -> int array +val construct_nhyps : pinductive -> Proof_type.goal Tacmach.sigma -> int array -val ind_hyps : int -> inductive -> constr list -> +val ind_hyps : int -> pinductive -> constr list -> Proof_type.goal Tacmach.sigma -> rel_context array type atoms = {positive:constr list;negative:constr list} @@ -49,19 +49,19 @@ type right_pattern = type left_arrow_pattern= LLatom - | LLfalse of inductive*constr list - | LLand of inductive*constr list - | LLor of inductive*constr list + | LLfalse of pinductive*constr list + | LLand of pinductive*constr list + | LLor of pinductive*constr list | LLforall of constr - | LLexists of inductive*constr list + | LLexists of pinductive*constr list | LLarrow of constr*constr*constr type left_pattern= Lfalse - | Land of inductive - | Lor of inductive + | Land of pinductive + | Lor of pinductive | Lforall of metavariable*constr*bool - | Lexists of inductive + | Lexists of pinductive | LA of constr*left_arrow_pattern type t={id: global_reference; diff --git a/plugins/firstorder/ground.ml b/plugins/firstorder/ground.ml index 6c1709140..e0f4fa95f 100644 --- a/plugins/firstorder/ground.ml +++ b/plugins/firstorder/ground.ml @@ -18,7 +18,7 @@ let update_flags ()= let predref=ref Names.Cpred.empty in let f coe= try - let kn=destConst (Classops.get_coercion_value coe) in + let kn= fst (destConst (Classops.get_coercion_value coe)) in predref:=Names.Cpred.add kn !predref with DestKO -> () in diff --git a/plugins/firstorder/instances.ml b/plugins/firstorder/instances.ml index fe22708a0..c6db6a49f 100644 --- a/plugins/firstorder/instances.ml +++ b/plugins/firstorder/instances.ml @@ -101,6 +101,8 @@ let dummy_constr=mkMeta (-1) let dummy_bvid=Id.of_string "x" +let constr_of_global = Universes.constr_of_global + let mk_open_instance id gl m t= let env=pf_env gl in let evmap=Refiner.project gl in @@ -128,7 +130,7 @@ let mk_open_instance id gl m t= GLambda(loc,name,k,GHole (Loc.ghost,Evar_kinds.BinderType name,None),t1) | _-> anomaly (Pp.str "can't happen") in let ntt=try - Pretyping.understand evmap env (raux m rawt) + fst (Pretyping.understand evmap env (raux m rawt))(*FIXME*) with e when Errors.noncritical e -> error "Untypable instance, maybe higher-order non-prenex quantification" in decompose_lam_n_assum m ntt diff --git a/plugins/firstorder/rules.ml b/plugins/firstorder/rules.ml index 6d9af2bbf..31a1e6cb0 100644 --- a/plugins/firstorder/rules.ml +++ b/plugins/firstorder/rules.ml @@ -53,7 +53,7 @@ let clear_global=function VarRef id->clear [id] | _->tclIDTAC - +let constr_of_global = Universes.constr_of_global (* connection rules *) let axiom_tac t seq= @@ -117,14 +117,14 @@ let left_false_tac id= (* We use this function for false, and, or, exists *) -let ll_ind_tac ind largs backtrack id continue seq gl= - let rcs=ind_hyps 0 ind largs gl in +let ll_ind_tac (ind,u as indu) largs backtrack id continue seq gl= + let rcs=ind_hyps 0 indu largs gl in let vargs=Array.of_list largs in (* construire le terme H->B, le generaliser etc *) let myterm i= let rc=rcs.(i) in let p=List.length rc in - let cstr=mkApp ((mkConstruct (ind,(i+1))),vargs) in + let cstr=mkApp ((mkConstructU ((ind,(i+1)),u)),vargs) in let vars=Array.init p (fun j->mkRel (p-j)) in let capply=mkApp ((lift p cstr),vars) in let head=mkApp ((lift p (constr_of_global id)),[|capply|]) in @@ -204,8 +204,8 @@ let ll_forall_tac prod backtrack id continue seq= let constant str = Coqlib.gen_constant "User" ["Init";"Logic"] str let defined_connectives=lazy - [AllOccurrences,EvalConstRef (destConst (constant "not")); - AllOccurrences,EvalConstRef (destConst (constant "iff"))] + [AllOccurrences,EvalConstRef (fst (destConst (constant "not"))); + AllOccurrences,EvalConstRef (fst (destConst (constant "iff")))] let normalize_evaluables= onAllHypsAndConcl diff --git a/plugins/firstorder/rules.mli b/plugins/firstorder/rules.mli index bfebbaaf8..180f6f5da 100644 --- a/plugins/firstorder/rules.mli +++ b/plugins/firstorder/rules.mli @@ -33,19 +33,19 @@ val or_tac : seqtac with_backtracking val arrow_tac : seqtac with_backtracking -val left_and_tac : inductive -> lseqtac with_backtracking +val left_and_tac : pinductive -> lseqtac with_backtracking -val left_or_tac : inductive -> lseqtac with_backtracking +val left_or_tac : pinductive -> lseqtac with_backtracking val left_false_tac : global_reference -> tactic -val ll_ind_tac : inductive -> constr list -> lseqtac with_backtracking +val ll_ind_tac : pinductive -> constr list -> lseqtac with_backtracking val ll_arrow_tac : constr -> constr -> constr -> lseqtac with_backtracking val forall_tac : seqtac with_backtracking -val left_exists_tac : inductive -> lseqtac with_backtracking +val left_exists_tac : pinductive -> lseqtac with_backtracking val ll_forall_tac : types -> lseqtac with_backtracking diff --git a/plugins/firstorder/sequent.ml b/plugins/firstorder/sequent.ml index 72bde18f4..c0e5c7e58 100644 --- a/plugins/firstorder/sequent.ml +++ b/plugins/firstorder/sequent.ml @@ -199,7 +199,7 @@ let expand_constructor_hints = let extend_with_ref_list l seq gl= let l = expand_constructor_hints l in let f gr seq= - let c=constr_of_global gr in + let c=Universes.constr_of_global gr in let typ=(pf_type_of gl c) in add_formula Hyp gr typ seq gl in List.fold_right f l seq @@ -210,10 +210,10 @@ let extend_with_auto_hints l seq gl= let seqref=ref seq in let f p_a_t = match p_a_t.code with - Res_pf (c,_) | Give_exact c + Res_pf (c,_) | Give_exact (c,_) | Res_pf_THEN_trivial_fail (c,_) -> (try - let gr=global_of_constr c in + let gr = global_of_constr c in let typ=(pf_type_of gl c) in seqref:=add_formula Hint gr typ !seqref gl with Not_found->()) diff --git a/plugins/firstorder/unify.ml b/plugins/firstorder/unify.ml index 2556460f5..f7ee9fdad 100644 --- a/plugins/firstorder/unify.ml +++ b/plugins/firstorder/unify.ml @@ -78,7 +78,7 @@ let unif t1 t2= for i=0 to l-1 do Queue.add (va.(i),vb.(i)) bige done - | _->if not (eq_constr nt1 nt2) then raise (UFAIL (nt1,nt2)) + | _->if not (eq_constr_nounivs nt1 nt2) then raise (UFAIL (nt1,nt2)) done; assert false (* this place is unreachable but needed for the sake of typing *) diff --git a/plugins/fourier/fourierR.ml b/plugins/fourier/fourierR.ml index aeb07fc3a..d34d50364 100644 --- a/plugins/fourier/fourierR.ml +++ b/plugins/fourier/fourierR.ml @@ -87,7 +87,7 @@ let string_of_R_constant kn = let rec string_of_R_constr c = match kind_of_term c with Cast (c,_,_) -> string_of_R_constr c - |Const c -> string_of_R_constant c + |Const (c,_) -> string_of_R_constant c | _ -> "not_of_constant" exception NoRational @@ -114,7 +114,7 @@ let rec rational_of_constr c = rminus (rational_of_constr args.(0)) (rational_of_constr args.(1)) | _ -> raise NoRational) - | Const kn -> + | Const (kn,_) -> (match (string_of_R_constant kn) with "R1" -> r1 |"R0" -> r0 @@ -160,7 +160,7 @@ let rec flin_of_constr c = with NoRational -> flin_add (flin_zero()) args.(0) (rinv b)) |_-> raise NoLinear) - | Const c -> + | Const (c,_) -> (match (string_of_R_constant c) with "R1" -> flin_one () |"R0" -> flin_zero () @@ -194,7 +194,7 @@ let ineq1_of_constr (h,t) = match (kind_of_term t) with | App (f,args) -> (match kind_of_term f with - | Const c when Array.length args = 2 -> + | Const (c,_) when Array.length args = 2 -> let t1= args.(0) in let t2= args.(1) in (match (string_of_R_constant c) with @@ -227,13 +227,13 @@ let ineq1_of_constr (h,t) = (flin_of_constr t1); hstrict=false}] |_-> raise NoIneq) - | Ind (kn,i) -> + | Ind ((kn,i),_) -> if not (eq_gr (IndRef(kn,i)) Coqlib.glob_eq) then raise NoIneq; let t0= args.(0) in let t1= args.(1) in let t2= args.(2) in (match (kind_of_term t0) with - | Const c -> + | Const (c,_) -> (match (string_of_R_constant c) with | "R"-> [{hname=h; @@ -609,8 +609,9 @@ let rec fourier gl= [tclORELSE (* TODO : Ring.polynom []*) tclIDTAC tclIDTAC; - (tclTHEN (apply (get coq_sym_eqT)) - (apply (get coq_Rinv_1)))] + pf_constr_of_global (get coq_sym_eqT) (fun symeq -> + (tclTHEN (apply symeq) + (apply (get coq_Rinv_1))))] ) ])); diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index f06d8fa53..a3af23dcd 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -124,11 +124,13 @@ let finish_proof dynamic_infos g = let refine c = - Tacmach.refine_no_check c + Tacmach.refine c let thin l = Tacmach.thin_no_check l +let eq_constr u v = eq_constr_nounivs u v + let is_trivial_eq t = let res = try begin @@ -205,7 +207,7 @@ let prove_trivial_eq h_id context (constructor,type_of_term,term) = let find_rectype env c = - let (t, l) = decompose_app (Reduction.whd_betaiotazeta c) in + let (t, l) = decompose_app (Reduction.whd_betaiotazeta env c) in match kind_of_term t with | Ind ind -> (t, l) | Construct _ -> (t,l) @@ -233,7 +235,7 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type = failwith "NoChange"; end in - let eq_constr = Reductionops.is_conv env sigma in + let eq_constr = Evarconv.e_conv env (ref sigma) in if not (noccurn 1 end_of_type) then nochange "dependent"; (* if end_of_type depends on this term we don't touch it *) if not (isApp t) then nochange "not an equality"; @@ -325,7 +327,8 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type = let all_ids = pf_ids_of_hyps g in let new_ids,_ = list_chop ctxt_size all_ids in let to_refine = applist(witness_fun,List.rev_map mkVar new_ids) in - refine to_refine g + let evm, _ = pf_apply Typing.e_type_of g to_refine in + tclTHEN (Refiner.tclEVARS evm) (refine to_refine) g ) in let simpl_eq_tac = @@ -633,8 +636,11 @@ let instanciate_hyps_with_args (do_prove:Id.t list -> tactic) hyps args_id = ( (* we instanciate the hyp if possible *) fun g -> let prov_hid = pf_get_new_id hid g in + let c = mkApp(mkVar hid,args) in + let evm, _ = pf_apply Typing.e_type_of g c in tclTHENLIST[ - Proofview.V82.of_tactic (pose_proof (Name prov_hid) (mkApp(mkVar hid,args))); + Refiner.tclEVARS evm; + Proofview.V82.of_tactic (pose_proof (Name prov_hid) c); thin [hid]; rename_hyp [prov_hid,hid] ] g @@ -757,6 +763,7 @@ let build_proof begin match kind_of_term f with | App _ -> assert false (* we have collected all the app in decompose_app *) + | Proj _ -> assert false (*FIXME*) | Var _ | Construct _ | Rel _ | Evar _ | Meta _ | Ind _ | Sort _ | Prod _ -> let new_infos = { dyn_infos with @@ -764,7 +771,7 @@ let build_proof } in build_proof_args do_finalize new_infos g - | Const c when not (List.mem_f Constant.equal c fnames) -> + | Const (c,_) when not (List.mem_f Constant.equal c fnames) -> let new_infos = { dyn_infos with info = (f,args) @@ -809,6 +816,7 @@ let build_proof | Fix _ | CoFix _ -> error ( "Anonymous local (co)fixpoints are not handled yet") + | Proj _ -> error "Prod" | Prod _ -> error "Prod" | LetIn _ -> let new_infos = @@ -938,7 +946,7 @@ let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num = (* observe (str "nb_args := " ++ str (string_of_int nb_args)); *) (* observe (str "nb_params := " ++ str (string_of_int nb_params)); *) (* observe (str "rec_args_num := " ++ str (string_of_int (rec_args_num + 1) )); *) - let f_def = Global.lookup_constant (destConst f) in + let f_def = Global.lookup_constant (fst (destConst f)) in let eq_lhs = mkApp(f,Array.init (nb_params + nb_args) (fun i -> mkRel(nb_params + nb_args - i))) in let f_body = Option.get (body_of_constant f_def) in @@ -956,10 +964,10 @@ let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num = let eq_rhs = nf_betaiotazeta (mkApp(compose_lam params f_body_with_params_and_other_fun,Array.init (nb_params + nb_args) (fun i -> mkRel(nb_params + nb_args - i)))) in (* observe (str "eq_rhs " ++ pr_lconstr eq_rhs); *) let type_ctxt,type_of_f = decompose_prod_n_assum (nb_params + nb_args) - (Typeops.type_of_constant_type (Global.env()) f_def.const_type) in + ((*FIXME*)f_def.const_type) in let eqn = mkApp(Lazy.force eq,[|type_of_f;eq_lhs;eq_rhs|]) in let lemma_type = it_mkProd_or_LetIn eqn type_ctxt in - let f_id = Label.to_id (con_label (destConst f)) in + let f_id = Label.to_id (con_label (fst (destConst f))) in let prove_replacement = tclTHENSEQ [ @@ -978,8 +986,8 @@ let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num = Ensures by: obvious i*) (mk_equation_id f_id) - (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem)) - lemma_type + (Decl_kinds.Global, false, (Decl_kinds.Proof Decl_kinds.Theorem)) + (lemma_type, (*FIXME*) Univ.ContextSet.empty) (fun _ _ -> ()); ignore (Pfedit.by (Proofview.V82.tactic prove_replacement)); Lemmas.save_proof (Vernacexpr.Proved(false,None)) @@ -990,10 +998,10 @@ let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num = let do_replace params rec_arg_num rev_args_id f fun_num all_funs g = let equation_lemma = try - let finfos = find_Function_infos (destConst f) in + let finfos = find_Function_infos (fst (destConst f)) (*FIXME*) in mkConst (Option.get finfos.equation_lemma) with (Not_found | Option.IsNone as e) -> - let f_id = Label.to_id (con_label (destConst f)) in + let f_id = Label.to_id (con_label (fst (destConst f))) in (*i The next call to mk_equation_id is valid since we will construct the lemma Ensures by: obvious i*) @@ -1002,7 +1010,7 @@ let do_replace params rec_arg_num rev_args_id f fun_num all_funs g = let _ = match e with | Option.IsNone -> - let finfos = find_Function_infos (destConst f) in + let finfos = find_Function_infos (fst (destConst f)) in update_Function {finfos with equation_lemma = Some (match Nametab.locate (qualid_of_ident equation_lemma_id) with @@ -1306,7 +1314,7 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : in let fname = destConst (fst (decompose_app (List.hd (List.rev pte_args)))) in tclTHENSEQ - [unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef fname)]; + [unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (fst fname))]; let do_prove = build_proof interactive_proof diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index d6f21fb86..2adc82505 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -106,14 +106,14 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = let pre_princ = substl (List.map mkVar ptes_vars) pre_princ in let is_dom c = match kind_of_term c with - | Ind((u,_)) -> MutInd.equal u rel_as_kn - | Construct((u,_),_) -> MutInd.equal u rel_as_kn + | Ind((u,_),_) -> MutInd.equal u rel_as_kn + | Construct(((u,_),_),_) -> MutInd.equal u rel_as_kn | _ -> false in let get_fun_num c = match kind_of_term c with - | Ind(_,num) -> num - | Construct((_,num),_) -> num + | Ind((_,num),_) -> num + | Construct(((_,num),_),_) -> num | _ -> assert false in let dummy_var = mkVar (Id.of_string "________") in @@ -251,8 +251,10 @@ let change_property_sort toSort princ princName = let princ_info = compute_elim_sig princ in let change_sort_in_predicate (x,v,t) = (x,None, - let args,_ = decompose_prod t in - compose_prod args (mkSort toSort) + let args,ty = decompose_prod t in + let s = destSort ty in + Global.add_constraints (Univ.enforce_leq (univ_of_sort toSort) (univ_of_sort s) Univ.Constraint.empty); + compose_prod args (mkSort toSort) ) in let princName_as_constr = Constrintern.global_reference princName in @@ -292,8 +294,8 @@ let build_functional_principle interactive_proof old_princ_type sorts funs i pro begin Lemmas.start_proof new_princ_name - (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem)) - new_principle_type + (Decl_kinds.Global,false,(Decl_kinds.Proof Decl_kinds.Theorem)) + (new_principle_type, (*FIXME*) Univ.ContextSet.empty) hook ; (* let _tim1 = System.get_time () in *) @@ -315,7 +317,7 @@ let generate_functional_principle try let f = funs.(i) in - let type_sort = Termops.new_sort_in_family InType in + let type_sort = Universes.new_sort_in_family InType in let new_sorts = match sorts with | None -> Array.make (Array.length funs) (type_sort) @@ -334,18 +336,23 @@ let generate_functional_principle then (* let id_of_f = Label.to_id (con_label f) in *) let register_with_sort fam_sort = - let s = Termops.new_sort_in_family fam_sort in + let s = Universes.new_sort_in_family fam_sort in let name = Indrec.make_elimination_ident base_new_princ_name fam_sort in let value = change_property_sort s new_principle_type new_princ_name in (* Pp.msgnl (str "new principle := " ++ pr_lconstr value); *) - let ce = { - const_entry_body = Future.from_val (value,Declareops.no_seff); - const_entry_secctx = None; - const_entry_type = None; - const_entry_opaque = false; - const_entry_inline_code = false; - const_entry_feedback = None; - } in + let ce = + { const_entry_body = + Future.from_val (value,Declareops.no_seff); + const_entry_secctx = None; + const_entry_type = None; + const_entry_polymorphic = false; + const_entry_universes = Univ.UContext.empty (*FIXME*); + const_entry_proj = None; + const_entry_opaque = false; + const_entry_feedback = None; + const_entry_inline_code = false + } + in ignore( Declare.declare_constant name @@ -488,19 +495,20 @@ let make_scheme (fas : (constant*glob_sort) list) : Entries.definition_entry lis List.map (fun (idx) -> let ind = first_fun_kn,idx in - ind,true,prop_sort + (ind,Univ.Instance.empty)(*FIXME*),true,prop_sort ) funs_indexes in + let sigma, schemes = + Indrec.build_mutual_induction_scheme env sigma ind_list + in let l_schemes = - List.map - (Typing.type_of env sigma) - (Indrec.build_mutual_induction_scheme env sigma ind_list) + List.map (Typing.type_of env sigma) schemes in let i = ref (-1) in let sorts = List.rev_map (fun (_,x) -> - Termops.new_sort_in_family (Pretyping.interp_elimination_sort x) + Universes.new_sort_in_family (Pretyping.interp_elimination_sort x) ) fas in @@ -649,10 +657,10 @@ let build_case_scheme fa = (* Constrintern.global_reference id *) (* in *) let funs = (fun (_,f,_) -> - try Globnames.constr_of_global (Nametab.global f) + try Universes.constr_of_global (Nametab.global f) with Not_found -> Errors.error ("Cannot find "^ Libnames.string_of_reference f)) fa in - let first_fun = destConst funs in + let first_fun,u = destConst funs in let funs_mp,funs_dp,_ = Names.repr_con first_fun in let first_fun_kn = try fst (find_Function_infos first_fun).graph_ind with Not_found -> raise No_graph_found in @@ -664,16 +672,18 @@ let build_case_scheme fa = let prop_sort = InProp in let funs_indexes = let this_block_funs_indexes = Array.to_list this_block_funs_indexes in - List.assoc_f Constant.equal (destConst funs) this_block_funs_indexes + List.assoc_f Constant.equal (fst (destConst funs)) this_block_funs_indexes in let ind_fun = let ind = first_fun_kn,funs_indexes in - ind,prop_sort + (ind,Univ.Instance.empty)(*FIXME*),prop_sort in - let scheme_type = (Typing.type_of env sigma ) ((fun (ind,sf) -> Indrec.build_case_analysis_scheme_default env sigma ind sf) ind_fun) in + let sigma, scheme = + (fun (ind,sf) -> Indrec.build_case_analysis_scheme_default env sigma ind sf) ind_fun in + let scheme_type = (Typing.type_of env sigma ) scheme in let sorts = (fun (_,_,x) -> - Termops.new_sort_in_family (Pretyping.interp_elimination_sort x) + Universes.new_sort_in_family (Pretyping.interp_elimination_sort x) ) fa in @@ -690,6 +700,6 @@ let build_case_scheme fa = (Some princ_name) this_block_funs 0 - (prove_princ_for_struct false 0 [|destConst funs|]) + (prove_princ_for_struct false 0 [|fst (destConst funs)|]) in () diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4 index 2dd78d890..3802aa365 100644 --- a/plugins/funind/g_indfun.ml4 +++ b/plugins/funind/g_indfun.ml4 @@ -307,8 +307,11 @@ let rec hdMatchSub inu (test: constr -> bool) : fapp_info list = max_rel = max_rel; onlyvars = List.for_all isVar args } ::subres +let make_eq () = +(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq ()) + let mkEq typ c1 c2 = - mkApp (Coqlib.build_coq_eq(),[| typ; c1; c2|]) + mkApp (make_eq(),[| typ; c1; c2|]) let poseq_unsafe idunsafe cstr gl = @@ -463,10 +466,10 @@ VERNAC COMMAND EXTEND MergeFunind CLASSIFIED AS SIDEFF [ "Mergeschemes" "(" ident(id1) ne_ident_list(cl1) ")" "with" "(" ident(id2) ne_ident_list(cl2) ")" "using" ident(id) ] -> [ - let f1 = Constrintern.interp_constr Evd.empty (Global.env()) - (CRef (Libnames.Ident (Loc.ghost,id1))) in - let f2 = Constrintern.interp_constr Evd.empty (Global.env()) - (CRef (Libnames.Ident (Loc.ghost,id2))) in + let f1,ctx = Constrintern.interp_constr Evd.empty (Global.env()) + (CRef (Libnames.Ident (Loc.ghost,id1),None)) in + let f2,ctx' = Constrintern.interp_constr Evd.empty (Global.env()) + (CRef (Libnames.Ident (Loc.ghost,id2),None)) in let f1type = Typing.type_of (Global.env()) Evd.empty f1 in let f2type = Typing.type_of (Global.env()) Evd.empty f2 in let ar1 = List.length (fst (decompose_prod f1type)) in diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index dd02dfe8d..4544f736c 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -333,8 +333,8 @@ let raw_push_named (na,raw_value,raw_typ) env = match na with | Anonymous -> env | Name id -> - let value = Option.map (Pretyping.understand Evd.empty env) raw_value in - let typ = Pretyping.understand Evd.empty env ~expected_type:Pretyping.IsType raw_typ in + let value = Option.map (fun x-> fst (Pretyping.understand Evd.empty env x)) raw_value in + let typ,ctx = Pretyping.understand Evd.empty env ~expected_type:Pretyping.IsType raw_typ in Environ.push_named (id,value,typ) env @@ -350,7 +350,7 @@ let add_pat_variables pat typ env : Environ.env = with Not_found -> assert false in let constructors = Inductiveops.get_constructors env indf in - let constructor : Inductiveops.constructor_summary = List.find (fun cs -> eq_constructor c cs.Inductiveops.cs_cstr) (Array.to_list constructors) in + let constructor : Inductiveops.constructor_summary = List.find (fun cs -> eq_constructor c (fst cs.Inductiveops.cs_cstr)) (Array.to_list constructors) in let cs_args_types :types list = List.map (fun (_,_,t) -> t) constructor.Inductiveops.cs_args in List.fold_left2 add_pat_variables env patl (List.rev cs_args_types) in @@ -397,7 +397,7 @@ let rec pattern_to_term_and_type env typ = function with Not_found -> assert false in let constructors = Inductiveops.get_constructors env indf in - let constructor = List.find (fun cs -> eq_constructor cs.Inductiveops.cs_cstr constr) (Array.to_list constructors) in + let constructor = List.find (fun cs -> eq_constructor (fst cs.Inductiveops.cs_cstr) constr) (Array.to_list constructors) in let cs_args_types :types list = List.map (fun (_,_,t) -> t) constructor.Inductiveops.cs_args in let _,cstl = Inductiveops.dest_ind_family indf in let csta = Array.of_list cstl in @@ -486,7 +486,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = a pseudo value "v1 ... vn". The "value" of this branch is then simply [res] *) - let rt_as_constr = Pretyping.understand Evd.empty env rt in + let rt_as_constr,ctx = Pretyping.understand Evd.empty env rt in let rt_typ = Typing.type_of env Evd.empty rt_as_constr in let res_raw_type = Detyping.detype false [] (Termops.names_of_rel_context env) rt_typ in let res = fresh_id args_res.to_avoid "_res" in @@ -559,6 +559,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = *) build_entry_lc env funnames avoid (mkGApp(b,args)) | GRec _ -> error "Not handled GRec" + | GProj _ -> error "Not handled GProj" | GProd _ -> error "Cannot apply a type" end (* end of the application treatement *) @@ -594,7 +595,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = and combine the two result *) let v_res = build_entry_lc env funnames avoid v in - let v_as_constr = Pretyping.understand Evd.empty env v in + let v_as_constr,ctx = Pretyping.understand Evd.empty env v in let v_type = Typing.type_of env Evd.empty v_as_constr in let new_env = match n with @@ -610,7 +611,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = let make_discr = make_discr_match brl in build_entry_lc_from_case env funnames make_discr el brl avoid | GIf(_,b,(na,e_option),lhs,rhs) -> - let b_as_constr = Pretyping.understand Evd.empty env b in + let b_as_constr,ctx = Pretyping.understand Evd.empty env b in let b_typ = Typing.type_of env Evd.empty b_as_constr in let (ind,_) = try Inductiveops.find_inductive env Evd.empty b_typ @@ -619,7 +620,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = Printer.pr_glob_constr b ++ str " in " ++ Printer.pr_glob_constr rt ++ str ". try again with a cast") in - let case_pats = build_constructors_of_type ind [] in + let case_pats = build_constructors_of_type (fst ind) [] in assert (Int.equal (Array.length case_pats) 2); let brl = List.map_i @@ -642,7 +643,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = ) nal in - let b_as_constr = Pretyping.understand Evd.empty env b in + let b_as_constr,ctx = Pretyping.understand Evd.empty env b in let b_typ = Typing.type_of env Evd.empty b_as_constr in let (ind,_) = try Inductiveops.find_inductive env Evd.empty b_typ @@ -651,7 +652,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = Printer.pr_glob_constr b ++ str " in " ++ Printer.pr_glob_constr rt ++ str ". try again with a cast") in - let case_pats = build_constructors_of_type ind nal_as_glob_constr in + let case_pats = build_constructors_of_type (fst ind) nal_as_glob_constr in assert (Int.equal (Array.length case_pats) 1); let br = (Loc.ghost,[],[case_pats.(0)],e) @@ -661,6 +662,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = end | GRec _ -> error "Not handled GRec" + | GProj _ -> error "Not handled GProj" | GCast(_,b,_) -> build_entry_lc env funnames avoid b and build_entry_lc_from_case env funname make_discr @@ -689,7 +691,7 @@ and build_entry_lc_from_case env funname make_discr in let types = List.map (fun (case_arg,_) -> - let case_arg_as_constr = Pretyping.understand Evd.empty env case_arg in + let case_arg_as_constr,ctx = Pretyping.understand Evd.empty env case_arg in Typing.type_of env Evd.empty case_arg_as_constr ) el in @@ -844,7 +846,7 @@ let is_res id = let same_raw_term rt1 rt2 = match rt1,rt2 with - | GRef(_,r1), GRef (_,r2) -> Globnames.eq_gr r1 r2 + | GRef(_,r1,_), GRef (_,r2,_) -> Globnames.eq_gr r1 r2 | GHole _, GHole _ -> true | _ -> false let decompose_raw_eq lhs rhs = @@ -894,7 +896,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = let new_t = mkGApp(mkGVar(mk_rel_id this_relname),args'@[res_rt]) in - let t' = Pretyping.understand Evd.empty env new_t in + let t',ctx = Pretyping.understand Evd.empty env new_t in let new_env = Environ.push_rel (n,None,t') env in let new_b,id_to_exclude = rebuild_cons new_env @@ -907,14 +909,14 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = | _ -> (* the first args is the name of the function! *) assert false end - | GApp(loc1,GRef(loc2,eq_as_ref),[ty;GVar(loc3,id);rt]) + | GApp(loc1,GRef(loc2,eq_as_ref,_),[ty;GVar(loc3,id);rt]) when Globnames.eq_gr eq_as_ref (Lazy.force Coqlib.coq_eq_ref) && n == Anonymous -> begin try observe (str "computing new type for eq : " ++ pr_glob_constr rt); let t' = - try Pretyping.understand Evd.empty env t + try fst (Pretyping.understand Evd.empty env t)(*FIXME*) with e when Errors.noncritical e -> raise Continue in let is_in_b = is_free_in id b in @@ -936,17 +938,17 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = in mkGProd(n,t,new_b),id_to_exclude with Continue -> - let jmeq = Globnames.IndRef (destInd (jmeq ())) in - let ty' = Pretyping.understand Evd.empty env ty in + let jmeq = Globnames.IndRef (fst (destInd (jmeq ()))) in + let ty',ctx = Pretyping.understand Evd.empty env ty in let ind,args' = Inductive.find_inductive env ty' in - let mib,_ = Global.lookup_inductive ind in + let mib,_ = Global.lookup_inductive (fst ind) in let nparam = mib.Declarations.mind_nparams in let params,arg' = ((Util.List.chop nparam args')) in let rt_typ = GApp(Loc.ghost, - GRef (Loc.ghost,Globnames.IndRef ind), + GRef (Loc.ghost,Globnames.IndRef (fst ind),None), (List.map (fun p -> Detyping.detype false [] (Termops.names_of_rel_context env) @@ -956,10 +958,10 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = (mkGHole ())))) in let eq' = - GApp(loc1,GRef(loc2,jmeq),[ty;GVar(loc3,id);rt_typ;rt]) + GApp(loc1,GRef(loc2,jmeq,None),[ty;GVar(loc3,id);rt_typ;rt]) in observe (str "computing new type for jmeq : " ++ pr_glob_constr eq'); - let eq'_as_constr = Pretyping.understand Evd.empty env eq' in + let eq'_as_constr,ctx = Pretyping.understand Evd.empty env eq' in observe (str " computing new type for jmeq : done") ; let new_args = match kind_of_term eq'_as_constr with @@ -1007,7 +1009,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = if is_in_b then b else replace_var_by_term id rt b in let new_env = - let t' = Pretyping.understand Evd.empty env eq' in + let t',ctx = Pretyping.understand Evd.empty env eq' in Environ.push_rel (n,None,t') env in let new_b,id_to_exclude = @@ -1024,7 +1026,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = mkGProd(n,t,new_b),id_to_exclude else new_b, Id.Set.add id id_to_exclude *) - | GApp(loc1,GRef(loc2,eq_as_ref),[ty;rt1;rt2]) + | GApp(loc1,GRef(loc2,eq_as_ref,_),[ty;rt1;rt2]) when Globnames.eq_gr eq_as_ref (Lazy.force Coqlib.coq_eq_ref) && n == Anonymous -> begin @@ -1045,7 +1047,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = else raise Continue with Continue -> observe (str "computing new type for prod : " ++ pr_glob_constr rt); - let t' = Pretyping.understand Evd.empty env t in + let t',ctx = Pretyping.understand Evd.empty env t in let new_env = Environ.push_rel (n,None,t') env in let new_b,id_to_exclude = rebuild_cons new_env @@ -1061,7 +1063,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = end | _ -> observe (str "computing new type for prod : " ++ pr_glob_constr rt); - let t' = Pretyping.understand Evd.empty env t in + let t',ctx = Pretyping.understand Evd.empty env t in let new_env = Environ.push_rel (n,None,t') env in let new_b,id_to_exclude = rebuild_cons new_env @@ -1080,7 +1082,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = let not_free_in_t id = not (is_free_in id t) in let new_crossed_types = t :: crossed_types in observe (str "computing new type for lambda : " ++ pr_glob_constr rt); - let t' = Pretyping.understand Evd.empty env t in + let t',ctx = Pretyping.understand Evd.empty env t in match n with | Name id -> let new_env = Environ.push_rel (n,None,t') env in @@ -1102,7 +1104,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = | GLetIn(_,n,t,b) -> begin let not_free_in_t id = not (is_free_in id t) in - let t' = Pretyping.understand Evd.empty env t in + let t',ctx = Pretyping.understand Evd.empty env t in let type_t' = Typing.type_of env Evd.empty t' in let new_env = Environ.push_rel (n,Some t',type_t') env in let new_b,id_to_exclude = @@ -1127,7 +1129,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = args (crossed_types) depth t in - let t' = Pretyping.understand Evd.empty env new_t in + let t',ctx = Pretyping.understand Evd.empty env new_t in let new_env = Environ.push_rel (na,None,t') env in let new_b,id_to_exclude = rebuild_cons new_env @@ -1179,7 +1181,7 @@ let rec compute_cst_params relnames params = function discriminitation ones *) | GSort _ -> params | GHole _ -> params - | GIf _ | GRec _ | GCast _ -> + | GIf _ | GRec _ | GCast _ | GProj _-> raise (UserError("compute_cst_params", str "Not handled case")) and compute_cst_params_from_app acc (params,rtl) = match params,rtl with @@ -1267,12 +1269,12 @@ let do_build_inductive (fun (n,t,is_defined) acc -> if is_defined then - Constrexpr.CLetIn(Loc.ghost,(Loc.ghost, n),Constrextern.extern_glob_constr Id.Set.empty t, + Constrexpr.CLetIn(Loc.ghost,(Loc.ghost, n),with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t, acc) else Constrexpr.CProdN (Loc.ghost, - [[(Loc.ghost,n)],Constrexpr_ops.default_binder_kind,Constrextern.extern_glob_constr Id.Set.empty t], + [[(Loc.ghost,n)],Constrexpr_ops.default_binder_kind,with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t], acc ) ) @@ -1285,7 +1287,8 @@ let do_build_inductive *) let rel_arities = Array.mapi rel_arity funsargs in Util.Array.fold_left2 (fun env rel_name rel_ar -> - Environ.push_named (rel_name,None, Constrintern.interp_constr Evd.empty env rel_ar) env) env relnames rel_arities + Environ.push_named (rel_name,None, + fst (with_full_print (Constrintern.interp_constr Evd.empty env) rel_ar)) env) env relnames rel_arities in (* and of the real constructors*) let constr i res = @@ -1333,12 +1336,12 @@ let do_build_inductive (fun (n,t,is_defined) acc -> if is_defined then - Constrexpr.CLetIn(Loc.ghost,(Loc.ghost, n),Constrextern.extern_glob_constr Id.Set.empty t, + Constrexpr.CLetIn(Loc.ghost,(Loc.ghost, n),with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t, acc) else Constrexpr.CProdN (Loc.ghost, - [[(Loc.ghost,n)],Constrexpr_ops.default_binder_kind,Constrextern.extern_glob_constr Id.Set.empty t], + [[(Loc.ghost,n)],Constrexpr_ops.default_binder_kind,with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t], acc ) ) @@ -1366,8 +1369,7 @@ let do_build_inductive Array.map (List.map (fun (id,t) -> false,((Loc.ghost,id), - Flags.with_option - Flags.raw_print + with_full_print (Constrextern.extern_glob_type Id.Set.empty) ((* zeta_normalize *) t) ) )) @@ -1403,7 +1405,7 @@ let do_build_inductive (* in *) let _time2 = System.get_time () in try - with_full_print (Flags.silently (Command.do_mutual_inductive rel_inds)) true + with_full_print (Flags.silently (Command.do_mutual_inductive rel_inds false)) true with | UserError(s,msg) as e -> let _time3 = System.get_time () in diff --git a/plugins/funind/glob_termops.ml b/plugins/funind/glob_termops.ml index 6a7f326e6..5efaf7954 100644 --- a/plugins/funind/glob_termops.ml +++ b/plugins/funind/glob_termops.ml @@ -10,7 +10,7 @@ open Misctypes Some basic functions to rebuild glob_constr In each of them the location is Loc.ghost *) -let mkGRef ref = GRef(Loc.ghost,ref) +let mkGRef ref = GRef(Loc.ghost,ref,None) let mkGVar id = GVar(Loc.ghost,id) let mkGApp(rt,rtl) = GApp(Loc.ghost,rt,rtl) let mkGLambda(n,t,b) = GLambda(Loc.ghost,n,Explicit,t,b) @@ -180,6 +180,7 @@ let change_vars = | GRec _ -> error "Local (co)fixes are not supported" | GSort _ -> rt | GHole _ -> rt + | GProj _ -> error "Native projections are not supported" (** FIXME *) | GCast(loc,b,c) -> GCast(loc,change_vars mapping b, Miscops.map_cast_type (change_vars mapping) c) @@ -357,6 +358,7 @@ let rec alpha_rt excluded rt = alpha_rt excluded rhs ) | GRec _ -> error "Not handled GRec" + | GProj _ -> error "Native projections are not supported" (** FIXME *) | GSort _ -> rt | GHole _ -> rt | GCast (loc,b,c) -> @@ -407,6 +409,7 @@ let is_free_in id = | GIf(_,cond,_,br1,br2) -> is_free_in cond || is_free_in br1 || is_free_in br2 | GRec _ -> raise (UserError("",str "Not handled GRec")) + | GProj _ -> error "Native projections are not supported" (** FIXME *) | GSort _ -> false | GHole _ -> false | GCast (_,b,(CastConv t|CastVM t|CastNative t)) -> is_free_in b || is_free_in t @@ -503,6 +506,7 @@ let replace_var_by_term x_id term = replace_var_by_pattern rhs ) | GRec _ -> raise (UserError("",str "Not handled GRec")) + | GProj _ -> error "Native projections are not supported" (** FIXME *) | GSort _ -> rt | GHole _ -> rt | GCast(loc,b,c) -> @@ -598,6 +602,7 @@ let ids_of_glob_constr c = | GCases (loc,sty,rtntypopt,tml,brchl) -> List.flatten (List.map (fun (_,idl,patl,c) -> idl @ ids_of_glob_constr [] c) brchl) | GRec _ -> failwith "Fix inside a constructor branch" + | GProj _ -> error "Native projections are not supported" (** FIXME *) | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) -> [] in (* build the set *) @@ -656,6 +661,7 @@ let zeta_normalize = zeta_normalize_term rhs ) | GRec _ -> raise (UserError("",str "Not handled GRec")) + | GProj _ -> error "Native projections are not supported" (** FIXME *) | GSort _ -> rt | GHole _ -> rt | GCast(loc,b,c) -> @@ -698,6 +704,7 @@ let expand_as = GIf(loc,expand_as map e,(na,Option.map (expand_as map) po), expand_as map br1, expand_as map br2) | GRec _ -> error "Not handled GRec" + | GProj _ -> error "Native projections are not supported" (** FIXME *) | GCast(loc,b,c) -> GCast(loc,expand_as map b, Miscops.map_cast_type (expand_as map) c) diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 661e5e486..d98f824e8 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -38,7 +38,7 @@ let functional_induction with_clean c princl pat = | None -> (* No principle is given let's find the good one *) begin match kind_of_term f with - | Const c' -> + | Const (c',u) -> let princ_option = let finfo = (* we first try to find out a graph on f *) try find_Function_infos c' @@ -148,7 +148,7 @@ let build_newrecursive List.fold_left (fun (env,impls) ((_,recname),bl,arityc,_) -> let arityc = Constrexpr_ops.prod_constr_expr arityc bl in - let arity = Constrintern.interp_type sigma env0 arityc in + let arity,ctx = Constrintern.interp_type sigma env0 arityc in let impl = Constrintern.compute_internalization_data env0 Constrintern.Recursive arity [] in (Environ.push_named (recname,None,arity) env, Id.Map.add recname impl impls)) (env0,Constrintern.empty_internalization_env) lnameargsardef in @@ -182,6 +182,7 @@ let is_rec names = | GVar(_,id) -> check_id id names | GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ -> false | GCast(_,b,_) -> lookup names b + | GProj _ -> error "GProj not handled" | GRec _ -> error "GRec not handled" | GIf(_,b,_,lhs,rhs) -> (lookup names b) || (lookup names lhs) || (lookup names rhs) @@ -222,7 +223,7 @@ let derive_inversion fix_names = try (* we first transform the fix_names identifier into their corresponding constant *) let fix_names_as_constant = - List.map (fun id -> destConst (Constrintern.global_reference id)) fix_names + List.map (fun id -> fst (destConst (Constrintern.global_reference id))) fix_names in (* Then we check that the graphs have been defined @@ -239,7 +240,7 @@ let derive_inversion fix_names = Ensures by : register_built i*) (List.map - (fun id -> destInd (Constrintern.global_reference (mk_rel_id id))) + (fun id -> fst (destInd (Constrintern.global_reference (mk_rel_id id)))) fix_names ) with e when Errors.noncritical e -> @@ -326,9 +327,8 @@ let generate_principle on_error let _ = List.map_i (fun i x -> - let princ = destConst (Indrec.lookup_eliminator (ind_kn,i) (InProp)) in - let princ_type = Typeops.type_of_constant (Global.env()) princ - in + let princ = Indrec.lookup_eliminator (ind_kn,i) (InProp) in + let princ_type = Global.type_of_global_unsafe princ in Functional_principles_types.generate_functional_principle interactive_proof princ_type @@ -351,10 +351,10 @@ let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexp match fixpoint_exprl with | [((_,fname),_,bl,ret_type,body),_] when not is_rec -> let body = match body with | Some body -> body | None -> user_err_loc (Loc.ghost,"Function",str "Body of Function must be given") in - Command.do_definition fname (Decl_kinds.Global,Decl_kinds.Definition) + Command.do_definition fname (Decl_kinds.Global,(*FIXME*)false,Decl_kinds.Definition) bl None body (Some ret_type) (fun _ _ -> ()) | _ -> - Command.do_fixpoint Global fixpoint_exprl + Command.do_fixpoint Global false(*FIXME*) fixpoint_exprl let generate_correction_proof_wf f_ref tcc_lemma_ref is_mes functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation @@ -385,7 +385,7 @@ let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas let f_app_args = Constrexpr.CAppExpl (Loc.ghost, - (None,(Ident (Loc.ghost,fname))) , + (None,(Ident (Loc.ghost,fname)),None) , (List.map (function | _,Anonymous -> assert false @@ -399,7 +399,7 @@ let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas [(f_app_args,None);(body,None)]) in let eq = Constrexpr_ops.prod_constr_expr unbounded_eq args in - let hook f_ref tcc_lemma_ref functional_ref eq_ref rec_arg_num rec_arg_type + let hook (f_ref,_) tcc_lemma_ref (functional_ref,_) (eq_ref,_) rec_arg_num rec_arg_type nb_args relation = try pre_hook @@ -536,7 +536,7 @@ let rebuild_bl (aux,assoc) bl typ = rebuild_bl (aux,assoc) bl typ let recompute_binder_list (fixpoint_exprl : (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) = let fixl,ntns = Command.extract_fixpoint_components false fixpoint_exprl in - let ((_,_,typel),_) = Command.interp_fixpoint fixl ntns in + let ((_,_,typel),_,_) = Command.interp_fixpoint fixl ntns in let constr_expr_typel = with_full_print (List.map (Constrextern.extern_constr false (Global.env ()))) typel in let fixpoint_exprl_with_new_bl = @@ -631,10 +631,10 @@ let do_generate_principle on_error register_built interactive_proof let rec add_args id new_args b = match b with - | CRef r -> + | CRef (r,_) -> begin match r with | Libnames.Ident(loc,fname) when Id.equal fname id -> - CAppExpl(Loc.ghost,(None,r),new_args) + CAppExpl(Loc.ghost,(None,r,None),new_args) | _ -> b end | CFix _ | CCoFix _ -> anomaly ~label:"add_args " (Pp.str "todo") @@ -648,12 +648,12 @@ let rec add_args id new_args b = add_args id new_args b1) | CLetIn(loc,na,b1,b2) -> CLetIn(loc,na,add_args id new_args b1,add_args id new_args b2) - | CAppExpl(loc,(pf,r),exprl) -> + | CAppExpl(loc,(pf,r,us),exprl) -> begin match r with | Libnames.Ident(loc,fname) when Id.equal fname id -> - CAppExpl(loc,(pf,r),new_args@(List.map (add_args id new_args) exprl)) - | _ -> CAppExpl(loc,(pf,r),List.map (add_args id new_args) exprl) + CAppExpl(loc,(pf,r,us),new_args@(List.map (add_args id new_args) exprl)) + | _ -> CAppExpl(loc,(pf,r,us),List.map (add_args id new_args) exprl) end | CApp(loc,(pf,b),bl) -> CApp(loc,(pf,add_args id new_args b), @@ -767,11 +767,10 @@ let make_graph (f_ref:global_reference) = | Some body -> let env = Global.env () in let extern_body,extern_type = - with_full_print - (fun () -> + with_full_print (fun () -> (Constrextern.extern_constr false env body, Constrextern.extern_type false env - (Typeops.type_of_constant_type env c_body.const_type) + ((*FIXNE*) c_body.const_type) ) ) () @@ -792,7 +791,7 @@ let make_graph (f_ref:global_reference) = | Constrexpr.LocalRawAssum (nal,_,_) -> List.map (fun (loc,n) -> - CRef(Libnames.Ident(loc, Nameops.out_name n))) + CRef(Libnames.Ident(loc, Nameops.out_name n),None)) nal ) nal_tas diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index 5c37dcec3..8cccb0bed 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -114,7 +114,7 @@ let const_of_id id = let def_of_const t = match (Term.kind_of_term t) with Term.Const sp -> - (try (match Declareops.body_of_constant (Global.lookup_constant sp) with + (try (match Environ.constant_opt_value_in (Global.env()) sp with | Some c -> c | _ -> assert false) with Not_found -> assert false) @@ -146,7 +146,7 @@ let get_locality = function | Local -> true | Global -> false -let save with_clean id const (locality,kind) hook = +let save with_clean id const (locality,_,kind) hook = let l,r = match locality with | Discharge when Lib.sections_are_opened () -> let k = Kindops.logical_kind_of_goal_kind kind in @@ -177,7 +177,8 @@ let get_proof_clean do_reduce = let with_full_print f a = let old_implicit_args = Impargs.is_implicit_args () and old_strict_implicit_args = Impargs.is_strict_implicit_args () - and old_contextual_implicit_args = Impargs.is_contextual_implicit_args () in + and old_contextual_implicit_args = Impargs.is_contextual_implicit_args () + in let old_rawprint = !Flags.raw_print in Flags.raw_print := true; Impargs.make_implicit_args false; @@ -259,8 +260,8 @@ let cache_Function (_,finfos) = let load_Function _ = cache_Function let subst_Function (subst,finfos) = - let do_subst_con c = fst (Mod_subst.subst_con subst c) - and do_subst_ind (kn,i) = (Mod_subst.subst_ind subst kn,i) + let do_subst_con c = Mod_subst.subst_constant subst c + and do_subst_ind i = Mod_subst.subst_ind subst i in let function_constant' = do_subst_con finfos.function_constant in let graph_ind' = do_subst_ind finfos.graph_ind in @@ -336,7 +337,7 @@ let pr_info f_info = str "function_constant_type := " ++ (try Printer.pr_lconstr - (Global.type_of_global (ConstRef f_info.function_constant)) + (Global.type_of_global_unsafe (ConstRef f_info.function_constant)) with e when Errors.noncritical e -> mt ()) ++ fnl () ++ str "equation_lemma := " ++ pr_ocst f_info.equation_lemma ++ fnl () ++ str "completeness_lemma :=" ++ pr_ocst f_info.completeness_lemma ++ fnl () ++ diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli index 0e8b22deb..6e8b79a6b 100644 --- a/plugins/funind/indfun_common.mli +++ b/plugins/funind/indfun_common.mli @@ -58,7 +58,7 @@ val get_proof_clean : bool -> -(* [with_full_print f a] applies [f] to [a] in full printing environment +(* [with_full_print f a] applies [f] to [a] in full printing environment. This function preserves the print settings *) diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index 7c8f5714e..897c8765b 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -112,7 +112,9 @@ let id_to_constr id = let generate_type g_to_f f graph i = (*i we deduce the number of arguments of the function and its returned type from the graph i*) - let graph_arity = Inductive.type_of_inductive (Global.env()) (Global.lookup_inductive (destInd graph)) in + let gr,u = destInd graph in + let graph_arity = Inductive.type_of_inductive (Global.env()) + (Global.lookup_inductive gr, u) in let ctxt,_ = decompose_prod_assum graph_arity in let fun_ctxt,res_type = match ctxt with @@ -138,8 +140,11 @@ let generate_type g_to_f f graph i = the hypothesis [res = fv] can then be computed We will need to lift it by one in order to use it as a conclusion i*) + let make_eq () = +(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq ()) + in let res_eq_f_of_args = - mkApp(Coqlib.build_coq_eq (),[|lift 2 res_type;mkRel 1;mkRel 2|]) + mkApp(make_eq (),[|lift 2 res_type;mkRel 1;mkRel 2|]) in (*i The hypothesis [graph\ x_1\ldots x_n\ res] can then be computed @@ -166,7 +171,7 @@ let generate_type g_to_f f graph i = WARNING: while convertible, [type_of body] and [type] can be non equal *) let find_induction_principle f = - let f_as_constant = match kind_of_term f with + let f_as_constant,u = match kind_of_term f with | Const c' -> c' | _ -> error "Must be used with a function" in @@ -205,6 +210,11 @@ let rec generate_fresh_id x avoid i = let id = Namegen.next_ident_away_in_goal x avoid in id::(generate_fresh_id x (id::avoid) (pred i)) +let make_eq () = +(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq ()) +let make_eq_refl () = +(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq_refl ()) + (* [prove_fun_correct functional_induction funs_constr graphs_constr schemes lemmas_types_infos i ] is the tactic used to prove correctness lemma. @@ -237,7 +247,7 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem \[fun (x_1:t_1)\ldots(x_n:t_n)=> fun fv => fun res => res = fv \rightarrow graph\ x_1\ldots x_n\ res\] *) (* we the get the definition of the graphs block *) - let graph_ind = destInd graphs_constr.(i) in + let graph_ind,u = destInd graphs_constr.(i) in let kn = fst graph_ind in let mib,_ = Global.lookup_inductive graph_ind in (* and the principle to use in this lemma in $\zeta$ normal form *) @@ -267,8 +277,8 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem branches in (* before building the full intro pattern for the principle *) - let eq_ind = Coqlib.build_coq_eq () in - let eq_construct = mkConstruct((destInd eq_ind),1) in + let eq_ind = make_eq () in + let eq_construct = mkConstructUi (destInd eq_ind, 1) in (* The next to referencies will be used to find out which constructor to apply in each branch *) let ind_number = ref 0 and min_constr_number = ref 0 in @@ -731,7 +741,7 @@ let rec intros_with_rewrite g = observe_tac "intros_with_rewrite" intros_with_rewrite_aux g and intros_with_rewrite_aux : tactic = fun g -> - let eq_ind = Coqlib.build_coq_eq () in + let eq_ind = make_eq () in match kind_of_term (pf_concl g) with | Prod(_,t,t') -> begin @@ -830,7 +840,7 @@ let rec reflexivity_with_destruct_cases g = | _ -> Proofview.V82.of_tactic reflexivity with e when Errors.noncritical e -> Proofview.V82.of_tactic reflexivity in - let eq_ind = Coqlib.build_coq_eq () in + let eq_ind = make_eq () in let discr_inject = Tacticals.onAllHypsAndConcl ( fun sc g -> @@ -936,7 +946,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = let rewrite_tac j ids : tactic = let graph_def = graphs.(j) in let infos = - try find_Function_infos (destConst funcs.(j)) + try find_Function_infos (fst (destConst funcs.(j))) with Not_found -> error "No graph found" in if infos.is_general @@ -962,7 +972,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = thin ids ] else - unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (destConst f))] + unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (fst (destConst f)))] in (* The proof of each branche itself *) let ind_number = ref 0 in @@ -1026,7 +1036,7 @@ let derive_correctness make_scheme functional_induction (funs: constant list) (g let lemmas_types_infos = Util.Array.map2_i (fun i f_constr graph -> - let const_of_f = destConst f_constr in + let const_of_f,u = destConst f_constr in let (type_of_lemma_ctxt,type_of_lemma_concl) as type_info = generate_type false const_of_f graph i in @@ -1065,22 +1075,22 @@ let derive_correctness make_scheme functional_induction (funs: constant list) (g i*) let lem_id = mk_correct_id f_id in Lemmas.start_proof lem_id - (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem)) - (fst lemmas_types_infos.(i)) + (Decl_kinds.Global,false(*FIXME*),(Decl_kinds.Proof Decl_kinds.Theorem)) + (fst lemmas_types_infos.(i), (*FIXME*)Univ.ContextSet.empty) (fun _ _ -> ()); ignore (Pfedit.by (Proofview.V82.tactic (observe_tac ("prove correctness ("^(Id.to_string f_id)^")") (proving_tac i)))); do_save (); let finfo = find_Function_infos f_as_constant in - let lem_cst = destConst (Constrintern.global_reference lem_id) in + let lem_cst = fst (destConst (Constrintern.global_reference lem_id)) in update_Function {finfo with correctness_lemma = Some lem_cst} ) funs; let lemmas_types_infos = Util.Array.map2_i (fun i f_constr graph -> - let const_of_f = destConst f_constr in + let const_of_f = fst (destConst f_constr) in let (type_of_lemma_ctxt,type_of_lemma_concl) as type_info = generate_type true const_of_f graph i in @@ -1092,19 +1102,21 @@ let derive_correctness make_scheme functional_induction (funs: constant list) (g funs_constr graphs_constr in - let kn,_ as graph_ind = destInd graphs_constr.(0) in + let kn,_ as graph_ind = fst (destInd graphs_constr.(0)) in let mib,mip = Global.lookup_inductive graph_ind in - let schemes = - Array.of_list + let sigma, scheme = (Indrec.build_mutual_induction_scheme (Global.env ()) Evd.empty (Array.to_list (Array.mapi - (fun i _ -> (kn,i),true,InType) + (fun i _ -> ((kn,i),Univ.Instance.empty)(*FIXME*),true,InType) mib.Declarations.mind_packets ) ) ) in + let schemes = + Array.of_list scheme + in let proving_tac = prove_fun_complete funs_constr mib.Declarations.mind_packets schemes lemmas_types_infos in @@ -1116,15 +1128,12 @@ let derive_correctness make_scheme functional_induction (funs: constant list) (g i*) let lem_id = mk_complete_id f_id in Lemmas.start_proof lem_id - (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem)) - (fst lemmas_types_infos.(i)) + (Decl_kinds.Global,false(*FIXME*),(Decl_kinds.Proof Decl_kinds.Theorem)) + (fst lemmas_types_infos.(i), (*FIXME*)Univ.ContextSet.empty) (fun _ _ -> ()); - ignore (Pfedit.by - (Proofview.V82.tactic (observe_tac ("prove completeness ("^(Id.to_string f_id)^")") - (proving_tac i)))); do_save (); let finfo = find_Function_infos f_as_constant in - let lem_cst = destConst (Constrintern.global_reference lem_id) in + let lem_cst,u = destConst (Constrintern.global_reference lem_id) in update_Function {finfo with completeness_lemma = Some lem_cst} ) funs) @@ -1142,7 +1151,7 @@ let revert_graph kn post_tac hid g = let typ = pf_type_of g (mkVar hid) in match kind_of_term typ with | App(i,args) when isInd i -> - let ((kn',num) as ind') = destInd i in + let ((kn',num) as ind'),u = destInd i in if MutInd.equal kn kn' then (* We have generated a graph hypothesis so that we must change it if we can *) let info = @@ -1192,7 +1201,7 @@ let functional_inversion kn hid fconst f_correct : tactic = let old_ids = List.fold_right Id.Set.add (pf_ids_of_hyps g) Id.Set.empty in let type_of_h = pf_type_of g (mkVar hid) in match kind_of_term type_of_h with - | App(eq,args) when eq_constr eq (Coqlib.build_coq_eq ()) -> + | App(eq,args) when eq_constr eq (make_eq ()) -> let pre_tac,f_args,res = match kind_of_term args.(1),kind_of_term args.(2) with | App(f,f_args),_ when eq_constr f fconst -> @@ -1244,12 +1253,12 @@ let invfun qhyp f g = (fun hid -> Proofview.V82.tactic begin fun g -> let hyp_typ = pf_type_of g (mkVar hid) in match kind_of_term hyp_typ with - | App(eq,args) when eq_constr eq (Coqlib.build_coq_eq ()) -> + | App(eq,args) when eq_constr eq (make_eq ()) -> begin let f1,_ = decompose_app args.(1) in try if not (isConst f1) then failwith ""; - let finfos = find_Function_infos (destConst f1) in + let finfos = find_Function_infos (fst (destConst f1)) in let f_correct = mkConst(Option.get finfos.correctness_lemma) and kn = fst finfos.graph_ind in @@ -1258,7 +1267,7 @@ let invfun qhyp f g = try let f2,_ = decompose_app args.(2) in if not (isConst f2) then failwith ""; - let finfos = find_Function_infos (destConst f2) in + let finfos = find_Function_infos (fst (destConst f2)) in let f_correct = mkConst(Option.get finfos.correctness_lemma) and kn = fst finfos.graph_ind in diff --git a/plugins/funind/merge.ml b/plugins/funind/merge.ml index ac54e44cc..d0497f6f6 100644 --- a/plugins/funind/merge.ml +++ b/plugins/funind/merge.ml @@ -70,7 +70,7 @@ let isVarf f x = in global environment. *) let ident_global_exist id = try - let ans = CRef (Libnames.Ident (Loc.ghost,id)) in + let ans = CRef (Libnames.Ident (Loc.ghost,id), None) in let _ = ignore (Constrintern.intern_constr (Global.env()) ans) in true with e when Errors.noncritical e -> false @@ -134,16 +134,12 @@ let prNamedRLDecl s lc = let showind (id:Id.t) = let cstrid = Constrintern.global_reference id in let ind1,cstrlist = Inductiveops.find_inductive (Global.env()) Evd.empty cstrid in - let mib1,ib1 = Inductive.lookup_mind_specif (Global.env()) ind1 in + let mib1,ib1 = Inductive.lookup_mind_specif (Global.env()) (fst ind1) in List.iter (fun (nm, optcstr, tp) -> print_string (string_of_name nm^":"); prconstr tp; print_string "\n") ib1.mind_arity_ctxt; - (match ib1.mind_arity with - | Monomorphic x -> - Printf.printf "arity :"; prconstr x.mind_user_arity - | Polymorphic x -> - Printf.printf "arity : universe?"); + Printf.printf "arity :"; prconstr ib1.mind_arity.mind_user_arity; Array.iteri (fun i x -> Printf.printf"type constr %d :" i ; prconstr x) ib1.mind_user_lc @@ -888,7 +884,7 @@ let merge_inductive (ind1: inductive) (ind2: inductive) let indexpr = glob_constr_list_to_inductive_expr prms1 prms2 mib1 mib2 shift_prm rawlist in (* Declare inductive *) let indl,_,_ = Command.extract_mutual_inductive_declaration_components [(indexpr,[])] in - let mie,impls = Command.interp_mutual_inductive indl [] true (* means: not coinductive *) in + let mie,impls = Command.interp_mutual_inductive indl [] false (*FIXMEnon-poly *) true (* means: not coinductive *) in (* Declare the mutual inductive block with its associated schemes *) ignore (Command.declare_mutual_inductive_with_eliminations Declare.UserVerbose mie impls) @@ -961,7 +957,7 @@ let funify_branches relinfo nfuns branch = | _ -> assert false in let is_dom c = match kind_of_term c with - | Ind((u,_)) | Construct((u,_),_) -> MutInd.equal u mut_induct + | Ind(((u,_),_)) | Construct(((u,_),_),_) -> MutInd.equal u mut_induct | _ -> false in let _dom_i c = assert (is_dom c); diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 614886073..96bf4c921 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -52,29 +52,21 @@ let find_reference sl s = let dp = Names.DirPath.make (List.rev_map Id.of_string sl) in locate (make_qualid dp (Id.of_string s)) -let (declare_fun : Id.t -> logical_kind -> constr -> global_reference) = - fun f_id kind value -> - let ce = {const_entry_body = Future.from_val - (value, Declareops.no_seff); - const_entry_secctx = None; - const_entry_type = None; - const_entry_opaque = false; - const_entry_inline_code = false; - const_entry_feedback = None; - } in - ConstRef(declare_constant f_id (DefinitionEntry ce, kind));; +let declare_fun f_id kind ?(ctx=Univ.UContext.empty) value = + let ce = definition_entry ~univs:ctx value (*FIXME *) in + ConstRef(declare_constant f_id (DefinitionEntry ce, kind));; let defined () = Lemmas.save_proof (Vernacexpr.Proved (false,None)) let def_of_const t = match (kind_of_term t) with Const sp -> - (try (match body_of_constant (Global.lookup_constant sp) with + (try (match constant_opt_value_in (Global.env ()) sp with | Some c -> c | _ -> raise Not_found) with Not_found -> anomaly (str "Cannot find definition of constant " ++ - (Id.print (Label.to_id (con_label sp)))) + (Id.print (Label.to_id (con_label (fst sp))))) ) |_ -> assert false @@ -83,6 +75,7 @@ let type_of_const t = Const sp -> Typeops.type_of_constant (Global.env()) sp |_ -> assert false +let constr_of_global = Universes.constr_of_global let constant sl s = constr_of_global (find_reference sl s) @@ -188,7 +181,7 @@ let (value_f:constr list -> global_reference -> constr) = let glob_body = GCases (d0,RegularStyle,None, - [GApp(d0, GRef(d0,fterm), List.rev_map (fun x_id -> GVar(d0, x_id)) rev_x_id_l), + [GApp(d0, GRef(d0,fterm,None), List.rev_map (fun x_id -> GVar(d0, x_id)) rev_x_id_l), (Anonymous,None)], [d0, [v_id], [PatCstr(d0,(destIndRef (delayed_force coq_sig_ref),1), @@ -197,7 +190,7 @@ let (value_f:constr list -> global_reference -> constr) = Anonymous)], GVar(d0,v_id)]) in - let body = understand Evd.empty env glob_body in + let body = fst (understand Evd.empty env glob_body)(*FIXME*) in it_mkLambda_or_LetIn body context let (declare_f : Id.t -> logical_kind -> constr list -> global_reference -> global_reference) = @@ -302,6 +295,7 @@ let check_not_nested forbidden e = | Lambda(_,t,b) -> check_not_nested t;check_not_nested b | LetIn(_,v,t,b) -> check_not_nested t;check_not_nested b;check_not_nested v | App(f,l) -> check_not_nested f;Array.iter check_not_nested l + | Proj (p,c) -> check_not_nested c | Const _ -> () | Ind _ -> () | Construct _ -> () @@ -412,6 +406,7 @@ let treat_case forbid_new_ids to_intros finalize_tac nb_lam e infos : tactic = let rec travel_aux jinfo continuation_tac (expr_info:constr infos) = match kind_of_term expr_info.info with | CoFix _ | Fix _ -> error "Function cannot treat local fixpoint or cofixpoint" + | Proj _ -> error "Function cannot treat projections" | LetIn(na,b,t,e) -> begin let new_continuation_tac = @@ -640,7 +635,16 @@ let terminate_letin (na,b,t,e) expr_info continuation_tac info = in continuation_tac {info with info = new_e; forbidden_ids = new_forbidden} +let pf_type c tac gl = + let evars, ty = Typing.e_type_of (pf_env gl) (project gl) c in + tclTHEN (Refiner.tclEVARS evars) (tac ty) gl +let pf_typel l tac = + let rec aux tys l = + match l with + | [] -> tac (List.rev tys) + | hd :: tl -> pf_type hd (fun ty -> aux (ty::tys) tl) + in aux [] l (* This is like the previous one except that it also rewrite on all hypotheses except the ones given in the first argument. All the @@ -660,12 +664,13 @@ let mkDestructEq : let type_of_expr = pf_type_of g expr in let new_hyps = mkApp(Lazy.force refl_equal, [|type_of_expr; expr|]):: to_revert_constr in + pf_typel new_hyps (fun _ -> tclTHENLIST [Simple.generalize new_hyps; (fun g2 -> change_in_concl None (pattern_occs [Locus.AllOccurrencesBut [1], expr] (pf_env g2) Evd.empty (pf_concl g2)) g2); - Proofview.V82.of_tactic (simplest_case expr)], to_revert + Proofview.V82.of_tactic (simplest_case expr)]), to_revert let terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos g = @@ -1167,7 +1172,7 @@ let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_a let get_current_subgoals_types () = let p = Proof_global.give_me_the_proof () in let { Evd.it=sgs ; sigma=sigma } = Proof.V82.subgoals p in - List.map (Goal.V82.abstract_type sigma) sgs + sigma, List.map (Goal.V82.abstract_type sigma) sgs let build_and_l l = let and_constr = Coqlib.build_coq_and () in @@ -1225,12 +1230,12 @@ let clear_goals = let build_new_goal_type () = - let sub_gls_types = get_current_subgoals_types () in - (* Pp.msgnl (str "sub_gls_types1 := " ++ Pp.prlist_with_sep (fun () -> Pp.fnl () ++ Pp.fnl ()) Printer.pr_lconstr sub_gls_types); *) + let sigma, sub_gls_types = get_current_subgoals_types () in + (* Pp.msgnl (str "sub_gls_types1 := " ++ Util.prlist_with_sep (fun () -> Pp.fnl () ++ Pp.fnl ()) Printer.pr_lconstr sub_gls_types); *) let sub_gls_types = clear_goals sub_gls_types in (* Pp.msgnl (str "sub_gls_types2 := " ++ Pp.prlist_with_sep (fun () -> Pp.fnl () ++ Pp.fnl ()) Printer.pr_lconstr sub_gls_types); *) let res = build_and_l sub_gls_types in - res + sigma, res let is_opaque_constant c = let cb = Global.lookup_constant c in @@ -1239,7 +1244,7 @@ let is_opaque_constant c = | Declarations.Undef _ -> true | Declarations.Def _ -> false -let open_new_goal (build_proof:tactic -> tactic -> unit) using_lemmas ref_ goal_name (gls_type,decompose_and_tac,nb_goal) = +let open_new_goal build_proof ctx using_lemmas ref_ goal_name (gls_type,decompose_and_tac,nb_goal) = (* Pp.msgnl (str "gls_type := " ++ Printer.pr_lconstr gls_type); *) let current_proof_name = get_current_proof_name () in let name = match goal_name with @@ -1265,7 +1270,7 @@ let open_new_goal (build_proof:tactic -> tactic -> unit) using_lemmas ref_ goal_ let lid = ref [] in let h_num = ref (-1) in Proof_global.discard_all (); - build_proof + build_proof (Univ.ContextSet.empty) ( fun gls -> let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gls) in tclTHENSEQ @@ -1312,8 +1317,8 @@ let open_new_goal (build_proof:tactic -> tactic -> unit) using_lemmas ref_ goal_ in Lemmas.start_proof na - (Decl_kinds.Global, Decl_kinds.Proof Decl_kinds.Lemma) - gls_type + (Decl_kinds.Global, false (* FIXME *), Decl_kinds.Proof Decl_kinds.Lemma) + (gls_type, ctx) hook; if Indfun_common.is_strict_tcc () then @@ -1330,7 +1335,7 @@ let open_new_goal (build_proof:tactic -> tactic -> unit) using_lemmas ref_ goal_ (fun c -> tclTHENSEQ [Proofview.V82.of_tactic intros; - Simple.apply (interp_constr Evd.empty (Global.env()) c); + Simple.apply (fst (interp_constr Evd.empty (Global.env()) c)) (*FIXME*); tclCOMPLETE (Proofview.V82.of_tactic Auto.default_auto) ] ) @@ -1354,22 +1359,24 @@ let com_terminate relation rec_arg_num thm_name using_lemmas - nb_args + nb_args ctx hook = - let start_proof (tac_start:tactic) (tac_end:tactic) = + let ctx = Univ.ContextSet.of_context ctx in + let start_proof ctx (tac_start:tactic) (tac_end:tactic) = let (evmap, env) = Lemmas.get_current_context() in Lemmas.start_proof thm_name - (Global, Proof Lemma) ~sign:(Environ.named_context_val env) - (compute_terminate_type nb_args fonctional_ref) hook; + (Global, false (* FIXME *), Proof Lemma) ~sign:(Environ.named_context_val env) + (compute_terminate_type nb_args fonctional_ref, ctx) hook; ignore (by (Proofview.V82.tactic (observe_tac (str "starting_tac") tac_start))); ignore (by (Proofview.V82.tactic (observe_tac (str "whole_start") (whole_start tac_end nb_args is_mes fonctional_ref input_type relation rec_arg_num )))) in - start_proof tclIDTAC tclIDTAC; + start_proof ctx tclIDTAC tclIDTAC; try - let new_goal_type = build_new_goal_type () in - open_new_goal start_proof using_lemmas tcc_lemma_ref + let sigma, new_goal_type = build_new_goal_type () in + open_new_goal start_proof (Evd.get_universe_context_set sigma) + using_lemmas tcc_lemma_ref (Some tcc_lemma_name) (new_goal_type); with Failure "empty list of subgoals!" -> @@ -1384,7 +1391,7 @@ let start_equation (f:global_reference) (term_f:global_reference) (cont_tactic:Id.t list -> tactic) g = let ids = pf_ids_of_hyps g in let terminate_constr = constr_of_global term_f in - let nargs = nb_prod (type_of_const terminate_constr) in + let nargs = nb_prod (fst (type_of_const terminate_constr)) (*FIXME*) in let x = n_x_id ids nargs in tclTHENLIST [ h_intros x; @@ -1406,8 +1413,8 @@ let (com_eqn : int -> Id.t -> let (evmap, env) = Lemmas.get_current_context() in let f_constr = constr_of_global f_ref in let equation_lemma_type = subst1 f_constr equation_lemma_type in - (Lemmas.start_proof eq_name (Global, Proof Lemma) - ~sign:(Environ.named_context_val env) equation_lemma_type (fun _ _ -> ()); + (Lemmas.start_proof eq_name (Global, false, Proof Lemma) + ~sign:(Environ.named_context_val env) (equation_lemma_type, (*FIXME*)Univ.ContextSet.empty) (fun _ _ -> ()); ignore (by (Proofview.V82.tactic (start_equation f_ref terminate_ref (fun x -> @@ -1445,13 +1452,15 @@ let (com_eqn : int -> Id.t -> let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num eq generate_induction_principle using_lemmas : unit = - let function_type = interp_constr Evd.empty (Global.env()) type_of_f in - let env = push_named (function_name,None,function_type) (Global.env()) in + let env = Global.env() in + let evd = ref (Evd.from_env env) in + let function_type = interp_type_evars evd env type_of_f in + let env = push_named (function_name,None,function_type) env in (* Pp.msgnl (str "function type := " ++ Printer.pr_lconstr function_type); *) - let equation_lemma_type = - nf_betaiotazeta - (interp_constr Evd.empty env ~impls:rec_impls eq) - in + let ty = interp_type_evars evd env ~impls:rec_impls eq in + let evm, nf = Evarutil.nf_evars_and_universes !evd in + let equation_lemma_type = nf_betaiotazeta (nf ty) in + let function_type = nf function_type in (* Pp.msgnl (str "lemma type := " ++ Printer.pr_lconstr equation_lemma_type ++ fnl ()); *) let res_vars,eq' = decompose_prod equation_lemma_type in let env_eq' = Environ.push_rel_context (List.map (fun (x,y) -> (x,None,y)) res_vars) env in @@ -1471,13 +1480,14 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num let equation_id = add_suffix function_name "_equation" in let functional_id = add_suffix function_name "_F" in let term_id = add_suffix function_name "_terminate" in - let functional_ref = declare_fun functional_id (IsDefinition Decl_kinds.Definition) res in + let ctx = Evd.universe_context evm in + let functional_ref = declare_fun functional_id (IsDefinition Decl_kinds.Definition) ~ctx res in let env_with_pre_rec_args = push_rel_context(List.map (function (x,t) -> (x,None,t)) pre_rec_args) env in let relation = - interp_constr + fst (*FIXME*)(interp_constr Evd.empty env_with_pre_rec_args - r + r) in let tcc_lemma_name = add_suffix function_name "_tcc" in let tcc_lemma_constr = ref None in @@ -1524,6 +1534,5 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num term_id using_lemmas (List.length res_vars) - hook) + ctx hook) () - diff --git a/plugins/funind/recdef.mli b/plugins/funind/recdef.mli index 2ef685203..f60eedbe6 100644 --- a/plugins/funind/recdef.mli +++ b/plugins/funind/recdef.mli @@ -12,9 +12,9 @@ bool -> Constrintern.internalization_env -> Constrexpr.constr_expr -> Constrexpr.constr_expr -> - int -> Constrexpr.constr_expr -> (Names.constant -> + int -> Constrexpr.constr_expr -> (Term.pconstant -> Term.constr option ref -> - Names.constant -> - Names.constant -> int -> Term.types -> int -> Term.constr -> 'a) -> Constrexpr.constr_expr list -> unit + Term.pconstant -> + Term.pconstant -> int -> Term.types -> int -> Term.constr -> 'a) -> Constrexpr.constr_expr list -> unit diff --git a/plugins/micromega/OrderedRing.v b/plugins/micromega/OrderedRing.v index b260feab1..2246af64d 100644 --- a/plugins/micromega/OrderedRing.v +++ b/plugins/micromega/OrderedRing.v @@ -85,9 +85,9 @@ Notation "x < y" := (rlt x y). Add Relation R req - reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _ ) - symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _ ) - transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _ ) + reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _) + symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _) + transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _) as sor_setoid. diff --git a/plugins/micromega/RingMicromega.v b/plugins/micromega/RingMicromega.v index 68add5b3d..fb16c55c2 100644 --- a/plugins/micromega/RingMicromega.v +++ b/plugins/micromega/RingMicromega.v @@ -57,7 +57,7 @@ Variables ceqb cleb : C -> C -> bool. Variable phi : C -> R. (* Power coefficients *) -Variable E : Set. (* the type of exponents *) +Variable E : Type. (* the type of exponents *) Variable pow_phi : N -> E. Variable rpow : R -> E -> R. @@ -78,9 +78,9 @@ Record SORaddon := mk_SOR_addon { Variable addon : SORaddon. Add Relation R req - reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _ ) - symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _ ) - transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _ ) + reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _) + symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _) + transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _) as micomega_sor_setoid. Add Morphism rplus with signature req ==> req ==> req as rplus_morph. @@ -414,7 +414,7 @@ Proof. simpl ; intros. destruct (nth_in_or_default n l (Pc cO, Equal)). (* index is in bounds *) - apply H ; congruence. + apply H. congruence. (* index is out-of-bounds *) inversion H0. rewrite e. simpl. diff --git a/plugins/micromega/ZMicromega.v b/plugins/micromega/ZMicromega.v index d8ab6fd30..78837d4cd 100644 --- a/plugins/micromega/ZMicromega.v +++ b/plugins/micromega/ZMicromega.v @@ -317,7 +317,7 @@ Qed. Require Import QArith. -Inductive ZArithProof : Type := +Inductive ZArithProof := | DoneProof | RatProof : ZWitness -> ZArithProof -> ZArithProof | CutProof : ZWitness -> ZArithProof -> ZArithProof diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index 9515c5de9..d11454b27 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -536,10 +536,10 @@ struct let get_left_construct term = match Term.kind_of_term term with - | Term.Construct(_,i) -> (i,[| |]) + | Term.Construct((_,i),_) -> (i,[| |]) | Term.App(l,rst) -> (match Term.kind_of_term l with - | Term.Construct(_,i) -> (i,rst) + | Term.Construct((_,i),_) -> (i,rst) | _ -> raise ParseError ) | _ -> raise ParseError @@ -833,8 +833,8 @@ struct let parse_zop (op,args) = match kind_of_term op with - | Const x -> (assoc_const op zop_table, args.(0) , args.(1)) - | Ind(n,0) -> + | Const (x,_) -> (assoc_const op zop_table, args.(0) , args.(1)) + | Ind((n,0),_) -> if Constr.equal op (Lazy.force coq_Eq) && Constr.equal args.(0) (Lazy.force coq_Z) then (Mc.OpEq, args.(1), args.(2)) else raise ParseError @@ -842,8 +842,8 @@ struct let parse_rop (op,args) = match kind_of_term op with - | Const x -> (assoc_const op rop_table, args.(0) , args.(1)) - | Ind(n,0) -> + | Const (x,_) -> (assoc_const op rop_table, args.(0) , args.(1)) + | Ind((n,0),_) -> if Constr.equal op (Lazy.force coq_Eq) && Constr.equal args.(0) (Lazy.force coq_R) then (Mc.OpEq, args.(1), args.(2)) else raise ParseError diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index 9b851447c..9b12c5eb3 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -170,7 +170,7 @@ let hide_constr,find_constr,clear_constr_tables,dump_tables = let l = ref ([]:(constr * (Id.t * Id.t * bool)) list) in (fun h id eg b -> l := (h,(id,eg,b)):: !l), (fun h -> - try List.assoc_f Constr.equal h !l with Not_found -> failwith "find_contr"), + try List.assoc_f eq_constr_nounivs h !l with Not_found -> failwith "find_contr"), (fun () -> l := []), (fun () -> !l) @@ -350,7 +350,7 @@ let coq_iff = lazy (constant "iff") (* For unfold *) let evaluable_ref_of_constr s c = match kind_of_term (Lazy.force c) with - | Const kn when Tacred.is_evaluable (Global.env()) (EvalConstRef kn) -> + | Const (kn,u) when Tacred.is_evaluable (Global.env()) (EvalConstRef kn) -> EvalConstRef kn | _ -> anomaly ~label:"Coq_omega" (Pp.str (s^" is not an evaluable constant")) @@ -367,15 +367,16 @@ let mk_var v = mkVar (Id.of_string v) let mk_plus t1 t2 = mkApp (Lazy.force coq_Zplus, [| t1; t2 |]) let mk_times t1 t2 = mkApp (Lazy.force coq_Zmult, [| t1; t2 |]) let mk_minus t1 t2 = mkApp (Lazy.force coq_Zminus, [| t1;t2 |]) -let mk_eq t1 t2 = mkApp (build_coq_eq (), [| Lazy.force coq_Z; t1; t2 |]) +let mk_eq t1 t2 = mkApp (Universes.constr_of_global (build_coq_eq ()), + [| Lazy.force coq_Z; t1; t2 |]) let mk_le t1 t2 = mkApp (Lazy.force coq_Zle, [| t1; t2 |]) let mk_gt t1 t2 = mkApp (Lazy.force coq_Zgt, [| t1; t2 |]) let mk_inv t = mkApp (Lazy.force coq_Zopp, [| t |]) let mk_and t1 t2 = mkApp (build_coq_and (), [| t1; t2 |]) let mk_or t1 t2 = mkApp (build_coq_or (), [| t1; t2 |]) let mk_not t = mkApp (build_coq_not (), [| t |]) -let mk_eq_rel t1 t2 = mkApp (build_coq_eq (), - [| Lazy.force coq_comparison; t1; t2 |]) +let mk_eq_rel t1 t2 = mkApp (Universes.constr_of_global (build_coq_eq ()), + [| Lazy.force coq_comparison; t1; t2 |]) let mk_inj t = mkApp (Lazy.force coq_Z_of_nat, [| t |]) let mk_integer n = @@ -419,7 +420,7 @@ type result = let destructurate_prop t = let c, args = decompose_app t in match kind_of_term c, args with - | _, [_;_;_] when eq_constr c (build_coq_eq ()) -> Kapp (Eq,args) + | _, [_;_;_] when eq_constr c (Universes.constr_of_global (build_coq_eq ())) -> Kapp (Eq,args) | _, [_;_] when eq_constr c (Lazy.force coq_neq) -> Kapp (Neq,args) | _, [_;_] when eq_constr c (Lazy.force coq_Zne) -> Kapp (Zne,args) | _, [_;_] when eq_constr c (Lazy.force coq_Zle) -> Kapp (Zle,args) @@ -436,11 +437,11 @@ let destructurate_prop t = | _, [_;_] when eq_constr c (Lazy.force coq_lt) -> Kapp (Lt,args) | _, [_;_] when eq_constr c (Lazy.force coq_ge) -> Kapp (Ge,args) | _, [_;_] when eq_constr c (Lazy.force coq_gt) -> Kapp (Gt,args) - | Const sp, args -> + | Const (sp,_), args -> Kapp (Other (string_of_path (path_of_global (ConstRef sp))),args) - | Construct csp , args -> + | Construct (csp,_) , args -> Kapp (Other (string_of_path (path_of_global (ConstructRef csp))), args) - | Ind isp, args -> + | Ind (isp,_), args -> Kapp (Other (string_of_path (path_of_global (IndRef isp))),args) | Var id,[] -> Kvar id | Prod (Anonymous,typ,body), [] -> Kimp(typ,body) @@ -1081,7 +1082,8 @@ let replay_history tactic_normalisation = let p_initial = [P_APP 2;P_TYPE] in let tac = shuffle_cancel p_initial e1.body in let solve_le = - let not_sup_sup = mkApp (build_coq_eq (), [| + let not_sup_sup = mkApp (Universes.constr_of_global (build_coq_eq ()), + [| Lazy.force coq_comparison; Lazy.force coq_Gt; Lazy.force coq_Gt |]) diff --git a/plugins/quote/quote.ml b/plugins/quote/quote.ml index 9ee16a582..ea459e551 100644 --- a/plugins/quote/quote.ml +++ b/plugins/quote/quote.ml @@ -196,9 +196,9 @@ let coerce_meta_in n = let compute_lhs typ i nargsi = match kind_of_term typ with - | Ind(sp,0) -> + | Ind((sp,0),u) -> let argsi = Array.init nargsi (fun j -> mkMeta (nargsi - j)) in - mkApp (mkConstruct ((sp,0),i+1), argsi) + mkApp (mkConstructU (((sp,0),i+1),u), argsi) | _ -> i_can't_do_that () (*s This function builds the pattern from the RHS. Recursive calls are @@ -221,7 +221,7 @@ let compute_rhs bodyi index_of_f = let compute_ivs f cs gl = let cst = try destConst f with DestKO -> i_can't_do_that () in - let body = Environ.constant_value (Global.env()) cst in + let body = Environ.constant_value_in (Global.env()) cst in match decomp_term body with | Fix(([| len |], 0), ([| name |], [| typ |], [| body2 |])) -> let (args3, body3) = decompose_lam body2 in diff --git a/plugins/romega/ReflOmegaCore.v b/plugins/romega/ReflOmegaCore.v index ab424c223..7e4475d40 100644 --- a/plugins/romega/ReflOmegaCore.v +++ b/plugins/romega/ReflOmegaCore.v @@ -1284,7 +1284,7 @@ Qed. (* Extraire une hypothèse de la liste *) Definition nth_hyps (n : nat) (l : hyps) := nth n l TrueTerm. - +Unset Printing Notations. Theorem nth_valid : forall (ep : list Prop) (e : list int) (i : nat) (l : hyps), interp_hyps ep e l -> interp_proposition ep e (nth_hyps i l). diff --git a/plugins/romega/const_omega.ml b/plugins/romega/const_omega.ml index 5416e936c..689462704 100644 --- a/plugins/romega/const_omega.ml +++ b/plugins/romega/const_omega.ml @@ -30,11 +30,11 @@ let string_of_global r = let destructurate t = let c, args = Term.decompose_app t in match Term.kind_of_term c, args with - | Term.Const sp, args -> + | Term.Const (sp,_), args -> Kapp (string_of_global (Globnames.ConstRef sp), args) - | Term.Construct csp , args -> + | Term.Construct (csp,_) , args -> Kapp (string_of_global (Globnames.ConstructRef csp), args) - | Term.Ind isp, args -> + | Term.Ind (isp,_), args -> Kapp (string_of_global (Globnames.IndRef isp), args) | Term.Var id,[] -> Kvar(Names.Id.to_string id) | Term.Prod (Names.Anonymous,typ,body), [] -> Kimp(typ,body) @@ -48,9 +48,9 @@ let dest_const_apply t = let f,args = Term.decompose_app t in let ref = match Term.kind_of_term f with - | Term.Const sp -> Globnames.ConstRef sp - | Term.Construct csp -> Globnames.ConstructRef csp - | Term.Ind isp -> Globnames.IndRef isp + | Term.Const (sp,_) -> Globnames.ConstRef sp + | Term.Construct (csp,_) -> Globnames.ConstructRef csp + | Term.Ind (isp,_) -> Globnames.IndRef isp | _ -> raise Destruct in Nametab.basename_of_global ref, args @@ -210,19 +210,26 @@ let rec mk_nat = function (* Lists *) -let coq_cons = lazy (constant "cons") -let coq_nil = lazy (constant "nil") +let mkListConst c u = + Term.mkConstructU (Globnames.destConstructRef + (Coqlib.gen_reference "" ["Init";"Datatypes"] c), + Univ.Instance.of_array [|u|]) -let mk_list typ l = +let coq_cons univ typ = Term.mkApp (mkListConst "cons" univ, [|typ|]) +let coq_nil univ typ = Term.mkApp (mkListConst "nil" univ, [|typ|]) + +let mk_list univ typ l = let rec loop = function - | [] -> - Term.mkApp (Lazy.force coq_nil, [|typ|]) + | [] -> coq_nil univ typ | (step :: l) -> - Term.mkApp (Lazy.force coq_cons, [|typ; step; loop l |]) in + Term.mkApp (coq_cons univ typ, [| step; loop l |]) in loop l -let mk_plist l = mk_list Term.mkProp l +let mk_plist = + let type1lev = Universes.new_univ_level (Global.current_dirpath ()) in + fun l -> mk_list type1lev Term.mkProp l +let mk_list = mk_list Univ.Level.set let mk_shuffle_list l = mk_list (Lazy.force coq_t_fusion) l diff --git a/plugins/romega/const_omega.mli b/plugins/romega/const_omega.mli index b8db71e40..4ae1cb94c 100644 --- a/plugins/romega/const_omega.mli +++ b/plugins/romega/const_omega.mli @@ -117,6 +117,7 @@ val do_seq : Term.constr -> Term.constr -> Term.constr val do_list : Term.constr list -> Term.constr val mk_nat : int -> Term.constr +(** Precondition: the type of the list is in Set *) val mk_list : Term.constr -> Term.constr list -> Term.constr val mk_plist : Term.types list -> Term.types val mk_shuffle_list : Term.constr list -> Term.constr diff --git a/plugins/rtauto/Bintree.v b/plugins/rtauto/Bintree.v index 98dd257d5..16081ffe1 100644 --- a/plugins/rtauto/Bintree.v +++ b/plugins/rtauto/Bintree.v @@ -198,7 +198,7 @@ Theorem get_Full_Gt : forall S, Full S -> Proof. intros S W;induction W. unfold empty,index,get,contents;intros;apply Tget_Tempty. -unfold index,get,push;simpl contents. +unfold index,get,push. simpl @contents. intros i e;rewrite Tget_Tadd. rewrite (Gt_Psucc _ _ e). unfold get in IHW. @@ -209,7 +209,7 @@ Theorem get_Full_Eq : forall S, Full S -> get (index S) S = PNone. intros [index0 contents0] F. case F. unfold empty,index,get,contents;intros;apply Tget_Tempty. -unfold index,get,push;simpl contents. +unfold push,index,get;simpl @contents. intros a S. rewrite Tget_Tadd. rewrite Psucc_Gt. @@ -231,12 +231,12 @@ Proof. intros i a S F. case_eq (i ?= index S). intro e;rewrite (Pos.compare_eq _ _ e). -destruct S;unfold get,push,index;simpl contents;rewrite Tget_Tadd. +destruct S;unfold get,push,index;simpl @contents;rewrite Tget_Tadd. rewrite Pos.compare_refl;reflexivity. -intros;destruct S;unfold get,push,index;simpl contents;rewrite Tget_Tadd. -simpl index in H;rewrite H;reflexivity. +intros;destruct S;unfold get,push,index;simpl @contents;rewrite Tget_Tadd. +simpl @index in H;rewrite H;reflexivity. intro H;generalize H;clear H. -unfold get,push;simpl index;simpl contents. +unfold get,push;simpl. rewrite Tget_Tadd;intro e;rewrite e. change (get i S=PNone). apply get_Full_Gt;auto. @@ -260,7 +260,7 @@ Qed. Lemma Full_index_one_empty : forall S, Full S -> index S = 1 -> S=empty. intros [ind cont] F one; inversion F. reflexivity. -simpl index in one;assert (h:=Pos.succ_not_1 (index S)). +simpl @index in one;assert (h:=Pos.succ_not_1 (index S)). congruence. Qed. diff --git a/plugins/rtauto/refl_tauto.ml b/plugins/rtauto/refl_tauto.ml index 96758788a..bff574a06 100644 --- a/plugins/rtauto/refl_tauto.ml +++ b/plugins/rtauto/refl_tauto.ml @@ -104,20 +104,20 @@ let rec make_form atom_env gls term = make_atom atom_env (normalize term) | Cast(a,_,_) -> make_form atom_env gls a - | Ind ind -> - if Names.eq_ind ind (Lazy.force li_False) then + | Ind (ind, _) -> + if Names.eq_ind ind (fst (Lazy.force li_False)) then Bot else make_atom atom_env (normalize term) | App(hd,argv) when Int.equal (Array.length argv) 2 -> begin try - let ind = destInd hd in - if Names.eq_ind ind (Lazy.force li_and) then + let ind, _ = destInd hd in + if Names.eq_ind ind (fst (Lazy.force li_and)) then let fa=make_form atom_env gls argv.(0) in let fb=make_form atom_env gls argv.(1) in Conjunct (fa,fb) - else if Names.eq_ind ind (Lazy.force li_or) then + else if Names.eq_ind ind (fst (Lazy.force li_or)) then let fa=make_form atom_env gls argv.(0) in let fb=make_form atom_env gls argv.(1) in Disjunct (fa,fb) diff --git a/plugins/setoid_ring/Field_theory.v b/plugins/setoid_ring/Field_theory.v index 3622c7fe9..2b9dce1b0 100644 --- a/plugins/setoid_ring/Field_theory.v +++ b/plugins/setoid_ring/Field_theory.v @@ -10,6 +10,7 @@ Require Ring. Import Ring_polynom Ring_tac Ring_theory InitialRing Setoid List Morphisms. Require Import ZArith_base. Set Implicit Arguments. +(* Set Universe Polymorphism. *) Section MakeFieldPol. @@ -278,6 +279,21 @@ apply radd_ext. [ ring | now rewrite rdiv_simpl ]. Qed. +Theorem rdiv3 r1 r2 r3 r4 : + ~ r2 == 0 -> + ~ r4 == 0 -> + r1 / r2 - r3 / r4 == (r1 * r4 - r3 * r2) / (r2 * r4). +Proof. +intros H2 H4. +assert (~ r2 * r4 == 0) by (apply field_is_integral_domain; trivial). +transitivity (r1 / r2 + - (r3 / r4)); auto. +transitivity (r1 / r2 + - r3 / r4); auto. +transitivity ((r1 * r4 + - r3 * r2) / (r2 * r4)). +apply rdiv2; auto. +f_equiv. +transitivity (r1 * r4 + - (r3 * r2)); auto. +Qed. + Theorem rdiv5 a b : - (a / b) == - a / b. Proof. now rewrite !rdiv_def, ropp_mul_l. @@ -696,6 +712,7 @@ Fixpoint PEsimp (e : PExpr C) : PExpr C := | _ => e end%poly. +<<<<<<< .merge_file_5Z3Qpn Theorem PEsimp_ok e : (PEsimp e === e)%poly. Proof. induction e; simpl. @@ -708,6 +725,32 @@ induction e; simpl. - rewrite NPEmul_ok. now f_equiv. - rewrite NPEopp_ok. now f_equiv. - rewrite NPEpow_ok. now f_equiv. +======= +Theorem PExpr_simp_correct: + forall l e, NPEeval l (PExpr_simp e) == NPEeval l e. +clear eq_sym. +intros l e; elim e; simpl; auto. +intros e1 He1 e2 He2. +transitivity (NPEeval l (PEadd (PExpr_simp e1) (PExpr_simp e2))); auto. +apply NPEadd_correct. +simpl; auto. +intros e1 He1 e2 He2. +transitivity (NPEeval l (PEsub (PExpr_simp e1) (PExpr_simp e2))). auto. +apply NPEsub_correct. +simpl; auto. +intros e1 He1 e2 He2. +transitivity (NPEeval l (PEmul (PExpr_simp e1) (PExpr_simp e2))); auto. +apply NPEmul_correct. +simpl; auto. +intros e1 He1. +transitivity (NPEeval l (PEopp (PExpr_simp e1))); auto. +apply NPEopp_correct. +simpl; auto. +intros e1 He1 n;simpl. +rewrite NPEpow_correct;simpl. +repeat rewrite pow_th.(rpow_pow_N). +rewrite He1;auto. +>>>>>>> .merge_file_U4r9lJ Qed. @@ -961,6 +1004,7 @@ Fixpoint split_aux e1 p e2 {struct e1}: rsplit := end end%poly. +<<<<<<< .merge_file_5Z3Qpn Lemma split_aux_ok1 e1 p e2 : (let res := match isIn e1 p e2 1 with | Some (N0,e3) => mk_rsplit 1 (e1 ^^ Npos p) e3 @@ -971,6 +1015,20 @@ Lemma split_aux_ok1 e1 p e2 : e1 ^ Npos p === left res * common res /\ e2 === right res * common res)%poly. Proof. +======= +Lemma split_aux_correct_1 : forall l e1 p e2, + let res := match isIn e1 p e2 xH with + | Some (N0,e3) => mk_rsplit (PEc cI) (NPEpow e1 (Npos p)) e3 + | Some (Npos q, e3) => mk_rsplit (NPEpow e1 (Npos q)) (NPEpow e1 (Npos (p - q))) e3 + | None => mk_rsplit (NPEpow e1 (Npos p)) (PEc cI) e2 + end in + NPEeval l (PEpow e1 (Npos p)) == NPEeval l (NPEmul (left res) (common res)) + /\ + NPEeval l e2 == NPEeval l (NPEmul (right res) (common res)). +Proof. + intros. unfold res. clear res; generalize (isIn_correct l e1 p e2 xH). + destruct (isIn e1 p e2 1). destruct p0. +>>>>>>> .merge_file_U4r9lJ Opaque NPEpow NPEmul. intros. unfold res;clear res; generalize (isIn_ok e1 p e2 xH). destruct (isIn e1 p e2 1) as [([|p'],e')|]; simpl. @@ -1090,6 +1148,7 @@ Eval compute Theorem Pcond_Fnorm l e : PCond l (condition (Fnorm e)) -> ~ (denum (Fnorm e))@l == 0. Proof. +<<<<<<< .merge_file_5Z3Qpn induction e; simpl condition; rewrite ?PCond_cons, ?PCond_app; simpl denum; intros (Hc1,Hc2) || intros Hc; rewrite ?NPEmul_ok. - simpl. rewrite phi_1; exact rI_neq_rO. @@ -1112,6 +1171,93 @@ induction e; simpl condition; rewrite ?PCond_cons, ?PCond_app; + apply split_nz_r, Hc1. - rewrite NPEpow_ok. apply PEpow_nz, IHe, Hc. Qed. +======= + induction p;simpl. + intro Hp;assert (H1 := @rmul_reg_l _ (pow_pos rmul x p * pow_pos rmul x p) 0 H). + apply IHp. + rewrite (@rmul_reg_l _ (pow_pos rmul x p) 0 IHp). + reflexivity. + rewrite H1. ring. rewrite Hp;ring. + intro Hp;apply IHp. rewrite (@rmul_reg_l _ (pow_pos rmul x p) 0 IHp). + reflexivity. rewrite Hp;ring. trivial. +Qed. + +Theorem Pcond_Fnorm: + forall l e, + PCond l (condition (Fnorm e)) -> ~ NPEeval l ((Fnorm e).(denum)) == 0. +intros l e; elim e. + simpl; intros _ _; rewrite (morph1 CRmorph); exact rI_neq_rO. + simpl; intros _ _; rewrite (morph1 CRmorph); exact rI_neq_rO. + intros e1 Hrec1 e2 Hrec2 Hcond. + simpl in Hcond. + simpl @denum. + rewrite NPEmul_correct. + simpl. + apply field_is_integral_domain. + intros HH; case Hrec1; auto. + apply PCond_app_inv_l with (1 := Hcond). + rewrite (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2))). + rewrite NPEmul_correct; simpl; rewrite HH; ring. + intros HH; case Hrec2; auto. + apply PCond_app_inv_r with (1 := Hcond). + rewrite (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))); auto. + intros e1 Hrec1 e2 Hrec2 Hcond. + simpl @condition in Hcond. + simpl @denum. + rewrite NPEmul_correct. + simpl. + apply field_is_integral_domain. + intros HH; case Hrec1; auto. + apply PCond_app_inv_l with (1 := Hcond). + rewrite (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2))). + rewrite NPEmul_correct; simpl; rewrite HH; ring. + intros HH; case Hrec2; auto. + apply PCond_app_inv_r with (1 := Hcond). + rewrite (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))); auto. + intros e1 Hrec1 e2 Hrec2 Hcond. + simpl in Hcond. + simpl @denum. + rewrite NPEmul_correct. + simpl. + apply field_is_integral_domain. + intros HH; apply Hrec1. + apply PCond_app_inv_l with (1 := Hcond). + rewrite (split_correct_r l (num (Fnorm e2)) (denum (Fnorm e1))). + rewrite NPEmul_correct; simpl; rewrite HH; ring. + intros HH; apply Hrec2. + apply PCond_app_inv_r with (1 := Hcond). + rewrite (split_correct_r l (num (Fnorm e1)) (denum (Fnorm e2))). + rewrite NPEmul_correct; simpl; rewrite HH; ring. + intros e1 Hrec1 Hcond. + simpl in Hcond. + simpl @denum. + auto. + intros e1 Hrec1 Hcond. + simpl in Hcond. + simpl @denum. + apply PCond_cons_inv_l with (1:=Hcond). + intros e1 Hrec1 e2 Hrec2 Hcond. + simpl in Hcond. + simpl @denum. + rewrite NPEmul_correct. + simpl. + apply field_is_integral_domain. + intros HH; apply Hrec1. + specialize PCond_cons_inv_r with (1:=Hcond); intro Hcond1. + apply PCond_app_inv_l with (1 := Hcond1). + rewrite (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2))). + rewrite NPEmul_correct; simpl; rewrite HH; ring. + intros HH; apply PCond_cons_inv_l with (1:=Hcond). + rewrite (split_correct_r l (num (Fnorm e1)) (num (Fnorm e2))). + rewrite NPEmul_correct; simpl; rewrite HH; ring. + simpl;intros e1 Hrec1 n Hcond. + rewrite NPEpow_correct. + simpl;rewrite pow_th.(rpow_pow_N). + destruct n;simpl;intros. + apply AFth.(AF_1_neq_0). apply pow_pos_not_0;auto. +Qed. +Hint Resolve Pcond_Fnorm. +>>>>>>> .merge_file_U4r9lJ (*************************************************************************** @@ -1502,11 +1648,21 @@ Hypothesis ceqb_complete : forall c1 c2, [c1] == [c2] -> ceqb c1 c2 = true. Lemma ceqb_spec' c1 c2 : Bool.reflect ([c1] == [c2]) (ceqb c1 c2). Proof. +<<<<<<< .merge_file_5Z3Qpn assert (H := morph_eq CRmorph c1 c2). assert (H' := @ceqb_complete c1 c2). destruct (ceqb c1 c2); constructor. - now apply H. - intro E. specialize (H' E). discriminate. +======= +intros. +generalize (fun h => X (morph_eq CRmorph _ _ h)). +generalize (@ceqb_complete c1 c2). +case (c1 ?=! c2); auto; intros. +apply X0. +red; intro. +absurd (false = true); auto; discriminate. +>>>>>>> .merge_file_U4r9lJ Qed. Fixpoint Fcons1 (e:PExpr C) (l:list (PExpr C)) {struct e} : list (PExpr C) := @@ -1766,4 +1922,4 @@ End Field. End Complete. Arguments FEO [C]. -Arguments FEI [C].
\ No newline at end of file +Arguments FEI [C]. diff --git a/plugins/setoid_ring/InitialRing.v b/plugins/setoid_ring/InitialRing.v index ca178dd38..07f49cc4f 100644 --- a/plugins/setoid_ring/InitialRing.v +++ b/plugins/setoid_ring/InitialRing.v @@ -15,6 +15,7 @@ Require Import Ring_polynom. Import List. Set Implicit Arguments. +(* Set Universe Polymorphism. *) Import RingSyntax. diff --git a/plugins/setoid_ring/Ring_polynom.v b/plugins/setoid_ring/Ring_polynom.v index 6ffa54866..5ec73950b 100644 --- a/plugins/setoid_ring/Ring_polynom.v +++ b/plugins/setoid_ring/Ring_polynom.v @@ -6,12 +6,14 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) + Set Implicit Arguments. -Require Import Setoid Morphisms BinList BinPos BinNat BinInt. +Require Import Setoid Morphisms. +Require Import BinList BinPos BinNat BinInt. Require Export Ring_theory. - Local Open Scope positive_scope. Import RingSyntax. +(* Set Universe Polymorphism. *) Section MakeRingPol. @@ -678,7 +680,7 @@ Section MakeRingPol. - add_permut. - destruct p; simpl; rewrite ?jump_pred_double; add_permut. - - destr_pos_sub; intros ->;Esimpl. + - destr_pos_sub; intros ->; Esimpl. + rewrite IHP';rsimpl. add_permut. + rewrite IHP', pow_pos_add;simpl;Esimpl. add_permut. + rewrite IHP1, pow_pos_add;rsimpl. add_permut. @@ -796,9 +798,9 @@ Section MakeRingPol. P@l == Q@l + [c] * R@l. Proof. revert l. - induction P as [c0 | j P IH | P1 IH1 i P2 IH2]; intros l; Esimpl. - - assert (H := div_th.(div_eucl_th) c0 c). - destruct cdiv as (q,r). rewrite H; Esimpl. add_permut. + induction P as [c0 | j P IH | P1 IH1 i P2 IH2]; intros l; Esimpl. + - assert (H := div_th.(div_eucl_th) c0 c). + destruct cdiv as (q,r). rewrite H; Esimpl. add_permut. - destr_factor. Esimpl. - destr_factor. Esimpl. add_permut. Qed. @@ -807,11 +809,12 @@ Section MakeRingPol. let (c,M) := cM in let (Q,R) := MFactor P c M in P@l == Q@l + [c] * M@@l * R@l. - Proof. + Proof. destruct cM as (c,M). revert M l. - induction P; destruct M; intros l; simpl; auto; + induction P; destruct M; intros l; simpl; auto; try (case ceqb_spec; intro He); - try (case Pos.compare_spec; intros He); rewrite ?He; + try (case Pos.compare_spec; intros He); + rewrite ?He; destr_factor; simpl; Esimpl. - assert (H := div_th.(div_eucl_th) c0 c). destruct cdiv as (q,r). rewrite H; Esimpl. add_permut. @@ -869,9 +872,9 @@ Section MakeRingPol. Lemma PSubstL1_ok n LM1 P1 l : MPcond LM1 l -> P1@l == (PSubstL1 P1 LM1 n)@l. Proof. - revert P1; induction LM1 as [|(M2,P2) LM2 IH]; simpl; intros. - - reflexivity. - - rewrite <- IH by intuition. now apply PNSubst1_ok. + revert P1; induction LM1 as [|(M2,P2) LM2 IH]; simpl; intros. + - reflexivity. + - rewrite <- IH by intuition; now apply PNSubst1_ok. Qed. Lemma PSubstL_ok n LM1 P1 P2 l : @@ -1483,4 +1486,4 @@ Qed. End MakeRingPol. Arguments PEO [C]. -Arguments PEI [C].
\ No newline at end of file +Arguments PEI [C]. diff --git a/plugins/setoid_ring/Ring_theory.v b/plugins/setoid_ring/Ring_theory.v index 42ce4edca..d56f50bec 100644 --- a/plugins/setoid_ring/Ring_theory.v +++ b/plugins/setoid_ring/Ring_theory.v @@ -28,6 +28,8 @@ Reserved Notation "x == y" (at level 70, no associativity). End RingSyntax. Import RingSyntax. +(* Set Universe Polymorphism. *) + Section Power. Variable R:Type. Variable rI : R. @@ -252,6 +254,7 @@ Section ALMOST_RING. Section SEMI_RING. Variable SReqe : sring_eq_ext radd rmul req. + Add Morphism radd : radd_ext1. exact (SRadd_ext SReqe). Qed. Add Morphism rmul : rmul_ext1. exact (SRmul_ext SReqe). Qed. Variable SRth : semi_ring_theory 0 1 radd rmul req. @@ -503,7 +506,6 @@ Qed. End ALMOST_RING. - Section AddRing. (* Variable R : Type. @@ -528,7 +530,6 @@ Inductive ring_kind : Type := (_ : ring_morph rO rI radd rmul rsub ropp req cO cI cadd cmul csub copp ceqb phi). - End AddRing. diff --git a/plugins/setoid_ring/newring.ml4 b/plugins/setoid_ring/newring.ml4 index 235ee8d72..7ed8e03a9 100644 --- a/plugins/setoid_ring/newring.ml4 +++ b/plugins/setoid_ring/newring.ml4 @@ -74,7 +74,7 @@ and mk_clos_app_but f_map subs f args n = | None -> mk_clos_app_but f_map subs f args (n+1) let interp_map l t = - try Some(List.assoc_f eq_constr t l) with Not_found -> None + try Some(List.assoc_f eq_constr_nounivs t l) with Not_found -> None let protect_maps = ref String.Map.empty let add_map s m = protect_maps := String.Map.add s m !protect_maps @@ -104,7 +104,7 @@ END;; (****************************************************************************) let closed_term t l = - let l = List.map constr_of_global l in + let l = List.map Universes.constr_of_global l in let cs = List.fold_right Quote.ConstrSet.add l Quote.ConstrSet.empty in if Quote.closed_under cs t then tclIDTAC else tclFAIL 0 (mt()) ;; @@ -141,15 +141,24 @@ let _ = add_tacdef false ((Loc.ghost,Id.of_string"ring_closed_term" let ic c = let env = Global.env() and sigma = Evd.empty in - Constrintern.interp_constr sigma env c + Constrintern.interp_open_constr sigma env c + +let ic_unsafe c = (*FIXME remove *) + let env = Global.env() and sigma = Evd.empty in + fst (Constrintern.interp_constr sigma env c) let ty c = Typing.type_of (Global.env()) Evd.empty c -let decl_constant na c = +let decl_constant na ctx c = + let vars = Universes.universes_of_constr c in + let ctx = Universes.restrict_universe_context (Univ.ContextSet.of_context ctx) vars in mkConst(declare_constant (Id.of_string na) (DefinitionEntry - { const_entry_body = c; + { const_entry_body = Future.from_val (c, Declareops.no_seff); const_entry_secctx = None; const_entry_type = None; + const_entry_polymorphic = false; + const_entry_universes = Univ.ContextSet.to_context ctx; + const_entry_proj = None; const_entry_opaque = true; const_entry_inline_code = false; const_entry_feedback = None; @@ -182,7 +191,11 @@ let dummy_goal env = Goal.V82.mk_goal Evd.empty (named_context_val env) mkProp Evd.Store.empty in {Evd.it = gl; Evd.sigma = sigma} -let exec_tactic env n f args = +let constr_of v = match Value.to_constr v with + | Some c -> c + | None -> failwith "Ring.exec_tactic: anomaly" + +let exec_tactic env evd n f args = let lid = List.init n (fun i -> Id.of_string("x"^string_of_int i)) in let res = ref [||] in let get_res ist = @@ -192,13 +205,14 @@ let exec_tactic env n f args = let getter = Tacexp(TacFun(List.map(fun id -> Some id) lid, Tacintern.glob_tactic(tacticIn get_res))) in - let _ = - Proofview.V82.of_tactic (Tacinterp.eval_tactic(ltac_call f (args@[getter]))) (dummy_goal env) in - !res - -let constr_of v = match Value.to_constr v with - | Some c -> c - | None -> failwith "Ring.exec_tactic: anomaly" + let gls = + (fun gl -> + let sigma = gl.Evd.sigma in + tclTHEN (Refiner.tclEVARS (Evd.merge sigma evd)) + (Proofview.V82.of_tactic (Tacinterp.eval_tactic(ltac_call f (args@[getter])))) gl) + (dummy_goal env) in + let evd, nf = Evarutil.nf_evars_and_universes (Refiner.project gls) in + Array.map (fun x -> nf (constr_of x)) !res, Evd.universe_context evd let stdlib_modules = [["Coq";"Setoids";"Setoid"]; @@ -209,6 +223,8 @@ let stdlib_modules = let coq_constant c = lazy (Coqlib.gen_constant_in_modules "Ring" stdlib_modules c) +let coq_reference c = + lazy (Coqlib.gen_reference_in_modules "Ring" stdlib_modules c) let coq_mk_Setoid = coq_constant "Build_Setoid_Theory" let coq_cons = coq_constant "cons" @@ -217,8 +233,15 @@ let coq_None = coq_constant "None" let coq_Some = coq_constant "Some" let coq_eq = coq_constant "eq" +let coq_pcons = coq_reference "cons" +let coq_pnil = coq_reference "nil" + let lapp f args = mkApp(Lazy.force f,args) +let plapp evd f args = + let fc = Evarutil.e_new_global evd (Lazy.force f) in + mkApp(fc,args) + let dest_rel0 t = match kind_of_term t with | App(f,args) when Array.length args >= 2 -> @@ -247,6 +270,8 @@ let plugin_modules = let my_constant c = lazy (Coqlib.gen_constant_in_modules "Ring" plugin_modules c) +let my_reference c = + lazy (Coqlib.gen_reference_in_modules "Ring" plugin_modules c) let new_ring_path = DirPath.make (List.map Id.of_string ["Ring_tac";plugin_dir;"Coq"]) @@ -266,9 +291,9 @@ let pol_cst s = mk_cst [plugin_dir;"Ring_polynom"] s ;; let coq_almost_ring_theory = my_constant "almost_ring_theory" (* setoid and morphism utilities *) -let coq_eq_setoid = my_constant "Eqsth" -let coq_eq_morph = my_constant "Eq_ext" -let coq_eq_smorph = my_constant "Eq_s_ext" +let coq_eq_setoid = my_reference "Eqsth" +let coq_eq_morph = my_reference "Eq_ext" +let coq_eq_smorph = my_reference "Eq_s_ext" (* ring -> almost_ring utilities *) let coq_ring_theory = my_constant "ring_theory" @@ -295,8 +320,8 @@ let ltac_inv_morph_nothing = zltac"inv_morph_nothing" let coq_pow_N_pow_N = my_constant "pow_N_pow_N" (* hypothesis *) -let coq_mkhypo = my_constant "mkhypo" -let coq_hypo = my_constant "hypo" +let coq_mkhypo = my_reference "mkhypo" +let coq_hypo = my_reference "hypo" (* Equality: do not evaluate but make recursive call on both sides *) let map_with_eq arg_map c = @@ -415,14 +440,14 @@ let theory_to_obj : ring_info -> obj = classify_function = (fun x -> Substitute x)} -let setoid_of_relation env a r = - let evm = Evd.empty in +let setoid_of_relation env evd a r = try - lapp coq_mk_Setoid - [|a ; r ; - Rewrite.get_reflexive_proof env evm a r ; - Rewrite.get_symmetric_proof env evm a r ; - Rewrite.get_transitive_proof env evm a r |] + let evm = !evd, Int.Set.empty in + let evm, refl = Rewrite.PropGlobal.get_reflexive_proof env evm a r in + let evm, sym = Rewrite.PropGlobal.get_symmetric_proof env evm a r in + let evm, trans = Rewrite.PropGlobal.get_transitive_proof env evm a r in + evd := fst evm; + lapp coq_mk_Setoid [|a ; r ; refl; sym; trans |] with Not_found -> error "cannot find setoid relation" @@ -435,7 +460,7 @@ let op_smorph r add mul req m1 m2 = (* let default_ring_equality (r,add,mul,opp,req) = *) (* let is_setoid = function *) (* {rel_refl=Some _; rel_sym=Some _;rel_trans=Some _;rel_aeq=rel} -> *) -(* eq_constr req rel (\* Qu: use conversion ? *\) *) +(* eq_constr_nounivs req rel (\* Qu: use conversion ? *\) *) (* | _ -> false in *) (* match default_relation_for_carrier ~filter:is_setoid r with *) (* Leibniz _ -> *) @@ -450,7 +475,7 @@ let op_smorph r add mul req m1 m2 = (* let is_endomorphism = function *) (* { args=args } -> List.for_all *) (* (function (var,Relation rel) -> *) -(* var=None && eq_constr req rel *) +(* var=None && eq_constr_nounivs req rel *) (* | _ -> false) args in *) (* let add_m = *) (* try default_morphism ~filter:is_endomorphism add *) @@ -485,17 +510,19 @@ let op_smorph r add mul req m1 m2 = (* op_smorph r add mul req add_m.lem mul_m.lem) in *) (* (setoid,op_morph) *) -let ring_equality (r,add,mul,opp,req) = +let ring_equality env evd (r,add,mul,opp,req) = match kind_of_term req with - | App (f, [| _ |]) when eq_constr f (Lazy.force coq_eq) -> - let setoid = lapp coq_eq_setoid [|r|] in + | App (f, [| _ |]) when eq_constr_nounivs f (Lazy.force coq_eq) -> + let setoid = plapp evd coq_eq_setoid [|r|] in let op_morph = match opp with - Some opp -> lapp coq_eq_morph [|r;add;mul;opp|] - | None -> lapp coq_eq_smorph [|r;add;mul|] in + Some opp -> plapp evd coq_eq_morph [|r;add;mul;opp|] + | None -> plapp evd coq_eq_smorph [|r;add;mul|] in + let setoid = Typing.solve_evars env evd setoid in + let op_morph = Typing.solve_evars env evd op_morph in (setoid,op_morph) | _ -> - let setoid = setoid_of_relation (Global.env ()) r req in + let setoid = setoid_of_relation (Global.env ()) evd r req in let signature = [Some (r,Some req);Some (r,Some req)],Some(r,Some req) in let add_m, add_m_lem = try Rewrite.default_morphism signature add @@ -532,22 +559,22 @@ let ring_equality (r,add,mul,opp,req) = op_smorph r add mul req add_m_lem mul_m_lem) in (setoid,op_morph) -let build_setoid_params r add mul opp req eqth = +let build_setoid_params env evd r add mul opp req eqth = match eqth with Some th -> th - | None -> ring_equality (r,add,mul,opp,req) + | None -> ring_equality env evd (r,add,mul,opp,req) let dest_ring env sigma th_spec = let th_typ = Retyping.get_type_of env sigma th_spec in match kind_of_term th_typ with App(f,[|r;zero;one;add;mul;sub;opp;req|]) - when eq_constr f (Lazy.force coq_almost_ring_theory) -> + when eq_constr_nounivs f (Lazy.force coq_almost_ring_theory) -> (None,r,zero,one,add,mul,Some sub,Some opp,req) | App(f,[|r;zero;one;add;mul;req|]) - when eq_constr f (Lazy.force coq_semi_ring_theory) -> + when eq_constr_nounivs f (Lazy.force coq_semi_ring_theory) -> (Some true,r,zero,one,add,mul,None,None,req) | App(f,[|r;zero;one;add;mul;sub;opp;req|]) - when eq_constr f (Lazy.force coq_ring_theory) -> + when eq_constr_nounivs f (Lazy.force coq_ring_theory) -> (Some false,r,zero,one,add,mul,Some sub,Some opp,req) | _ -> error "bad ring structure" @@ -557,10 +584,10 @@ let dest_morph env sigma m_spec = match kind_of_term m_typ with App(f,[|r;zero;one;add;mul;sub;opp;req; c;czero;cone;cadd;cmul;csub;copp;ceqb;phi|]) - when eq_constr f (Lazy.force coq_ring_morph) -> + when eq_constr_nounivs f (Lazy.force coq_ring_morph) -> (c,czero,cone,cadd,cmul,Some csub,Some copp,ceqb,phi) | App(f,[|r;zero;one;add;mul;req;c;czero;cone;cadd;cmul;ceqb;phi|]) - when eq_constr f (Lazy.force coq_semi_morph) -> + when eq_constr_nounivs f (Lazy.force coq_semi_morph) -> (c,czero,cone,cadd,cmul,None,None,ceqb,phi) | _ -> error "bad morphism structure" @@ -591,18 +618,22 @@ let interp_cst_tac env sigma rk kind (zero,one,add,mul,opp) cst_tac = let t = ArgArg(Loc.ghost,Lazy.force ltac_inv_morph_nothing) in TacArg(Loc.ghost,TacCall(Loc.ghost,t,[])) -let make_hyp env c = - let t = Retyping.get_type_of env Evd.empty c in - lapp coq_mkhypo [|t;c|] - -let make_hyp_list env lH = - let carrier = Lazy.force coq_hypo in - List.fold_right - (fun c l -> lapp coq_cons [|carrier; (make_hyp env c); l|]) lH - (lapp coq_nil [|carrier|]) - -let interp_power env pow = - let carrier = Lazy.force coq_hypo in +let make_hyp env evd c = + let t = Retyping.get_type_of env !evd c in + plapp evd coq_mkhypo [|t;c|] + +let make_hyp_list env evd lH = + let carrier = Evarutil.e_new_global evd (Lazy.force coq_hypo) in + let l = + List.fold_right + (fun c l -> plapp evd coq_pcons [|carrier; (make_hyp env evd c); l|]) lH + (plapp evd coq_pnil [|carrier|]) + in + let l' = Typing.solve_evars env evd l in + Evarutil.nf_evars_universes !evd l' + +let interp_power env evd pow = + let carrier = Evarutil.e_new_global evd (Lazy.force coq_hypo) in match pow with | None -> let t = ArgArg(Loc.ghost, Lazy.force ltac_inv_morph_nothing) in @@ -613,47 +644,47 @@ let interp_power env pow = | CstTac t -> Tacintern.glob_tactic t | Closed lc -> closed_term_ast (List.map Smartlocate.global_with_alias lc) in - let spec = make_hyp env (ic spec) in + let spec = make_hyp env evd (ic_unsafe spec) in (tac, lapp coq_Some [|carrier; spec|]) -let interp_sign env sign = - let carrier = Lazy.force coq_hypo in +let interp_sign env evd sign = + let carrier = Evarutil.e_new_global evd (Lazy.force coq_hypo) in match sign with | None -> lapp coq_None [|carrier|] | Some spec -> - let spec = make_hyp env (ic spec) in + let spec = make_hyp env evd (ic_unsafe spec) in lapp coq_Some [|carrier;spec|] (* Same remark on ill-typed terms ... *) -let interp_div env div = - let carrier = Lazy.force coq_hypo in +let interp_div env evd div = + let carrier = Evarutil.e_new_global evd (Lazy.force coq_hypo) in match div with | None -> lapp coq_None [|carrier|] | Some spec -> - let spec = make_hyp env (ic spec) in + let spec = make_hyp env evd (ic_unsafe spec) in lapp coq_Some [|carrier;spec|] (* Same remark on ill-typed terms ... *) -let add_theory name rth eqth morphth cst_tac (pre,post) power sign div = +let add_theory name (sigma,rth) eqth morphth cst_tac (pre,post) power sign div = check_required_library (cdir@["Ring_base"]); let env = Global.env() in - let sigma = Evd.empty in let (kind,r,zero,one,add,mul,sub,opp,req) = dest_ring env sigma rth in - let (sth,ext) = build_setoid_params r add mul opp req eqth in - let (pow_tac, pspec) = interp_power env power in - let sspec = interp_sign env sign in - let dspec = interp_div env div in + let evd = ref sigma in + let (sth,ext) = build_setoid_params env evd r add mul opp req eqth in + let (pow_tac, pspec) = interp_power env evd power in + let sspec = interp_sign env evd sign in + let dspec = interp_div env evd div in let rk = reflect_coeff morphth in - let params = - exec_tactic env 5 (zltac "ring_lemmas") + let params,ctx = + exec_tactic env !evd 5 (zltac "ring_lemmas") (List.map carg[sth;ext;rth;pspec;sspec;dspec;rk]) in - let lemma1 = constr_of params.(3) in - let lemma2 = constr_of params.(4) in + let lemma1 = params.(3) in + let lemma2 = params.(4) in let lemma1 = - decl_constant (Id.to_string name^"_ring_lemma1") (Future.from_val ( lemma1,Declareops.no_seff)) in + decl_constant (Id.to_string name^"_ring_lemma1") ctx (Future.from_val ( lemma1,Declareops.no_seff)) in let lemma2 = - decl_constant (Id.to_string name^"_ring_lemma2") (Future.from_val ( lemma2,Declareops.no_seff)) in + decl_constant (Id.to_string name^"_ring_lemma2") ctx (Future.from_val ( lemma2,Declareops.no_seff)) in let cst_tac = interp_cst_tac env sigma morphth kind (zero,one,add,mul,opp) cst_tac in let pretac = @@ -670,9 +701,9 @@ let add_theory name rth eqth morphth cst_tac (pre,post) power sign div = { ring_carrier = r; ring_req = req; ring_setoid = sth; - ring_ext = constr_of params.(1); - ring_morph = constr_of params.(2); - ring_th = constr_of params.(0); + ring_ext = params.(1); + ring_morph = params.(2); + ring_th = params.(0); ring_cst_tac = cst_tac; ring_pow_tac = pow_tac; ring_lemma1 = lemma1; @@ -692,16 +723,11 @@ type 'constr ring_mod = | Sign_spec of Constrexpr.constr_expr | Div_spec of Constrexpr.constr_expr -let ic_coeff_spec = function - | Computational t -> Computational (ic t) - | Morphism t -> Morphism (ic t) - | Abstract -> Abstract - VERNAC ARGUMENT EXTEND ring_mod - | [ "decidable" constr(eq_test) ] -> [ Ring_kind(Computational eq_test) ] + | [ "decidable" constr(eq_test) ] -> [ Ring_kind(Computational (ic_unsafe eq_test)) ] | [ "abstract" ] -> [ Ring_kind Abstract ] - | [ "morphism" constr(morph) ] -> [ Ring_kind(Morphism morph) ] + | [ "morphism" constr(morph) ] -> [ Ring_kind(Morphism (ic_unsafe morph)) ] | [ "constants" "[" tactic(cst_tac) "]" ] -> [ Const_tac(CstTac cst_tac) ] | [ "closed" "[" ne_global_list(l) "]" ] -> [ Const_tac(Closed l) ] | [ "preprocess" "[" tactic(pre) "]" ] -> [ Pre_tac pre ] @@ -732,11 +758,11 @@ let process_ring_mods l = | Const_tac t -> set_once "tactic recognizing constants" cst_tac t | Pre_tac t -> set_once "preprocess tactic" pre t | Post_tac t -> set_once "postprocess tactic" post t - | Setoid(sth,ext) -> set_once "setoid" set (ic sth,ic ext) + | Setoid(sth,ext) -> set_once "setoid" set (ic_unsafe sth,ic_unsafe ext) | Pow_spec(t,spec) -> set_once "power" power (t,spec) | Sign_spec t -> set_once "sign" sign t | Div_spec t -> set_once "div" div t) l; - let k = match !kind with Some k -> ic_coeff_spec k | None -> Abstract in + let k = match !kind with Some k -> k | None -> Abstract in (k, !set, !cst_tac, !pre, !post, !power, !sign, !div) VERNAC COMMAND EXTEND AddSetoidRing CLASSIFIED AS SIDEFF @@ -762,10 +788,11 @@ let make_args_list rl t = | [] -> let (_,t1,t2) = dest_rel0 t in [t1;t2] | _ -> rl -let make_term_list carrier rl = - List.fold_right - (fun x l -> lapp coq_cons [|carrier;x;l|]) rl - (lapp coq_nil [|carrier|]) +let make_term_list env evd carrier rl = + let l = List.fold_right + (fun x l -> plapp evd coq_pcons [|carrier;x;l|]) rl + (plapp evd coq_pnil [|carrier|]) + in Typing.solve_evars env evd l let ltac_ring_structure e = let req = carg e.ring_req in @@ -786,12 +813,15 @@ let ring_lookup (f:glob_tactic_expr) lH rl t = Proofview.Goal.raw_enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in - let rl = make_args_list rl t in - let e = find_ring_structure env sigma rl in - let rl = carg (make_term_list e.ring_carrier rl) in - let lH = carg (make_hyp_list env lH) in - let ring = ltac_ring_structure e in - ltac_apply f (ring@[lH;rl]) + try (* find_ring_strucure can raise an exception *) + let evdref = ref sigma in + let rl = make_args_list rl t in + let e = find_ring_structure env sigma rl in + let rl = carg (make_term_list env evdref e.ring_carrier rl) in + let lH = carg (make_hyp_list env evdref lH) in + let ring = ltac_ring_structure e in + Proofview.tclTHEN (Proofview.V82.tclEVARS !evdref) (ltac_apply f (ring@[lH;rl])) + with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e end TACTIC EXTEND ring_lookup @@ -850,26 +880,26 @@ let _ = Redexpr.declare_reduction "simpl_field_expr" let afield_theory = my_constant "almost_field_theory" let field_theory = my_constant "field_theory" let sfield_theory = my_constant "semi_field_theory" -let af_ar = my_constant"AF_AR" -let f_r = my_constant"F_R" -let sf_sr = my_constant"SF_SR" -let dest_field env sigma th_spec = - let th_typ = Retyping.get_type_of env sigma th_spec in +let af_ar = my_reference"AF_AR" +let f_r = my_reference"F_R" +let sf_sr = my_reference"SF_SR" +let dest_field env evd th_spec = + let th_typ = Retyping.get_type_of env !evd th_spec in match kind_of_term th_typ with | App(f,[|r;zero;one;add;mul;sub;opp;div;inv;req|]) - when eq_constr f (Lazy.force afield_theory) -> - let rth = lapp af_ar + when eq_constr_nounivs f (Lazy.force afield_theory) -> + let rth = plapp evd af_ar [|r;zero;one;add;mul;sub;opp;div;inv;req;th_spec|] in (None,r,zero,one,add,mul,Some sub,Some opp,div,inv,req,rth) | App(f,[|r;zero;one;add;mul;sub;opp;div;inv;req|]) - when eq_constr f (Lazy.force field_theory) -> + when eq_constr_nounivs f (Lazy.force field_theory) -> let rth = - lapp f_r + plapp evd f_r [|r;zero;one;add;mul;sub;opp;div;inv;req;th_spec|] in (Some false,r,zero,one,add,mul,Some sub,Some opp,div,inv,req,rth) | App(f,[|r;zero;one;add;mul;div;inv;req|]) - when eq_constr f (Lazy.force sfield_theory) -> - let rth = lapp sf_sr + when eq_constr_nounivs f (Lazy.force sfield_theory) -> + let rth = plapp evd sf_sr [|r;zero;one;add;mul;div;inv;req;th_spec|] in (Some true,r,zero,one,add,mul,None,None,div,inv,req,rth) | _ -> error "bad field structure" @@ -960,12 +990,12 @@ let ftheory_to_obj : field_info -> obj = subst_function = subst_th; classify_function = (fun x -> Substitute x) } -let field_equality r inv req = +let field_equality evd r inv req = match kind_of_term req with - | App (f, [| _ |]) when eq_constr f (Lazy.force coq_eq) -> - mkApp((Coqlib.build_coq_eq_data()).congr,[|r;r;inv|]) + | App (f, [| _ |]) when eq_constr_nounivs f (Lazy.force coq_eq) -> + mkApp(Universes.constr_of_global (Coqlib.build_coq_eq_data()).congr,[|r;r;inv|]) | _ -> - let _setoid = setoid_of_relation (Global.env ()) r req in + let _setoid = setoid_of_relation (Global.env ()) evd r req in let signature = [Some (r,Some req)],Some(r,Some req) in let inv_m, inv_m_lem = try Rewrite.default_morphism signature inv @@ -973,36 +1003,41 @@ let field_equality r inv req = error "field inverse should be declared as a morphism" in inv_m_lem -let add_field_theory name fth eqth morphth cst_tac inj (pre,post) power sign odiv = +let add_field_theory name (sigma,fth) eqth morphth cst_tac inj (pre,post) power sign odiv = check_required_library (cdir@["Field_tac"]); let env = Global.env() in - let sigma = Evd.empty in + let evd = ref sigma in let (kind,r,zero,one,add,mul,sub,opp,div,inv,req,rth) = - dest_field env sigma fth in - let (sth,ext) = build_setoid_params r add mul opp req eqth in + dest_field env evd fth in + let (sth,ext) = build_setoid_params env evd r add mul opp req eqth in let eqth = Some(sth,ext) in - let _ = add_theory name rth eqth morphth cst_tac (None,None) power sign odiv in - let (pow_tac, pspec) = interp_power env power in - let sspec = interp_sign env sign in - let dspec = interp_div env odiv in - let inv_m = field_equality r inv req in + let _ = add_theory name (!evd,rth) eqth morphth cst_tac (None,None) power sign odiv in + let (pow_tac, pspec) = interp_power env evd power in + let sspec = interp_sign env evd sign in + let dspec = interp_div env evd odiv in + let inv_m = field_equality evd r inv req in let rk = reflect_coeff morphth in - let params = - exec_tactic env 9 (field_ltac"field_lemmas") + let params,ctx = + exec_tactic env !evd 9 (field_ltac"field_lemmas") (List.map carg[sth;ext;inv_m;fth;pspec;sspec;dspec;rk]) in - let lemma1 = constr_of params.(3) in - let lemma2 = constr_of params.(4) in - let lemma3 = constr_of params.(5) in - let lemma4 = constr_of params.(6) in + let lemma1 = params.(3) in + let lemma2 = params.(4) in + let lemma3 = params.(5) in + let lemma4 = params.(6) in let cond_lemma = match inj with | Some thm -> mkApp(constr_of params.(8),[|thm|]) | None -> constr_of params.(7) in - let lemma1 = decl_constant (Id.to_string name^"_field_lemma1") (Future.from_val (lemma1,Declareops.no_seff)) in - let lemma2 = decl_constant (Id.to_string name^"_field_lemma2") (Future.from_val (lemma2,Declareops.no_seff)) in - let lemma3 = decl_constant (Id.to_string name^"_field_lemma3") (Future.from_val (lemma3,Declareops.no_seff)) in - let lemma4 = decl_constant (Id.to_string name^"_field_lemma4") (Future.from_val (lemma4,Declareops.no_seff)) in - let cond_lemma = decl_constant (Id.to_string name^"_lemma5") (Future.from_val (cond_lemma,Declareops.no_seff)) in + let lemma1 = decl_constant (Id.to_string name^"_field_lemma1") + ctx (Future.from_val (lemma1,Declareops.no_seff)) in + let lemma2 = decl_constant (Id.to_string name^"_field_lemma2") + ctx (Future.from_val (lemma2,Declareops.no_seff)) in + let lemma3 = decl_constant (Id.to_string name^"_field_lemma3") + ctx (Future.from_val (lemma3,Declareops.no_seff)) in + let lemma4 = decl_constant (Id.to_string name^"_field_lemma4") + ctx (Future.from_val (lemma4,Declareops.no_seff)) in + let cond_lemma = decl_constant (Id.to_string name^"_lemma5") + ctx (Future.from_val (cond_lemma,Declareops.no_seff)) in let cst_tac = interp_cst_tac env sigma morphth kind (zero,one,add,mul,opp) cst_tac in let pretac = @@ -1053,12 +1088,12 @@ let process_field_mods l = set_once "tactic recognizing constants" cst_tac t | Ring_mod(Pre_tac t) -> set_once "preprocess tactic" pre t | Ring_mod(Post_tac t) -> set_once "postprocess tactic" post t - | Ring_mod(Setoid(sth,ext)) -> set_once "setoid" set (ic sth,ic ext) + | Ring_mod(Setoid(sth,ext)) -> set_once "setoid" set (ic_unsafe sth,ic_unsafe ext) | Ring_mod(Pow_spec(t,spec)) -> set_once "power" power (t,spec) | Ring_mod(Sign_spec t) -> set_once "sign" sign t | Ring_mod(Div_spec t) -> set_once "div" div t - | Inject i -> set_once "infinite property" inj (ic i)) l; - let k = match !kind with Some k -> ic_coeff_spec k | None -> Abstract in + | Inject i -> set_once "infinite property" inj (ic_unsafe i)) l; + let k = match !kind with Some k -> k | None -> Abstract in (k, !set, !inj, !cst_tac, !pre, !post, !power, !sign, !div) VERNAC COMMAND EXTEND AddSetoidField CLASSIFIED AS SIDEFF @@ -1094,12 +1129,15 @@ let field_lookup (f:glob_tactic_expr) lH rl t = Proofview.Goal.raw_enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in - let rl = make_args_list rl t in - let e = find_field_structure env sigma rl in - let rl = carg (make_term_list e.field_carrier rl) in - let lH = carg (make_hyp_list env lH) in - let field = ltac_field_structure e in - ltac_apply f (field@[lH;rl]) + try + let evdref = ref sigma in + let rl = make_args_list rl t in + let e = find_field_structure env sigma rl in + let rl = carg (make_term_list env evdref e.field_carrier rl) in + let lH = carg (make_hyp_list env evdref lH) in + let field = ltac_field_structure e in + Proofview.tclTHEN (Proofview.V82.tclEVARS !evdref) (ltac_apply f (field@[lH;rl])) + with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e end diff --git a/plugins/syntax/ascii_syntax.ml b/plugins/syntax/ascii_syntax.ml index 790e1970b..5c060c3d6 100644 --- a/plugins/syntax/ascii_syntax.ml +++ b/plugins/syntax/ascii_syntax.ml @@ -37,9 +37,9 @@ let interp_ascii dloc p = let rec aux n p = if Int.equal n 0 then [] else let mp = p mod 2 in - GRef (dloc,if Int.equal mp 0 then glob_false else glob_true) + GRef (dloc,if Int.equal mp 0 then glob_false else glob_true,None) :: (aux (n-1) (p/2)) in - GApp (dloc,GRef(dloc,force glob_Ascii), aux 8 p) + GApp (dloc,GRef(dloc,force glob_Ascii,None), aux 8 p) let interp_ascii_string dloc s = let p = @@ -55,12 +55,12 @@ let interp_ascii_string dloc s = let uninterp_ascii r = let rec uninterp_bool_list n = function | [] when Int.equal n 0 -> 0 - | GRef (_,k)::l when Globnames.eq_gr k glob_true -> 1+2*(uninterp_bool_list (n-1) l) - | GRef (_,k)::l when Globnames.eq_gr k glob_false -> 2*(uninterp_bool_list (n-1) l) + | GRef (_,k,_)::l when Globnames.eq_gr k glob_true -> 1+2*(uninterp_bool_list (n-1) l) + | GRef (_,k,_)::l when Globnames.eq_gr k glob_false -> 2*(uninterp_bool_list (n-1) l) | _ -> raise Non_closed_ascii in try let aux = function - | GApp (_,GRef (_,k),l) when Globnames.eq_gr k (force glob_Ascii) -> uninterp_bool_list 8 l + | GApp (_,GRef (_,k,_),l) when Globnames.eq_gr k (force glob_Ascii) -> uninterp_bool_list 8 l | _ -> raise Non_closed_ascii in Some (aux r) with @@ -76,4 +76,4 @@ let _ = Notation.declare_string_interpreter "char_scope" (ascii_path,ascii_module) interp_ascii_string - ([GRef (Loc.ghost,static_glob_Ascii)], uninterp_ascii_string, true) + ([GRef (Loc.ghost,static_glob_Ascii,None)], uninterp_ascii_string, true) diff --git a/plugins/syntax/nat_syntax.ml b/plugins/syntax/nat_syntax.ml index c3dad0a10..bad099d4f 100644 --- a/plugins/syntax/nat_syntax.ml +++ b/plugins/syntax/nat_syntax.ml @@ -30,8 +30,8 @@ let nat_of_int dloc n = strbrk "working with large numbers in nat (observed threshold " ++ strbrk "may vary from 5000 to 70000 depending on your system " ++ strbrk "limits and on the command executed)."); - let ref_O = GRef (dloc, glob_O) in - let ref_S = GRef (dloc, glob_S) in + let ref_O = GRef (dloc, glob_O, None) in + let ref_S = GRef (dloc, glob_S, None) in let rec mk_nat acc n = if n <> zero then mk_nat (GApp (dloc,ref_S, [acc])) (sub_1 n) @@ -50,8 +50,8 @@ let nat_of_int dloc n = exception Non_closed_number let rec int_of_nat = function - | GApp (_,GRef (_,s),[a]) when Globnames.eq_gr s glob_S -> add_1 (int_of_nat a) - | GRef (_,z) when Globnames.eq_gr z glob_O -> zero + | GApp (_,GRef (_,s,_),[a]) when Globnames.eq_gr s glob_S -> add_1 (int_of_nat a) + | GRef (_,z,_) when Globnames.eq_gr z glob_O -> zero | _ -> raise Non_closed_number let uninterp_nat p = @@ -67,4 +67,4 @@ let _ = Notation.declare_numeral_interpreter "nat_scope" (nat_path,datatypes_module_name) nat_of_int - ([GRef (Loc.ghost,glob_S); GRef (Loc.ghost,glob_O)], uninterp_nat, true) + ([GRef (Loc.ghost,glob_S,None); GRef (Loc.ghost,glob_O,None)], uninterp_nat, true) diff --git a/plugins/syntax/numbers_syntax.ml b/plugins/syntax/numbers_syntax.ml index 8e09c974a..a6b3d9038 100644 --- a/plugins/syntax/numbers_syntax.ml +++ b/plugins/syntax/numbers_syntax.ml @@ -83,9 +83,9 @@ exception Non_closed (* parses a *non-negative* integer (from bigint.ml) into an int31 wraps modulo 2^31 *) let int31_of_pos_bigint dloc n = - let ref_construct = GRef (dloc, int31_construct) in - let ref_0 = GRef (dloc, int31_0) in - let ref_1 = GRef (dloc, int31_1) in + let ref_construct = GRef (dloc, int31_construct, None) in + let ref_0 = GRef (dloc, int31_0, None) in + let ref_1 = GRef (dloc, int31_1, None) in let rec args counter n = if counter <= 0 then [] @@ -110,12 +110,12 @@ let bigint_of_int31 = let rec args_parsing args cur = match args with | [] -> cur - | (GRef (_,b))::l when eq_gr b int31_0 -> args_parsing l (mult_2 cur) - | (GRef (_,b))::l when eq_gr b int31_1 -> args_parsing l (add_1 (mult_2 cur)) + | (GRef (_,b,_))::l when eq_gr b int31_0 -> args_parsing l (mult_2 cur) + | (GRef (_,b,_))::l when eq_gr b int31_1 -> args_parsing l (add_1 (mult_2 cur)) | _ -> raise Non_closed in function - | GApp (_, GRef (_, c), args) when eq_gr c int31_construct -> args_parsing args zero + | GApp (_, GRef (_, c, _), args) when eq_gr c int31_construct -> args_parsing args zero | _ -> raise Non_closed let uninterp_int31 i = @@ -128,7 +128,7 @@ let uninterp_int31 i = let _ = Notation.declare_numeral_interpreter int31_scope (int31_path, int31_module) interp_int31 - ([GRef (Loc.ghost, int31_construct)], + ([GRef (Loc.ghost, int31_construct, None)], uninterp_int31, true) @@ -159,8 +159,8 @@ let height bi = (* n must be a non-negative integer (from bigint.ml) *) let word_of_pos_bigint dloc hght n = - let ref_W0 = GRef (dloc, zn2z_W0) in - let ref_WW = GRef (dloc, zn2z_WW) in + let ref_W0 = GRef (dloc, zn2z_W0, None) in + let ref_WW = GRef (dloc, zn2z_WW, None) in let rec decomp hgt n = if hgt <= 0 then int31_of_pos_bigint dloc n @@ -176,7 +176,7 @@ let word_of_pos_bigint dloc hght n = let bigN_of_pos_bigint dloc n = let h = height n in - let ref_constructor = GRef (dloc, bigN_constructor h) in + let ref_constructor = GRef (dloc, bigN_constructor h, None) in let word = word_of_pos_bigint dloc h n in let args = if h < n_inlined then [word] @@ -199,14 +199,14 @@ let interp_bigN dloc n = let bigint_of_word = let rec get_height rc = match rc with - | GApp (_,GRef(_,c), [_;lft;rght]) when eq_gr c zn2z_WW -> + | GApp (_,GRef(_,c,_), [_;lft;rght]) when eq_gr c zn2z_WW -> 1+max (get_height lft) (get_height rght) | _ -> 0 in let rec transform hght rc = match rc with - | GApp (_,GRef(_,c),_) when eq_gr c zn2z_W0-> zero - | GApp (_,GRef(_,c), [_;lft;rght]) when eq_gr c zn2z_WW-> + | GApp (_,GRef(_,c,_),_) when eq_gr c zn2z_W0-> zero + | GApp (_,GRef(_,c,_), [_;lft;rght]) when eq_gr c zn2z_WW-> let new_hght = hght-1 in add (mult (rank new_hght) (transform new_hght lft)) @@ -236,7 +236,7 @@ let uninterp_bigN rc = let bigN_list_of_constructors = let rec build i = if i < n_inlined+1 then - GRef (Loc.ghost, bigN_constructor i)::(build (i+1)) + GRef (Loc.ghost, bigN_constructor i,None)::(build (i+1)) else [] in @@ -253,8 +253,8 @@ let _ = Notation.declare_numeral_interpreter bigN_scope (*** Parsing for bigZ in digital notation ***) let interp_bigZ dloc n = - let ref_pos = GRef (dloc, bigZ_pos) in - let ref_neg = GRef (dloc, bigZ_neg) in + let ref_pos = GRef (dloc, bigZ_pos, None) in + let ref_neg = GRef (dloc, bigZ_neg, None) in if is_pos_or_zero n then GApp (dloc, ref_pos, [bigN_of_pos_bigint dloc n]) else @@ -262,8 +262,8 @@ let interp_bigZ dloc n = (* pretty printing functions for bigZ *) let bigint_of_bigZ = function - | GApp (_, GRef(_,c), [one_arg]) when eq_gr c bigZ_pos -> bigint_of_bigN one_arg - | GApp (_, GRef(_,c), [one_arg]) when eq_gr c bigZ_neg -> + | GApp (_, GRef(_,c,_), [one_arg]) when eq_gr c bigZ_pos -> bigint_of_bigN one_arg + | GApp (_, GRef(_,c,_), [one_arg]) when eq_gr c bigZ_neg -> let opp_val = bigint_of_bigN one_arg in if equal opp_val zero then raise Non_closed @@ -282,19 +282,19 @@ let uninterp_bigZ rc = let _ = Notation.declare_numeral_interpreter bigZ_scope (bigZ_path, bigZ_module) interp_bigZ - ([GRef (Loc.ghost, bigZ_pos); - GRef (Loc.ghost, bigZ_neg)], + ([GRef (Loc.ghost, bigZ_pos, None); + GRef (Loc.ghost, bigZ_neg, None)], uninterp_bigZ, true) (*** Parsing for bigQ in digital notation ***) let interp_bigQ dloc n = - let ref_z = GRef (dloc, bigQ_z) in + let ref_z = GRef (dloc, bigQ_z, None) in GApp (dloc, ref_z, [interp_bigZ dloc n]) let uninterp_bigQ rc = try match rc with - | GApp (_, GRef(_,c), [one_arg]) when eq_gr c bigQ_z -> + | GApp (_, GRef(_,c,_), [one_arg]) when eq_gr c bigQ_z -> Some (bigint_of_bigZ one_arg) | _ -> None (* we don't pretty-print yet fractions *) with Non_closed -> None @@ -303,5 +303,5 @@ let uninterp_bigQ rc = let _ = Notation.declare_numeral_interpreter bigQ_scope (bigQ_path, bigQ_module) interp_bigQ - ([GRef (Loc.ghost, bigQ_z)], uninterp_bigQ, + ([GRef (Loc.ghost, bigQ_z, None)], uninterp_bigQ, true) diff --git a/plugins/syntax/r_syntax.ml b/plugins/syntax/r_syntax.ml index 545f205db..dac70c673 100644 --- a/plugins/syntax/r_syntax.ml +++ b/plugins/syntax/r_syntax.ml @@ -42,24 +42,24 @@ let four = mult_2 two (* Unary representation of strictly positive numbers *) let rec small_r dloc n = - if equal one n then GRef (dloc, glob_R1) - else GApp(dloc,GRef (dloc,glob_Rplus), - [GRef (dloc, glob_R1);small_r dloc (sub_1 n)]) + if equal one n then GRef (dloc, glob_R1, None) + else GApp(dloc,GRef (dloc,glob_Rplus, None), + [GRef (dloc, glob_R1, None);small_r dloc (sub_1 n)]) let r_of_posint dloc n = - let r1 = GRef (dloc, glob_R1) in + let r1 = GRef (dloc, glob_R1, None) in let r2 = small_r dloc two in let rec r_of_pos n = if less_than n four then small_r dloc n else let (q,r) = div2_with_rest n in - let b = GApp(dloc,GRef(dloc,glob_Rmult),[r2;r_of_pos q]) in - if r then GApp(dloc,GRef(dloc,glob_Rplus),[r1;b]) else b in - if not (Bigint.equal n zero) then r_of_pos n else GRef(dloc,glob_R0) + let b = GApp(dloc,GRef(dloc,glob_Rmult,None),[r2;r_of_pos q]) in + if r then GApp(dloc,GRef(dloc,glob_Rplus,None),[r1;b]) else b in + if not (Bigint.equal n zero) then r_of_pos n else GRef(dloc,glob_R0,None) let r_of_int dloc z = if is_strictly_neg z then - GApp (dloc, GRef(dloc,glob_Ropp), [r_of_posint dloc (neg z)]) + GApp (dloc, GRef(dloc,glob_Ropp,None), [r_of_posint dloc (neg z)]) else r_of_posint dloc z @@ -71,33 +71,33 @@ let bignat_of_r = (* for numbers > 1 *) let rec bignat_of_pos = function (* 1+1 *) - | GApp (_,GRef (_,p), [GRef (_,o1); GRef (_,o2)]) + | GApp (_,GRef (_,p,_), [GRef (_,o1,_); GRef (_,o2,_)]) when Globnames.eq_gr p glob_Rplus && Globnames.eq_gr o1 glob_R1 && Globnames.eq_gr o2 glob_R1 -> two (* 1+(1+1) *) - | GApp (_,GRef (_,p1), [GRef (_,o1); - GApp(_,GRef (_,p2),[GRef(_,o2);GRef(_,o3)])]) + | GApp (_,GRef (_,p1,_), [GRef (_,o1,_); + GApp(_,GRef (_,p2,_),[GRef(_,o2,_);GRef(_,o3,_)])]) when Globnames.eq_gr p1 glob_Rplus && Globnames.eq_gr p2 glob_Rplus && Globnames.eq_gr o1 glob_R1 && Globnames.eq_gr o2 glob_R1 && Globnames.eq_gr o3 glob_R1 -> three (* (1+1)*b *) - | GApp (_,GRef (_,p), [a; b]) when Globnames.eq_gr p glob_Rmult -> + | GApp (_,GRef (_,p,_), [a; b]) when Globnames.eq_gr p glob_Rmult -> if not (Bigint.equal (bignat_of_pos a) two) then raise Non_closed_number; mult_2 (bignat_of_pos b) (* 1+(1+1)*b *) - | GApp (_,GRef (_,p1), [GRef (_,o); GApp (_,GRef (_,p2),[a;b])]) + | GApp (_,GRef (_,p1,_), [GRef (_,o,_); GApp (_,GRef (_,p2,_),[a;b])]) when Globnames.eq_gr p1 glob_Rplus && Globnames.eq_gr p2 glob_Rmult && Globnames.eq_gr o glob_R1 -> if not (Bigint.equal (bignat_of_pos a) two) then raise Non_closed_number; add_1 (mult_2 (bignat_of_pos b)) | _ -> raise Non_closed_number in let bignat_of_r = function - | GRef (_,a) when Globnames.eq_gr a glob_R0 -> zero - | GRef (_,a) when Globnames.eq_gr a glob_R1 -> one + | GRef (_,a,_) when Globnames.eq_gr a glob_R0 -> zero + | GRef (_,a,_) when Globnames.eq_gr a glob_R1 -> one | r -> bignat_of_pos r in bignat_of_r let bigint_of_r = function - | GApp (_,GRef (_,o), [a]) when Globnames.eq_gr o glob_Ropp -> + | GApp (_,GRef (_,o,_), [a]) when Globnames.eq_gr o glob_Ropp -> let n = bignat_of_r a in if Bigint.equal n zero then raise Non_closed_number; neg n @@ -109,11 +109,12 @@ let uninterp_r p = with Non_closed_number -> None +let mkGRef gr = GRef (Loc.ghost,gr,None) + let _ = Notation.declare_numeral_interpreter "R_scope" (r_path,["Coq";"Reals";"Rdefinitions"]) r_of_int - ([GRef(Loc.ghost,glob_Ropp);GRef(Loc.ghost,glob_R0); - GRef(Loc.ghost,glob_Rplus);GRef(Loc.ghost,glob_Rmult); - GRef(Loc.ghost,glob_R1)], + (List.map mkGRef + [glob_Ropp;glob_R0;glob_Rplus;glob_Rmult;glob_R1], uninterp_r, false) diff --git a/plugins/syntax/string_syntax.ml b/plugins/syntax/string_syntax.ml index 54206b453..2e696f391 100644 --- a/plugins/syntax/string_syntax.ml +++ b/plugins/syntax/string_syntax.ml @@ -32,8 +32,8 @@ open Lazy let interp_string dloc s = let le = String.length s in let rec aux n = - if n = le then GRef (dloc, force glob_EmptyString) else - GApp (dloc,GRef (dloc, force glob_String), + if n = le then GRef (dloc, force glob_EmptyString, None) else + GApp (dloc,GRef (dloc, force glob_String, None), [interp_ascii dloc (int_of_char s.[n]); aux (n+1)]) in aux 0 @@ -41,11 +41,11 @@ let uninterp_string r = try let b = Buffer.create 16 in let rec aux = function - | GApp (_,GRef (_,k),[a;s]) when eq_gr k (force glob_String) -> + | GApp (_,GRef (_,k,_),[a;s]) when eq_gr k (force glob_String) -> (match uninterp_ascii a with | Some c -> Buffer.add_char b (Char.chr c); aux s | _ -> raise Non_closed_string) - | GRef (_,z) when eq_gr z (force glob_EmptyString) -> + | GRef (_,z,_) when eq_gr z (force glob_EmptyString) -> Some (Buffer.contents b) | _ -> raise Non_closed_string @@ -57,6 +57,6 @@ let _ = Notation.declare_string_interpreter "string_scope" (string_path,["Coq";"Strings";"String"]) interp_string - ([GRef (Loc.ghost,static_glob_String); - GRef (Loc.ghost,static_glob_EmptyString)], + ([GRef (Loc.ghost,static_glob_String,None); + GRef (Loc.ghost,static_glob_EmptyString,None)], uninterp_string, true) diff --git a/plugins/syntax/z_syntax.ml b/plugins/syntax/z_syntax.ml index 67e54c017..5131a5f38 100644 --- a/plugins/syntax/z_syntax.ml +++ b/plugins/syntax/z_syntax.ml @@ -41,9 +41,9 @@ let glob_xO = ConstructRef path_of_xO let glob_xH = ConstructRef path_of_xH let pos_of_bignat dloc x = - let ref_xI = GRef (dloc, glob_xI) in - let ref_xH = GRef (dloc, glob_xH) in - let ref_xO = GRef (dloc, glob_xO) in + let ref_xI = GRef (dloc, glob_xI, None) in + let ref_xH = GRef (dloc, glob_xH, None) in + let ref_xO = GRef (dloc, glob_xO, None) in let rec pos_of x = match div2_with_rest x with | (q,false) -> GApp (dloc, ref_xO,[pos_of q]) @@ -65,9 +65,9 @@ let interp_positive dloc n = (**********************************************************************) let rec bignat_of_pos = function - | GApp (_, GRef (_,b),[a]) when Globnames.eq_gr b glob_xO -> mult_2(bignat_of_pos a) - | GApp (_, GRef (_,b),[a]) when Globnames.eq_gr b glob_xI -> add_1(mult_2(bignat_of_pos a)) - | GRef (_, a) when Globnames.eq_gr a glob_xH -> Bigint.one + | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_xO -> mult_2(bignat_of_pos a) + | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_xI -> add_1(mult_2(bignat_of_pos a)) + | GRef (_, a, _) when Globnames.eq_gr a glob_xH -> Bigint.one | _ -> raise Non_closed_number let uninterp_positive p = @@ -83,9 +83,9 @@ let uninterp_positive p = let _ = Notation.declare_numeral_interpreter "positive_scope" (positive_path,binnums) interp_positive - ([GRef (Loc.ghost, glob_xI); - GRef (Loc.ghost, glob_xO); - GRef (Loc.ghost, glob_xH)], + ([GRef (Loc.ghost, glob_xI, None); + GRef (Loc.ghost, glob_xO, None); + GRef (Loc.ghost, glob_xH, None)], uninterp_positive, true) @@ -104,9 +104,9 @@ let n_path = make_path binnums "N" let n_of_binnat dloc pos_or_neg n = if not (Bigint.equal n zero) then - GApp(dloc, GRef (dloc,glob_Npos), [pos_of_bignat dloc n]) + GApp(dloc, GRef (dloc,glob_Npos,None), [pos_of_bignat dloc n]) else - GRef (dloc, glob_N0) + GRef (dloc, glob_N0, None) let error_negative dloc = user_err_loc (dloc, "interp_N", str "No negative numbers in type \"N\".") @@ -120,8 +120,8 @@ let n_of_int dloc n = (**********************************************************************) let bignat_of_n = function - | GApp (_, GRef (_,b),[a]) when Globnames.eq_gr b glob_Npos -> bignat_of_pos a - | GRef (_, a) when Globnames.eq_gr a glob_N0 -> Bigint.zero + | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_Npos -> bignat_of_pos a + | GRef (_, a,_) when Globnames.eq_gr a glob_N0 -> Bigint.zero | _ -> raise Non_closed_number let uninterp_n p = @@ -134,8 +134,8 @@ let uninterp_n p = let _ = Notation.declare_numeral_interpreter "N_scope" (n_path,binnums) n_of_int - ([GRef (Loc.ghost, glob_N0); - GRef (Loc.ghost, glob_Npos)], + ([GRef (Loc.ghost, glob_N0, None); + GRef (Loc.ghost, glob_Npos, None)], uninterp_n, true) @@ -157,18 +157,18 @@ let z_of_int dloc n = if not (Bigint.equal n zero) then let sgn, n = if is_pos_or_zero n then glob_POS, n else glob_NEG, Bigint.neg n in - GApp(dloc, GRef (dloc,sgn), [pos_of_bignat dloc n]) + GApp(dloc, GRef (dloc,sgn,None), [pos_of_bignat dloc n]) else - GRef (dloc, glob_ZERO) + GRef (dloc, glob_ZERO, None) (**********************************************************************) (* Printing Z via scopes *) (**********************************************************************) let bigint_of_z = function - | GApp (_, GRef (_,b),[a]) when Globnames.eq_gr b glob_POS -> bignat_of_pos a - | GApp (_, GRef (_,b),[a]) when Globnames.eq_gr b glob_NEG -> Bigint.neg (bignat_of_pos a) - | GRef (_, a) when Globnames.eq_gr a glob_ZERO -> Bigint.zero + | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_POS -> bignat_of_pos a + | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_NEG -> Bigint.neg (bignat_of_pos a) + | GRef (_, a, _) when Globnames.eq_gr a glob_ZERO -> Bigint.zero | _ -> raise Non_closed_number let uninterp_z p = @@ -182,8 +182,8 @@ let uninterp_z p = let _ = Notation.declare_numeral_interpreter "Z_scope" (z_path,binnums) z_of_int - ([GRef (Loc.ghost, glob_ZERO); - GRef (Loc.ghost, glob_POS); - GRef (Loc.ghost, glob_NEG)], + ([GRef (Loc.ghost, glob_ZERO, None, None); + GRef (Loc.ghost, glob_POS, None, None); + GRef (Loc.ghost, glob_NEG, None, None)], uninterp_z, true) diff --git a/plugins/xml/cic2acic.ml b/plugins/xml/cic2acic.ml index bf46065d0..bbaef1e70 100644 --- a/plugins/xml/cic2acic.ml +++ b/plugins/xml/cic2acic.ml @@ -190,6 +190,7 @@ module CPropRetyping = let typeur sigma metamap = let rec type_of env cstr= match Term.kind_of_term cstr with + | T.Proj _ -> assert false | T.Meta n -> (try T.strip_outer_cast (Int.List.assoc n metamap) with Not_found -> Errors.anomaly ~label:"type_of" (Pp.str "this is not a well-typed term")) @@ -202,9 +203,7 @@ let typeur sigma metamap = ty with Not_found -> Errors.anomaly ~label:"type_of" (str "variable " ++ Id.print id ++ str " unbound")) - | T.Const c -> - let cb = Environ.lookup_constant c env in - Typeops.type_of_constant_type env (cb.Declarations.const_type) + | T.Const c -> Typeops.type_of_constant_in env c | T.Evar ev -> Evd.existential_type sigma ev | T.Ind ind -> Inductiveops.type_of_inductive env ind | T.Construct cstr -> Inductiveops.type_of_constructor env cstr @@ -355,7 +354,7 @@ Pp.msg_debug (Pp.(++) (Pp.str "BUG: this subterm was not visited during the doub {DoubleTypeInference.synthesized = Reductionops.nf_beta evar_map (CPropRetyping.get_type_of env evar_map - (Termops.refresh_universes tt)) ; + ((* Termops.refresh_universes *) tt)) ; DoubleTypeInference.expected = None} in let innersort = @@ -484,7 +483,8 @@ print_endline "PASSATO" ; flush stdout ; (* Now that we have all the auxiliary functions we *) (* can finally proceed with the main case analysis. *) match Term.kind_of_term tt with - Term.Rel n -> + | Term.Proj _ -> assert false + | Term.Rel n -> let id = match List.nth (Environ.rel_context env) (n - 1) with (Names.Name id,_,_) -> id @@ -670,7 +670,7 @@ print_endline "PASSATO" ; flush stdout ; explicit_substitute_and_eta_expand_if_required h (Array.to_list t) t' compute_result_if_eta_expansion_not_required - | Term.Const kn -> + | Term.Const (kn,u) -> Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ; if is_a_Prop innersort && expected_available then add_inner_type fresh_id'' ; @@ -681,7 +681,7 @@ print_endline "PASSATO" ; flush stdout ; explicit_substitute_and_eta_expand_if_required tt [] (List.map snd subst') compute_result_if_eta_expansion_not_required - | Term.Ind (kn,i) -> + | Term.Ind ((kn,i),u) -> let compute_result_if_eta_expansion_not_required _ _ = Acic.AInd (fresh_id'', subst, (uri_of_kernel_name (Inductive kn)), i) in @@ -689,7 +689,7 @@ print_endline "PASSATO" ; flush stdout ; explicit_substitute_and_eta_expand_if_required tt [] (List.map snd subst') compute_result_if_eta_expansion_not_required - | Term.Construct ((kn,i),j) -> + | Term.Construct (((kn,i),j),u) -> Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ; if is_a_Prop innersort && expected_available then add_inner_type fresh_id'' ; diff --git a/plugins/xml/doubleTypeInference.ml b/plugins/xml/doubleTypeInference.ml index d54308165..c8717e008 100644 --- a/plugins/xml/doubleTypeInference.ml +++ b/plugins/xml/doubleTypeInference.ml @@ -64,7 +64,7 @@ let double_type_of env sigma cstr expectedty subterms_to_types = T.Meta n -> Errors.error "DoubleTypeInference.double_type_of: found a non-instanciated goal" - + | T.Proj _ -> assert false | T.Evar ((n,l) as ev) -> let ty = Unshare.unshare (Evd.existential_type sigma ev) in let jty = execute env sigma ty None in @@ -99,7 +99,7 @@ let double_type_of env sigma cstr expectedty subterms_to_types = Typeops.judge_of_variable env id | T.Const c -> - E.make_judge cstr (Typeops.type_of_constant env c) + E.make_judge cstr (fst (Typeops.type_of_constant env c)) | T.Ind ind -> E.make_judge cstr (Inductiveops.type_of_inductive env ind) @@ -112,15 +112,14 @@ let double_type_of env sigma cstr expectedty subterms_to_types = Reduction.whd_betadeltaiota env (Retyping.get_type_of env sigma c) in let cj = execute env sigma c (Some expectedtype) in let pj = execute env sigma p None in - let (expectedtypes,_,_) = + let (expectedtypes,_) = let indspec = Inductive.find_rectype env cj.Environ.uj_type in Inductive.type_case_branches env indspec pj cj.Environ.uj_val in let lfj = execute_array env sigma lf (Array.map (function x -> Some x) expectedtypes) in - let (j,_) = Typeops.judge_of_case env ci pj cj lfj in - j + Typeops.judge_of_case env ci pj cj lfj | T.Fix ((vn,i as vni),recdef) -> let (_,tys,_ as recdef') = execute_recdef env sigma recdef in @@ -141,10 +140,10 @@ let double_type_of env sigma cstr expectedty subterms_to_types = (*CSC: again once Judicael will introduce his non-bugged algebraic *) (*CSC: universes. *) (try - Typeops.judge_of_type u + (*FIXME*) (Typeops.judge_of_type u) with _ -> (* Successor of a non universe-variable universe anomaly *) Pp.msg_warning (Pp.str "Universe refresh performed!!!"); - Typeops.judge_of_type (Termops.new_univ ()) + (*FIXME*) (Typeops.judge_of_type (Universes.new_univ Names.empty_dirpath)) ) | T.App (f,args) -> @@ -165,7 +164,7 @@ let double_type_of env sigma cstr expectedty subterms_to_types = Array.of_list (aux j.Environ.uj_type (Array.to_list args)) in let jl = execute_array env sigma args expected_args in - let (j,_) = Typeops.judge_of_apply env j jl in + let j = Typeops.judge_of_apply env j jl in j | T.Lambda (name,c1,c2) -> @@ -212,7 +211,7 @@ let double_type_of env sigma cstr expectedty subterms_to_types = let cj = execute env sigma c (Some (Reductionops.nf_beta sigma t)) in let tj = execute env sigma t None in let tj = type_judgment env sigma tj in - let j, _ = Typeops.judge_of_cast env cj k tj in + let j = Typeops.judge_of_cast env cj k tj in j in let synthesized = E.j_type judgement in diff --git a/plugins/xml/xmlcommand.ml b/plugins/xml/xmlcommand.ml index 5f26e2bac..3d655920b 100644 --- a/plugins/xml/xmlcommand.ml +++ b/plugins/xml/xmlcommand.ml @@ -175,16 +175,17 @@ let find_hyps t = | Term.Meta _ | Term.Evar _ | Term.Sort _ -> l + | Term.Proj _ -> ignore(Errors.todo "Proj in find_hyps"); assert false | Term.Cast (te,_, ty) -> aux (aux l te) ty | Term.Prod (_,s,t) -> aux (aux l s) t | Term.Lambda (_,s,t) -> aux (aux l s) t | Term.LetIn (_,s,_,t) -> aux (aux l s) t | Term.App (he,tl) -> Array.fold_left (fun i x -> aux i x) (aux l he) tl - | Term.Const con -> + | Term.Const (con, _) -> let hyps = (Global.lookup_constant con).Declarations.const_hyps in map_and_filter l hyps @ l - | Term.Ind ind - | Term.Construct (ind,_) -> + | Term.Ind (ind,_) + | Term.Construct ((ind,_),_) -> let hyps = (fst (Global.lookup_inductive ind)).Declarations.mind_hyps in map_and_filter l hyps @ l | Term.Case (_,t1,t2,b) -> @@ -243,8 +244,8 @@ let mk_inductive_obj sp mib packs variables nparams hyps finite = let {Declarations.mind_consnames=consnames ; Declarations.mind_typename=typename } = p in - let arity = Inductive.type_of_inductive (Global.env()) (mib,p) in - let lc = Inductiveops.arities_of_constructors (Global.env ()) (sp,!tyno) in + let arity = Inductive.type_of_inductive (Global.env()) ((mib,p),Univ.Instance.empty)(*FIXME*) in + let lc = Inductiveops.arities_of_constructors (Global.env ()) ((sp,!tyno),Univ.Instance.empty)(*FIXME*) in let cons = (Array.fold_right (fun (name,lc) i -> (name,lc)::i) (Array.mapi @@ -379,7 +380,7 @@ let print internal glob_ref kind xml_library_root = let val0 = Declareops.body_of_constant cb in let typ = cb.Declarations.const_type in let hyps = cb.Declarations.const_hyps in - let typ = Typeops.type_of_constant_type (Global.env()) typ in + let typ = (* Typeops.type_of_constant_type (Global.env()) *) typ in Cic2acic.Constant kn,mk_constant_obj id val0 typ variables hyps | Globnames.IndRef (kn,_) -> let mib = Global.lookup_mind kn in diff --git a/pretyping/arguments_renaming.ml b/pretyping/arguments_renaming.ml index 4562c5aa5..be22030ce 100644 --- a/pretyping/arguments_renaming.ml +++ b/pretyping/arguments_renaming.ml @@ -41,12 +41,12 @@ let section_segment_of_reference = function | ConstRef con -> Lib.section_segment_of_constant con | IndRef (kn,_) | ConstructRef ((kn,_),_) -> Lib.section_segment_of_mutual_inductive kn - | _ -> [] + | _ -> [], Univ.UContext.empty let discharge_rename_args = function | _, (ReqGlobal (c, names), _ as req) -> (try - let vars = section_segment_of_reference c in + let vars,_ = section_segment_of_reference c in let c' = pop_global_reference c in let var_names = List.map (fun (id, _,_,_) -> Name id) vars in let names' = List.map (fun l -> var_names @ l) names in @@ -87,22 +87,24 @@ let rename_type ty ref = with Not_found -> ty let rename_type_of_constant env c = - let ty = Typeops.type_of_constant env c in - rename_type ty (ConstRef c) + let ty = Typeops.type_of_constant_in env c in + rename_type ty (ConstRef (fst c)) let rename_type_of_inductive env ind = let ty = Inductiveops.type_of_inductive env ind in - rename_type ty (IndRef ind) + rename_type ty (IndRef (fst ind)) let rename_type_of_constructor env cstruct = let ty = Inductiveops.type_of_constructor env cstruct in - rename_type ty (ConstructRef cstruct) + rename_type ty (ConstructRef (fst cstruct)) let rename_typing env c = - let j = Typeops.typing env c in - match kind_of_term c with - | Const c -> { j with uj_type = rename_type j.uj_type (ConstRef c) } - | Ind i -> { j with uj_type = rename_type j.uj_type (IndRef i) } - | Construct k -> { j with uj_type = rename_type j.uj_type (ConstructRef k) } - | _ -> j + let j = Typeops.infer env c in + let j' = + match kind_of_term c with + | Const (c,u) -> { j with uj_type = rename_type j.uj_type (ConstRef c) } + | Ind (i,u) -> { j with uj_type = rename_type j.uj_type (IndRef i) } + | Construct (k,u) -> { j with uj_type = rename_type j.uj_type (ConstructRef k) } + | _ -> j + in j' diff --git a/pretyping/arguments_renaming.mli b/pretyping/arguments_renaming.mli index 09b8859e6..6c37f8938 100644 --- a/pretyping/arguments_renaming.mli +++ b/pretyping/arguments_renaming.mli @@ -16,7 +16,7 @@ val rename_arguments : bool -> global_reference -> Name.t list list -> unit (** [Not_found] is raised is no names are defined for [r] *) val arguments_names : global_reference -> Name.t list list -val rename_type_of_constant : env -> constant -> types -val rename_type_of_inductive : env -> inductive -> types -val rename_type_of_constructor : env -> constructor -> types +val rename_type_of_constant : env -> pconstant -> types +val rename_type_of_inductive : env -> pinductive -> types +val rename_type_of_constructor : env -> pconstructor -> types val rename_typing : env -> constr -> unsafe_judgment diff --git a/pretyping/cases.ml b/pretyping/cases.ml index d71499eda..1db3fac52 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -264,7 +264,8 @@ let rec find_row_ind = function | PatCstr(loc,c,_,_) :: _ -> Some (loc,c) let inductive_template evdref env tmloc ind = - let arsign = get_full_arity_sign env ind in + let indu = evd_comb1 (Evd.fresh_inductive_instance env) evdref ind in + let arsign = get_full_arity_sign env indu in let hole_source = match tmloc with | Some loc -> fun i -> (loc, Evar_kinds.TomatchTypeParameter (ind,i)) | None -> fun _ -> (Loc.ghost, Evar_kinds.InternalHole) in @@ -279,7 +280,7 @@ let inductive_template evdref env tmloc ind = | Some b -> (substl subst b::subst,evarl,n+1)) arsign ([],[],1) in - applist (mkInd ind,List.rev evarl) + applist (mkIndU indu,List.rev evarl) let try_find_ind env sigma typ realnames = let (IndType(_,realargs) as ind) = find_rectype env sigma typ in @@ -349,7 +350,7 @@ let coerce_to_indtype typing_fun evdref env matx tomatchl = (* Utils *) let mkExistential env ?(src=(Loc.ghost,Evar_kinds.InternalHole)) evdref = - e_new_evar evdref env ~src:src (new_Type ()) + let e, u = e_new_type_evar evdref univ_flexible_alg env ~src:src in e let evd_comb2 f evdref x y = let (evd',y) = f !evdref x y in @@ -928,13 +929,19 @@ let expand_arg tms (p,ccl) ((_,t),_,na) = let k = length_of_tomatch_type_sign na t in (p+k,liftn_predicate (k-1) (p+1) ccl tms) + +let use_unit_judge evd = + let j, ctx = coq_unit_judge () in + let evd' = Evd.merge_context_set Evd.univ_flexible_alg evd ctx in + evd', j + let adjust_impossible_cases pb pred tomatch submat = match submat with | [] -> begin match kind_of_term (whd_evar !(pb.evdref) pred) with | Evar (evk,_) when snd (evar_source evk !(pb.evdref)) == Evar_kinds.ImpossibleCase -> - let default = (coq_unit_judge ()).uj_type in - pb.evdref := Evd.define evk default !(pb.evdref); + let evd, default = use_unit_judge !(pb.evdref) in + pb.evdref := Evd.define evk default.uj_type evd; (* we add an "assert false" case *) let pats = List.map (fun _ -> PatVar (Loc.ghost,Anonymous)) tomatch in let aliasnames = @@ -1159,7 +1166,7 @@ let build_leaf pb = let build_branch initial current realargs deps (realnames,curname) pb arsign eqns const_info = (* We remember that we descend through constructor C *) let history = - push_history_pattern const_info.cs_nargs const_info.cs_cstr pb.history in + push_history_pattern const_info.cs_nargs (fst const_info.cs_cstr) pb.history in (* We prepare the matching on x1:T1 .. xn:Tn using some heuristic to *) (* build the name x1..xn from the names present in the equations *) @@ -1236,7 +1243,7 @@ let build_branch initial current realargs deps (realnames,curname) pb arsign eqn let cur_alias = lift const_info.cs_nargs current in let ind = appvect ( - applist (mkInd (inductive_of_constructor const_info.cs_cstr), + applist (mkIndU (inductive_of_constructor (fst const_info.cs_cstr), snd const_info.cs_cstr), List.map (lift const_info.cs_nargs) const_info.cs_params), const_info.cs_concl_realargs) in Alias (initial,(aliasname,cur_alias,(ci,ind))) in @@ -1293,7 +1300,7 @@ and match_current pb (initial,tomatch) = let mind,_ = dest_ind_family indf in let cstrs = get_constructors pb.env indf in let arsign, _ = get_arity pb.env indf in - let eqns,onlydflt = group_equations pb mind current cstrs pb.mat in + let eqns,onlydflt = group_equations pb (fst mind) current cstrs pb.mat in let no_cstr = Int.equal (Array.length cstrs) 0 in if (not no_cstr || not (List.is_empty pb.mat)) && onlydflt then compile_all_variables initial tomatch pb @@ -1313,7 +1320,7 @@ and match_current pb (initial,tomatch) = let (pred,typ) = find_predicate pb.caseloc pb.env pb.evdref pred current indt (names,dep) tomatch in - let ci = make_case_info pb.env mind pb.casestyle in + let ci = make_case_info pb.env (fst mind) pb.casestyle in let pred = nf_betaiota !(pb.evdref) pred in let case = mkCase (ci,pred,current,brvals) in Typing.check_allowed_sort pb.env !(pb.evdref) mind current pred; @@ -1594,10 +1601,9 @@ let build_tycon loc env tycon_env subst tycon extenv evdref t = we are in an impossible branch *) let n = rel_context_length (rel_context env) in let n' = rel_context_length (rel_context tycon_env) in - let tt = new_Type () in - let impossible_case_type = - e_new_evar evdref env ~src:(loc,Evar_kinds.ImpossibleCase) tt in - (lift (n'-n) impossible_case_type, tt) + let impossible_case_type, u = + e_new_type_evar evdref univ_flexible_alg env ~src:(loc,Evar_kinds.ImpossibleCase) in + (lift (n'-n) impossible_case_type, mkSort u) | Some t -> let t = abstract_tycon loc tycon_env evdref subst tycon extenv t in let evd,tt = Typing.e_type_of extenv !evdref t in @@ -1621,9 +1627,9 @@ let build_inversion_problem loc env sigma tms t = PatVar (Loc.ghost,Name id), ((id,t)::subst, id::avoid) in let rec reveal_pattern t (subst,avoid as acc) = match kind_of_term (whd_betadeltaiota env sigma t) with - | Construct cstr -> PatCstr (Loc.ghost,cstr,[],Anonymous), acc + | Construct (cstr,u) -> PatCstr (Loc.ghost,cstr,[],Anonymous), acc | App (f,v) when isConstruct f -> - let cstr = destConstruct f in + let cstr,u = destConstruct f in let n = constructor_nrealargs env cstr in let l = List.lastn n (Array.to_list v) in let l,acc = List.fold_map' reveal_pattern l acc in @@ -1707,11 +1713,18 @@ let build_inversion_problem loc env sigma tms t = it = None } } in (* [pb] is the auxiliary pattern-matching serving as skeleton for the return type of the original problem Xi *) + (* let sigma, s = Evd.new_sort_variable sigma in *) +(*FIXME TRY *) + (* let sigma, s = Evd.new_sort_variable univ_flexible sigma in *) + let s' = Retyping.get_sort_of env sigma t in + let sigma, s = Evd.new_sort_variable univ_flexible_alg sigma in + let sigma = Evd.set_leq_sort sigma s' s in let evdref = ref sigma in + (* let ty = evd_comb1 (refresh_universes false) evdref ty in *) let pb = { env = pb_env; evdref = evdref; - pred = new_Type(); + pred = (*ty *) mkSort s; tomatch = sub_tms; history = start_history n; mat = [eqn1;eqn2]; @@ -1744,7 +1757,7 @@ let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign = str"Unexpected type annotation for a term of non inductive type.")) | IsInd (term,IndType(indf,realargs),_) -> let indf' = if dolift then lift_inductive_family n indf else indf in - let (ind,_) = dest_ind_family indf' in + let ((ind,u),_) = dest_ind_family indf' in let nparams_ctxt,nrealargs_ctxt = inductive_nargs_env env0 ind in let arsign = fst (get_arity env0 indf') in let realnal = @@ -1848,7 +1861,11 @@ let prepare_predicate loc typing_fun sigma env tomatchs arsign tycon pred = (* we use two strategies *) let sigma,t = match tycon with | Some t -> sigma,t - | None -> new_type_evar sigma env ~src:(loc, Evar_kinds.CasesType) in + | None -> + let sigma, (t, _) = + new_type_evar univ_flexible_alg sigma env ~src:(loc, Evar_kinds.CasesType) in + sigma, t + in (* First strategy: we build an "inversion" predicate *) let sigma1,pred1 = build_inversion_problem loc env sigma tomatchs t in (* Second strategy: we directly use the evar as a non dependent pred *) @@ -1858,7 +1875,7 @@ let prepare_predicate loc typing_fun sigma env tomatchs arsign tycon pred = | Some rtntyp, _ -> (* We extract the signature of the arity *) let envar = List.fold_right push_rel_context arsign env in - let sigma, newt = new_sort_variable sigma in + let sigma, newt = new_sort_variable univ_flexible_alg sigma in let evdref = ref sigma in let predcclj = typing_fun (mk_tycon (mkSort newt)) envar evdref rtntyp in let sigma = !evdref in @@ -1933,7 +1950,7 @@ let constr_of_pat env evdref arsign pat avoid = with Not_found -> error_case_not_inductive env {uj_val = ty; uj_type = Typing.type_of env !evdref ty} in - let ind, params = dest_ind_family indf in + let (ind,u), params = dest_ind_family indf in if not (eq_ind ind cind) then error_bad_constructor_loc l cstr ind; let cstrs = get_constructors env indf in let ci = cstrs.(i-1) in @@ -1954,7 +1971,7 @@ let constr_of_pat env evdref arsign pat avoid = let args = List.rev args in let patargs = List.rev patargs in let pat' = PatCstr (l, cstr, patargs, alias) in - let cstr = mkConstruct ci.cs_cstr in + let cstr = mkConstructU ci.cs_cstr in let app = applistc cstr (List.map (lift (List.length sign)) params) in let app = applistc app args in let apptype = Retyping.get_type_of env ( !evdref) app in @@ -2010,7 +2027,7 @@ let vars_of_ctx ctx = | Some t' when is_topvar t' -> prev, (GApp (Loc.ghost, - (GRef (Loc.ghost, delayed_force coq_eq_refl_ref)), + (GRef (Loc.ghost, delayed_force coq_eq_refl_ref, None)), [hole; GVar (Loc.ghost, prev)])) :: vars | _ -> match na with @@ -2282,7 +2299,7 @@ let compile_program_cases loc style (typing_function, evdref) tycon env (predopt, tomatchl, eqns) = let typing_fun tycon env = function | Some t -> typing_function tycon env evdref t - | None -> coq_unit_judge () in + | None -> Evarutil.evd_comb0 use_unit_judge evdref in (* We build the matrix of patterns and right-hand side *) let matx = matx_of_eqns env eqns in @@ -2361,7 +2378,7 @@ let compile_program_cases loc style (typing_function, evdref) tycon env let typing_function tycon env evdref = function | Some t -> typing_function tycon env evdref t - | None -> coq_unit_judge () in + | None -> evd_comb0 use_unit_judge evdref in let pb = { env = env; @@ -2435,7 +2452,7 @@ let compile_cases loc style (typing_fun, evdref) tycon env (predopt, tomatchl, e (* A typing function that provides with a canonical term for absurd cases*) let typing_fun tycon env evdref = function | Some t -> typing_fun tycon env evdref t - | None -> coq_unit_judge () in + | None -> evd_comb0 use_unit_judge evdref in let myevdref = ref sigma in diff --git a/pretyping/cbv.ml b/pretyping/cbv.ml index 1334fb285..4c1e3c3af 100644 --- a/pretyping/cbv.ml +++ b/pretyping/cbv.ml @@ -45,7 +45,7 @@ type cbv_value = | LAM of int * (Name.t * constr) list * constr * cbv_value subs | FIXP of fixpoint * cbv_value subs * cbv_value array | COFIXP of cofixpoint * cbv_value subs * cbv_value array - | CONSTR of constructor * cbv_value array + | CONSTR of constructor puniverses * cbv_value array (* type of terms with a hole. This hole can appear only under App or Case. * TOP means the term is considered without context @@ -67,6 +67,7 @@ and cbv_stack = | TOP | APP of cbv_value array * cbv_stack | CASE of constr * constr array * case_info * cbv_value subs * cbv_stack + | PROJ of projection * Declarations.projection_body * cbv_stack (* les vars pourraient etre des constr, cela permet de retarder les lift: utile ?? *) @@ -107,7 +108,7 @@ let contract_cofixp env (i,(_,_,bds as bodies)) = let make_constr_ref n = function | RelKey p -> mkRel (n+p) | VarKey id -> mkVar id - | ConstKey cst -> mkConst cst + | ConstKey cst -> mkConstU cst (* Adds an application list. Collapse APPs! *) let stack_app appl stack = @@ -121,6 +122,7 @@ let rec stack_concat stk1 stk2 = TOP -> stk2 | APP(v,stk1') -> APP(v,stack_concat stk1' stk2) | CASE(c,b,i,s,stk1') -> CASE(c,b,i,s,stack_concat stk1' stk2) + | PROJ (p,pinfo,stk1') -> PROJ (p,pinfo,stack_concat stk1' stk2) (* merge stacks when there is no shifts in between *) let mkSTACK = function @@ -136,7 +138,7 @@ open RedFlags let red_set_ref flags = function | RelKey _ -> red_set flags fDELTA | VarKey id -> red_set flags (fVAR id) - | ConstKey sp -> red_set flags (fCONST sp) + | ConstKey (sp,_) -> red_set flags (fCONST sp) (* Transfer application lists from a value to the stack * useful because fixpoints may be totally applied in several times. @@ -193,6 +195,10 @@ let rec norm_head info env t stack = norm_head info env head (stack_app nargs stack) | Case (ci,p,c,v) -> norm_head info env c (CASE(p,v,ci,env,stack)) | Cast (ct,_,_) -> norm_head info env ct stack + + | Proj (p, c) -> + let pinfo = Option.get ((Environ.lookup_constant p (info_env info)).Declarations.const_proj) in + norm_head info env c (PROJ (p, pinfo, stack)) (* constants, axioms * the first pattern is CRUCIAL, n=0 happens very often: @@ -221,7 +227,7 @@ let rec norm_head info env t stack = (CBN(t,env), stack) (* Considrer une coupure commutative ? *) | Evar ev -> - (match evar_value info ev with + (match evar_value info.i_cache ev with Some c -> norm_head info env c stack | None -> (VAL(0, t), stack)) @@ -279,14 +285,14 @@ and cbv_stack_term info stack env t = cbv_stack_term info stk envf redfix (* constructor in a Case -> IOTA *) - | (CONSTR((sp,n),[||]), APP(args,CASE(_,br,ci,env,stk))) + | (CONSTR(((sp,n),u),[||]), APP(args,CASE(_,br,ci,env,stk))) when red_set (info_flags info) fIOTA -> let cargs = Array.sub args ci.ci_npar (Array.length args - ci.ci_npar) in cbv_stack_term info (stack_app cargs stk) env br.(n-1) (* constructor of arity 0 in a Case -> IOTA *) - | (CONSTR((_,n),[||]), CASE(_,br,_,env,stk)) + | (CONSTR(((_,n),u),[||]), CASE(_,br,_,env,stk)) when red_set (info_flags info) fIOTA -> cbv_stack_term info stk env br.(n-1) @@ -312,6 +318,8 @@ let rec apply_stack info t = function (mkCase (ci, cbv_norm_term info env ty, t, Array.map (cbv_norm_term info env) br)) st + | PROJ (p, pinfo, st) -> + apply_stack info (mkProj (p, t)) st (* performs the reduction on a constr, and returns a constr *) and cbv_norm_term info env t = @@ -348,7 +356,7 @@ and cbv_norm_value info = function (* reduction under binders *) (subs_liftn (Array.length lty) env)) bds)), Array.map (cbv_norm_value info) args) | CONSTR (c,args) -> - mkApp(mkConstruct c, Array.map (cbv_norm_value info) args) + mkApp(mkConstructU c, Array.map (cbv_norm_value info) args) (* with profiling *) let cbv_norm infos constr = diff --git a/pretyping/cbv.mli b/pretyping/cbv.mli index 66aef4d14..adb2ed15d 100644 --- a/pretyping/cbv.mli +++ b/pretyping/cbv.mli @@ -30,12 +30,13 @@ type cbv_value = | LAM of int * (Name.t * constr) list * constr * cbv_value subs | FIXP of fixpoint * cbv_value subs * cbv_value array | COFIXP of cofixpoint * cbv_value subs * cbv_value array - | CONSTR of constructor * cbv_value array + | CONSTR of constructor puniverses * cbv_value array and cbv_stack = | TOP | APP of cbv_value array * cbv_stack | CASE of constr * constr array * case_info * cbv_value subs * cbv_stack + | PROJ of projection * Declarations.projection_body * cbv_stack val shift_value : int -> cbv_value -> cbv_value diff --git a/pretyping/classops.ml b/pretyping/classops.ml index 886e00e83..86b789f7d 100644 --- a/pretyping/classops.ml +++ b/pretyping/classops.ml @@ -44,7 +44,9 @@ type coe_info_typ = { coe_value : constr; coe_type : types; coe_local : bool; + coe_context : Univ.universe_context_set; coe_is_identity : bool; + coe_is_projection : bool; coe_param : int } let coe_info_typ_equal c1 c2 = @@ -52,6 +54,7 @@ let coe_info_typ_equal c1 c2 = eq_constr c1.coe_type c2.coe_type && c1.coe_local == c2.coe_local && c1.coe_is_identity == c2.coe_is_identity && + c1.coe_is_projection == c2.coe_is_projection && Int.equal c1.coe_param c2.coe_param let cl_typ_ord t1 t2 = match t1, t2 with @@ -184,16 +187,16 @@ let coercion_info coe = CoeTypMap.find coe !coercion_tab let coercion_exists coe = CoeTypMap.mem coe !coercion_tab -(* find_class_type : evar_map -> constr -> cl_typ * constr list *) +(* find_class_type : evar_map -> constr -> cl_typ * universe_list * constr list *) let find_class_type sigma t = let t', args = Reductionops.whd_betaiotazeta_stack sigma t in match kind_of_term t' with - | Var id -> CL_SECVAR id, args - | Const sp -> CL_CONST sp, args - | Ind ind_sp -> CL_IND ind_sp, args - | Prod (_,_,_) -> CL_FUN, [] - | Sort _ -> CL_SORT, [] + | Var id -> CL_SECVAR id, Univ.Instance.empty, args + | Const (sp,u) -> CL_CONST sp, u, args + | Ind (ind_sp,u) -> CL_IND ind_sp, u, args + | Prod (_,_,_) -> CL_FUN, Univ.Instance.empty, [] + | Sort _ -> CL_SORT, Univ.Instance.empty, [] | _ -> raise Not_found @@ -201,38 +204,37 @@ let subst_cl_typ subst ct = match ct with CL_SORT | CL_FUN | CL_SECVAR _ -> ct - | CL_CONST kn -> - let kn',t = subst_con subst kn in - if kn' == kn then ct else - fst (find_class_type Evd.empty t) - | CL_IND (kn,i) -> - let kn' = subst_ind subst kn in - if kn' == kn then ct else - CL_IND (kn',i) + | CL_CONST c -> + let c',t = subst_con_kn subst c in + if c' == c then ct else + pi1 (find_class_type Evd.empty t) + | CL_IND i -> + let i' = subst_ind subst i in + if i' == i then ct else CL_IND i' (*CSC: here we should change the datatype for coercions: it should be possible to declare any term as a coercion *) -let subst_coe_typ subst t = fst (subst_global subst t) +let subst_coe_typ subst t = subst_global_reference subst t (* class_of : Term.constr -> int *) let class_of env sigma t = - let (t, n1, i, args) = + let (t, n1, i, u, args) = try - let (cl,args) = find_class_type sigma t in + let (cl, u, args) = find_class_type sigma t in let (i, { cl_param = n1 } ) = class_info cl in - (t, n1, i, args) + (t, n1, i, u, args) with Not_found -> let t = Tacred.hnf_constr env sigma t in - let (cl, args) = find_class_type sigma t in + let (cl, u, args) = find_class_type sigma t in let (i, { cl_param = n1 } ) = class_info cl in - (t, n1, i, args) + (t, n1, i, u, args) in if Int.equal (List.length args) n1 then t, i else raise Not_found let inductive_class_of ind = fst (class_info (CL_IND ind)) -let class_args_of env sigma c = snd (find_class_type sigma c) +let class_args_of env sigma c = pi3 (find_class_type sigma c) let string_of_class = function | CL_FUN -> "Funclass" @@ -261,14 +263,14 @@ let lookup_path_to_sort_from_class s = let apply_on_class_of env sigma t cont = try - let (cl,args) = find_class_type sigma t in + let (cl,u,args) = find_class_type sigma t in let (i, { cl_param = n1 } ) = class_info cl in if not (Int.equal (List.length args) n1) then raise Not_found; t, cont i with Not_found -> (* Is it worth to be more incremental on the delta steps? *) let t = Tacred.hnf_constr env sigma t in - let (cl, args) = find_class_type sigma t in + let (cl, u, args) = find_class_type sigma t in let (i, { cl_param = n1 } ) = class_info cl in if not (Int.equal (List.length args) n1) then raise Not_found; t, cont i @@ -291,7 +293,7 @@ let get_coercion_constructor coe = Reductionops.whd_betadeltaiota_stack (Global.env()) Evd.empty coe.coe_value in match kind_of_term c with - | Construct cstr -> + | Construct (cstr,u) -> (cstr, Inductiveops.constructor_nrealargs (Global.env()) cstr -1) | _ -> raise Not_found @@ -303,8 +305,12 @@ let lookup_pattern_path_between (s,t) = (* coercion_value : coe_index -> unsafe_judgment * bool *) -let coercion_value { coe_value = c; coe_type = t; coe_is_identity = b } = - (make_judge c t, b) +let coercion_value { coe_value = c; coe_type = t; coe_context = ctx; + coe_is_identity = b; coe_is_projection = b' } = + let subst, ctx = Universes.fresh_universe_context_set_instance ctx in + let c' = Vars.subst_univs_level_constr subst c + and t' = Vars.subst_univs_level_constr subst t in + (make_judge c' t', b, b'), ctx (* pretty-print functions are now in Pretty *) (* rajouter une coercion dans le graphe *) @@ -323,9 +329,15 @@ let message_ambig l = (* add_coercion_in_graph : coe_index * cl_index * cl_index -> unit coercion,source,target *) -let different_class_params i j = - (snd (class_info_from_index i)).cl_param > 0 - +let different_class_params i = + let ci = class_info_from_index i in + if (snd ci).cl_param > 0 then true + else + match fst ci with + | CL_IND i -> Global.is_polymorphic (IndRef i) + | CL_CONST c -> Global.is_polymorphic (ConstRef c) + | _ -> false + let add_coercion_in_graph (ic,source,target) = let old_inheritance_graph = !inheritance_graph in let ambig_paths = @@ -333,12 +345,12 @@ let add_coercion_in_graph (ic,source,target) = let try_add_new_path (i,j as ij) p = try if Bijint.Index.equal i j then begin - if different_class_params i j then begin + if different_class_params i then begin let _ = lookup_path_between_class ij in ambig_paths := (ij,p)::!ambig_paths end end else begin - let _ = lookup_path_between_class (i,j) in + let _ = lookup_path_between_class ij in ambig_paths := (ij,p)::!ambig_paths end; false @@ -374,6 +386,7 @@ type coercion = { coercion_type : coe_typ; coercion_local : bool; coercion_is_id : bool; + coercion_is_proj : bool; coercion_source : cl_typ; coercion_target : cl_typ; coercion_params : int; @@ -382,7 +395,7 @@ type coercion = { (* Calcul de l'arit d'une classe *) let reference_arity_length ref = - let t = Global.type_of_global ref in + let t,_ = Universes.type_of_global ref in List.length (fst (Reductionops.splay_arity (Global.env()) Evd.empty t)) let class_params = function @@ -413,11 +426,15 @@ let cache_coercion (_, c) = let () = add_class c.coercion_target in let is, _ = class_info c.coercion_source in let it, _ = class_info c.coercion_target in + let value, ctx = Universes.fresh_global_instance (Global.env()) c.coercion_type in + let typ = Retyping.get_type_of (Global.env ()) Evd.empty value in let xf = - { coe_value = constr_of_global c.coercion_type; - coe_type = Global.type_of_global c.coercion_type; + { coe_value = value; + coe_type = typ; + coe_context = ctx; coe_local = c.coercion_local; coe_is_identity = c.coercion_is_id; + coe_is_projection = c.coercion_is_proj; coe_param = c.coercion_params } in let () = add_new_coercion c.coercion_type xf in add_coercion_in_graph (xf,is,it) @@ -441,7 +458,6 @@ let subst_coercion (subst, c) = if c.coercion_type == coe && c.coercion_source == cls && c.coercion_target == clt then c else { c with coercion_type = coe; coercion_source = cls; coercion_target = clt } - let discharge_cl = function | CL_CONST kn -> CL_CONST (Lib.discharge_con kn) | CL_IND ind -> CL_IND (Lib.discharge_inductive ind) @@ -453,7 +469,7 @@ let discharge_coercion (_, c) = let n = try let ins = Lib.section_instance c.coercion_type in - Array.length ins + Array.length (snd ins) with Not_found -> 0 in let nc = { c with @@ -477,10 +493,16 @@ let inCoercion : coercion -> obj = discharge_function = discharge_coercion } let declare_coercion coef ?(local = false) ~isid ~src:cls ~target:clt ~params:ps = + let isproj = + match coef with + | ConstRef c -> Environ.is_projection c (Global.env ()) + | _ -> false + in let c = { coercion_type = coef; coercion_local = local; coercion_is_id = isid; + coercion_is_proj = isproj; coercion_source = cls; coercion_target = clt; coercion_params = ps; diff --git a/pretyping/classops.mli b/pretyping/classops.mli index 7bde9e910..3251dc4eb 100644 --- a/pretyping/classops.mli +++ b/pretyping/classops.mli @@ -53,9 +53,9 @@ val class_info : cl_typ -> (cl_index * cl_info_typ) val class_info_from_index : cl_index -> cl_typ * cl_info_typ -(** [find_class_type env sigma c] returns the head reference of [c] and its - arguments *) -val find_class_type : evar_map -> types -> cl_typ * constr list +(** [find_class_type env sigma c] returns the head reference of [c], + its universe instance and its arguments *) +val find_class_type : evar_map -> types -> cl_typ * Univ.universe_instance * constr list (** raises [Not_found] if not convertible to a class *) val class_of : env -> evar_map -> types -> types * cl_index @@ -73,7 +73,7 @@ val declare_coercion : (** {6 Access to coercions infos } *) val coercion_exists : coe_typ -> bool -val coercion_value : coe_index -> (unsafe_judgment * bool) +val coercion_value : coe_index -> (unsafe_judgment * bool * bool) Univ.in_universe_context_set (** {6 Lookup functions for coercion paths } *) diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index 1db4119be..43af6ec62 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -34,19 +34,22 @@ exception NoCoercion exception NoCoercionNoUnifier of evar_map * unification_error (* Here, funj is a coercion therefore already typed in global context *) -let apply_coercion_args env argl funj = +let apply_coercion_args env evd check argl funj = + let evdref = ref evd in let rec apply_rec acc typ = function | [] -> { uj_val = applist (j_val funj,argl); uj_type = typ } | h::restl -> (* On devrait pouvoir s'arranger pour qu'on n'ait pas à faire hnf_constr *) - match kind_of_term (whd_betadeltaiota env Evd.empty typ) with + match kind_of_term (whd_betadeltaiota env evd typ) with | Prod (_,c1,c2) -> - (* Typage garanti par l'appel app_coercion*) + if check && not (e_cumul env evdref (Retyping.get_type_of env evd h) c1) then + anomaly (Pp.str"apply_coercion_args: mismatch between arguments and coercion"); apply_rec (h::acc) (subst1 h c2) restl | _ -> anomaly (Pp.str "apply_coercion_args") in - apply_rec [] funj.uj_type argl + let res = apply_rec [] funj.uj_type argl in + !evdref, res (* appliquer le chemin de coercions de patterns p *) let apply_pattern_coercion loc pat p = @@ -78,10 +81,10 @@ let disc_subset x = match kind_of_term x with | App (c, l) -> (match kind_of_term c with - Ind i -> + Ind (i,_) -> let len = Array.length l in let sigty = delayed_force sig_typ in - if Int.equal len 2 && eq_ind i (destInd sigty) + if Int.equal len 2 && eq_ind i (fst (Term.destInd sigty)) then let (a, b) = pair_of_array l in Some (a, b) @@ -170,11 +173,11 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr) in match (kind_of_term x, kind_of_term y) with | Sort s, Sort s' -> - (match s, s' with - Prop x, Prop y when x == y -> None - | Prop _, Type _ -> None - | Type x, Type y when Univ.Universe.equal x y -> None (* false *) - | _ -> subco ()) + (match s, s' with + | Prop x, Prop y when x == y -> None + | Prop _, Type _ -> None + | Type x, Type y when Univ.Universe.eq x y -> None (* false *) + | _ -> subco ()) | Prod (name, a, b), Prod (name', a', b') -> let name' = Name (Namegen.next_ident_away (Id.of_string "x") (Termops.ids_of_context env)) in let env' = push_rel (name', None, a') env in @@ -195,15 +198,15 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr) | App (c, l), App (c', l') -> (match kind_of_term c, kind_of_term c' with - Ind i, Ind i' -> (* Inductive types *) + Ind (i, u), Ind (i', u') -> (* Inductive types *) let len = Array.length l in let sigT = delayed_force sigT_typ in let prod = delayed_force prod_typ in (* Sigma types *) if Int.equal len (Array.length l') && Int.equal len 2 && eq_ind i i' - && (eq_ind i (destInd sigT) || eq_ind i (destInd prod)) + && (eq_ind i (fst (Term.destInd sigT)) || eq_ind i (fst (Term.destInd prod))) then - if eq_ind i (destInd sigT) + if eq_ind i (fst (Term.destInd sigT)) then begin let (a, pb), (a', pb') = @@ -323,17 +326,25 @@ let saturate_evd env evd = (* appliquer le chemin de coercions p hj *) let apply_coercion env sigma p hj typ_cl = try - fst (List.fold_left - (fun (ja,typ_cl) i -> - let fv,isid = coercion_value i in - let argl = (class_args_of env sigma typ_cl)@[ja.uj_val] in - let jres = apply_coercion_args env argl fv in - (if isid then - { uj_val = ja.uj_val; uj_type = jres.uj_type } - else - jres), - jres.uj_type) - (hj,typ_cl) p) + let j,t,evd = + List.fold_left + (fun (ja,typ_cl,sigma) i -> + let ((fv,isid,isproj),ctx) = coercion_value i in + let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx in + let argl = (class_args_of env sigma typ_cl)@[ja.uj_val] in + let sigma, jres = + apply_coercion_args env sigma (not (Univ.ContextSet.is_empty ctx)) argl fv + in + (if isid then + { uj_val = ja.uj_val; uj_type = jres.uj_type } + else if isproj then + { uj_val = mkProj (fst (destConst fv.uj_val), ja.uj_val); + uj_type = jres.uj_type } + else + jres), + jres.uj_type,sigma) + (hj,typ_cl,sigma) p + in evd, j with e when Errors.noncritical e -> anomaly (Pp.str "apply_coercion") let inh_app_fun env evd j = @@ -346,7 +357,7 @@ let inh_app_fun env evd j = | _ -> try let t,p = lookup_path_to_fun_from env evd j.uj_type in - (evd,apply_coercion env evd p j t) + apply_coercion env evd p j t with Not_found when Flags.is_program_mode () -> try let evdref = ref evd in @@ -367,7 +378,7 @@ let inh_app_fun resolve_tc env evd j = let inh_tosort_force loc env evd j = try let t,p = lookup_path_to_sort_from env evd j.uj_type in - let j1 = apply_coercion env evd p j t in + let evd,j1 = apply_coercion env evd p j t in let j2 = on_judgment_type (whd_evar evd) j1 in (evd,type_judgment env j2) with Not_found -> @@ -405,16 +416,16 @@ let inh_coerce_to_fail env evd rigidonly v t c1 = then raise NoCoercion else - let v', t' = + let evd, v', t' = try let t2,t1,p = lookup_path_between env evd (t,c1) in match v with Some v -> - let j = + let evd,j = apply_coercion env evd p {uj_val = v; uj_type = t} t2 in - Some j.uj_val, j.uj_type - | None -> None, t + evd, Some j.uj_val, j.uj_type + | None -> evd, None, t with Not_found -> raise NoCoercion in try (the_conv_x_leq env t' c1 evd, v') @@ -466,11 +477,20 @@ let inh_conv_coerce_to_gen resolve_tc rigidonly loc env evd cj t = | NoSubtacCoercion when not resolve_tc -> error_actual_type_loc loc env best_failed_evd cj t e | NoSubtacCoercion -> - let evd = saturate_evd env evd in + let evd' = saturate_evd env evd in try - inh_conv_coerce_to_fail loc env evd rigidonly (Some cj.uj_val) cj.uj_type t + if evd' == evd then + error_actual_type_loc loc env best_failed_evd cj t e + else + inh_conv_coerce_to_fail loc env evd' rigidonly (Some cj.uj_val) cj.uj_type t with NoCoercionNoUnifier (best_failed_evd,e) -> error_actual_type_loc loc env best_failed_evd cj t e + + (* let evd = saturate_evd env evd in *) + (* try *) + (* inh_conv_coerce_to_fail loc env evd rigidonly (Some cj.uj_val) cj.uj_type t *) + (* with NoCoercionNoUnifier (best_failed_evd,e) -> *) + (* error_actual_type_loc loc env best_failed_evd cj t e *) in let val' = match val' with Some v -> v | None -> assert(false) in (evd',{ uj_val = val'; uj_type = t }) diff --git a/pretyping/constrMatching.ml b/pretyping/constrMatching.ml index 45b097c00..243b563d3 100644 --- a/pretyping/constrMatching.ml +++ b/pretyping/constrMatching.ml @@ -63,7 +63,7 @@ let warn_bound_again name = let constrain n (ids, m as x) (names, terms as subst) = try let (ids', m') = Id.Map.find n terms in - if List.equal Id.equal ids ids' && eq_constr m m' then subst + if List.equal Id.equal ids ids' && eq_constr_nounivs m m' then subst else raise PatternMatchingFailure with Not_found -> let () = if Id.Map.mem n names then warn_bound_meta n in @@ -139,9 +139,18 @@ let merge_binding allow_bound_rels stk n cT subst = constrain n c subst let matches_core convert allow_partial_app allow_bound_rels pat c = - let conv = match convert with - | None -> eq_constr - | Some (env,sigma) -> is_conv env sigma in + let convref ref c = + match ref, kind_of_term c with + | VarRef id, Var id' -> Names.id_eq id id' + | ConstRef c, Const (c',_) -> Names.eq_constant c c' + | IndRef i, Ind (i', _) -> Names.eq_ind i i' + | ConstructRef c, Construct (c',u) -> Names.eq_constructor c c' + | _, _ -> (match convert with + | None -> false + | Some (env,sigma) -> + let sigma,c' = Evd.fresh_global env sigma ref in + is_conv env sigma c' c) + in let rec sorec stk subst p t = let cT = strip_outer_cast t in match p,kind_of_term cT with @@ -165,7 +174,7 @@ let matches_core convert allow_partial_app allow_bound_rels pat c = | PVar v1, Var v2 when Id.equal v1 v2 -> subst - | PRef ref, _ when conv (constr_of_global ref) cT -> subst + | PRef ref, _ when convref ref cT -> subst | PRel n1, Rel n2 when Int.equal n1 n2 -> subst @@ -193,8 +202,17 @@ let matches_core convert allow_partial_app allow_bound_rels pat c = else raise PatternMatchingFailure | PApp (c1,arg1), App (c2,arg2) -> - (try Array.fold_left2 (sorec stk) (sorec stk subst c1 c2) arg1 arg2 - with Invalid_argument _ -> raise PatternMatchingFailure) + (match c1, kind_of_term c2 with + | PRef (ConstRef r), Proj _ -> + (let subst = (sorec stk subst (PProj (r,arg1.(0))) c2) in + try Array.fold_left2 (sorec stk) subst (Array.tl arg1) arg2 + with Invalid_argument _ -> raise PatternMatchingFailure) + | _ -> + (try Array.fold_left2 (sorec stk) (sorec stk subst c1 c2) arg1 arg2 + with Invalid_argument _ -> raise PatternMatchingFailure)) + + | PProj (p1,c1), Proj (p2,c2) when eq_constant p1 p2 -> + sorec stk subst c1 c2 | PProd (na1,c1,d1), Prod(na2,c2,d2) -> sorec ((na1,na2,c2)::stk) @@ -367,6 +385,10 @@ let sub_match ?(partial_app=false) ?(closed=true) pat c = let next () = try_aux ((Array.to_list types)@(Array.to_list bodies)) next_mk_ctx next in authorized_occ partial_app closed pat c mk_ctx next + | Proj (p,c') -> + let next_mk_ctx le = mk_ctx (mkProj (p,List.hd le)) in + let next () = try_aux [c'] next_mk_ctx next in + authorized_occ partial_app closed pat c mk_ctx next | Construct _| Ind _|Evar _|Const _ | Rel _|Meta _|Var _|Sort _ -> authorized_occ partial_app closed pat c mk_ctx next diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index 9bc3d68c6..652c5acf9 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -73,10 +73,7 @@ module PrintingInductiveMake = type t = inductive let compare = ind_ord let encode = Test.encode - let subst subst (kn, ints as obj) = - let kn' = subst_ind subst kn in - if kn' == kn then obj else - kn', ints + let subst subst obj = subst_ind subst obj let printer ind = pr_global_env Id.Set.empty (IndRef ind) let key = ["Printing";Test.field] let title = Test.title @@ -373,7 +370,7 @@ let detype_sort = function | Type u -> GType (if !print_universes - then Some (Pp.string_of_ppcmds (Univ.pr_uni u)) + then Some (Pp.string_of_ppcmds (Univ.Universe.pr u)) else None) type binder_kind = BProd | BLambda | BLetIn @@ -384,6 +381,10 @@ type binder_kind = BProd | BLambda | BLetIn let detype_anonymous = ref (fun loc n -> anomaly ~label:"detype" (Pp.str "index to an anonymous variable")) let set_detype_anonymous f = detype_anonymous := f +let option_of_instance l = + if Univ.Instance.is_empty l then None + else Some l + let rec detype (isgoal:bool) avoid env t = match kind_of_term (collapse_appl t) with | Rel n -> @@ -397,7 +398,7 @@ let rec detype (isgoal:bool) avoid env t = (* Meta in constr are not user-parsable and are mapped to Evar *) GEvar (dl, Evar.unsafe_of_int n, None) | Var id -> - (try let _ = Global.lookup_named id in GRef (dl, VarRef id) + (try let _ = Global.lookup_named id in GRef (dl, VarRef id, None) with Not_found -> GVar (dl, id)) | Sort s -> GSort (dl,detype_sort s) | Cast (c1,REVERTcast,c2) when not !Flags.raw_print -> @@ -415,16 +416,26 @@ let rec detype (isgoal:bool) avoid env t = | Lambda (na,ty,c) -> detype_binder isgoal BLambda avoid env na ty c | LetIn (na,b,_,c) -> detype_binder isgoal BLetIn avoid env na b c | App (f,args) -> - GApp (dl,detype isgoal avoid env f, - Array.map_to_list (detype isgoal avoid env) args) - | Const sp -> GRef (dl, ConstRef sp) + let mkapp f' args' = + match f' with + | GApp (dl',f',args'') -> + GApp (dl,f',args''@args') + | _ -> GApp (dl,f',args') + in + mkapp (detype isgoal avoid env f) + (Array.map_to_list (detype isgoal avoid env) args) + (* GApp (dl,detype isgoal avoid env f, *) + (* Array.map_to_list (detype isgoal avoid env) args) *) + | Const (sp,u) -> GRef (dl, ConstRef sp, option_of_instance u) + | Proj (p,c) -> + GProj (dl, p, detype isgoal avoid env c) | Evar (ev,cl) -> GEvar (dl, ev, Some (List.map (detype isgoal avoid env) (Array.to_list cl))) - | Ind ind_sp -> - GRef (dl, IndRef ind_sp) - | Construct cstr_sp -> - GRef (dl, ConstructRef cstr_sp) + | Ind (ind_sp,u) -> + GRef (dl, IndRef ind_sp, option_of_instance u) + | Construct (cstr_sp,u) -> + GRef (dl, ConstructRef cstr_sp, option_of_instance u) | Case (ci,p,c,bl) -> let comp = computable p (ci.ci_pp_info.ind_nargs) in detype_case comp (detype isgoal avoid env) @@ -589,7 +600,7 @@ let rec subst_cases_pattern subst pat = match pat with | PatVar _ -> pat | PatCstr (loc,((kn,i),j),cpl,n) -> - let kn' = subst_ind subst kn + let kn' = subst_mind subst kn and cpl' = List.smartmap (subst_cases_pattern subst) cpl in if kn' == kn && cpl' == cpl then pat else PatCstr (loc,((kn',i),j),cpl',n) @@ -598,7 +609,7 @@ let (f_subst_genarg, subst_genarg_hook) = Hook.make () let rec subst_glob_constr subst raw = match raw with - | GRef (loc,ref) -> + | GRef (loc,ref,u) -> let ref',t = subst_global subst ref in if ref' == ref then raw else detype false [] [] t @@ -613,6 +624,12 @@ let rec subst_glob_constr subst raw = if r' == r && rl' == rl then raw else GApp(loc,r',rl') + | GProj (loc,p,c) -> + let p' = subst_constant subst p in + let c' = subst_glob_constr subst c in + if p' == p && c' == c then raw + else GProj (loc,p',c') + | GLambda (loc,n,bk,r1,r2) -> let r1' = subst_glob_constr subst r1 and r2' = subst_glob_constr subst r2 in if r1' == r1 && r2' == r2 then raw else @@ -635,7 +652,7 @@ let rec subst_glob_constr subst raw = let (n,topt) = x in let topt' = Option.smartmap (fun (loc,(sp,i),y as t) -> - let sp' = subst_ind subst sp in + let sp' = subst_mind subst sp in if sp == sp' then t else (loc,(sp',i),y)) topt in if a == a' && topt == topt' then y else (a',(n,topt'))) rl and branches' = List.smartmap diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index a0542cbb2..594481af3 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -27,41 +27,52 @@ let debug_unification = ref (false) let _ = Goptions.declare_bool_option { Goptions.optsync = true; Goptions.optdepr = false; Goptions.optname = - "Print states sended to Evarconv unification"; + "Print states sent to Evarconv unification"; Goptions.optkey = ["Debug";"Unification"]; Goptions.optread = (fun () -> !debug_unification); Goptions.optwrite = (fun a -> debug_unification:=a); } -let eval_flexible_term ts env c = +let unfold_projection env p c stk = + (match try Some (lookup_projection p env) with Not_found -> None with + | Some pb -> + let s = Stack.Proj (pb.Declarations.proj_npars, pb.Declarations.proj_arg, p) in + Some (c, s :: stk) + | None -> None) + +let eval_flexible_term ts env c stk = match kind_of_term c with - | Const c -> + | Const (c,u as cu) -> if is_transparent_constant ts c - then constant_opt_value env c + then Option.map (fun x -> x, stk) (constant_opt_value_in env cu) else None | Rel n -> - (try let (_,v,_) = lookup_rel n env in Option.map (lift n) v + (try let (_,v,_) = lookup_rel n env in Option.map (fun t -> lift n t, stk) v with Not_found -> None) | Var id -> (try if is_transparent_variable ts id then - let (_,v,_) = lookup_named id env in v + let (_,v,_) = lookup_named id env in Option.map (fun t -> t, stk) v else None with Not_found -> None) - | LetIn (_,b,_,c) -> Some (subst1 b c) - | Lambda _ -> Some c + | LetIn (_,b,_,c) -> Some (subst1 b c, stk) + | Lambda _ -> Some (c, stk) + | Proj (p, c) -> + if is_transparent_constant ts p + then unfold_projection env p c stk + else None | _ -> assert false type flex_kind_of_term = | Rigid - | MaybeFlexible of Constr.t (* reducible but not necessarily reduced *) + | MaybeFlexible of Constr.t * Constr.t Stack.t (* reducible but not necessarily reduced *) | Flexible of existential let flex_kind_of_term ts env c sk = match kind_of_term c with - | LetIn _ | Rel _ | Const _ | Var _ -> - Option.cata (fun x -> MaybeFlexible x) Rigid (eval_flexible_term ts env c) - | Lambda _ when not (Option.is_empty (Stack.decomp sk)) -> MaybeFlexible c + | LetIn _ | Rel _ | Const _ | Var _ | Proj _ -> + Option.cata (fun (x,y) -> MaybeFlexible (x,y)) Rigid (eval_flexible_term ts env c sk) + | Lambda _ when not (Option.is_empty (Stack.decomp sk)) -> MaybeFlexible (c, sk) | Evar ev -> Flexible ev | Lambda _ | Prod _ | Sort _ | Ind _ | Construct _ | CoFix _ -> Rigid | Meta _ -> Rigid @@ -100,36 +111,43 @@ let position_problem l2r = function projection would have been reduced) *) let check_conv_record (t1,sk1) (t2,sk2) = - let proji = global_of_constr t1 in - let canon_s,sk2_effective = - try - match kind_of_term t2 with - Prod (_,a,b) -> (* assert (l2=[]); *) + let (proji, u), arg = Universes.global_app_of_constr t1 in + let canon_s,sk2_effective = + try + match kind_of_term t2 with + Prod (_,a,b) -> (* assert (l2=[]); *) if dependent (mkRel 1) b then raise Not_found else lookup_canonical_conversion (proji, Prod_cs),(Stack.append_app [|a;pop b|] Stack.empty) - | Sort s -> - lookup_canonical_conversion - (proji, Sort_cs (family_of_sort s)),[] - | _ -> - let c2 = global_of_constr t2 in - lookup_canonical_conversion (proji, Const_cs c2),sk2 - with Not_found -> - lookup_canonical_conversion (proji,Default_cs),[] - in - let { o_DEF = c; o_INJ=n; o_TABS = bs; - o_TPARAMS = params; o_NPARAMS = nparams; o_TCOMPS = us } = canon_s in - let params1, c1, extra_args1 = + | Sort s -> + lookup_canonical_conversion + (proji, Sort_cs (family_of_sort s)),[] + | _ -> + let c2 = global_of_constr t2 in + lookup_canonical_conversion (proji, Const_cs c2),sk2 + with Not_found -> + lookup_canonical_conversion (proji,Default_cs),[] + in + let { o_DEF = c; o_CTX = ctx; o_INJ=n; o_TABS = bs; + o_TPARAMS = params; o_NPARAMS = nparams; o_TCOMPS = us } = canon_s in + let params1, c1, extra_args1 = + match arg with + | Some c -> (* A primitive projection applied to c *) + [], c, sk1 + | None -> match Stack.strip_n_app nparams sk1 with | Some (params1, c1,extra_args1) -> params1, c1, extra_args1 | _ -> raise Not_found in - let us2,extra_args2 = - let l_us = List.length us in + let us2,extra_args2 = + let l_us = List.length us in if Int.equal l_us 0 then Stack.empty,sk2_effective else match (Stack.strip_n_app (l_us-1) sk2_effective) with - | None -> raise Not_found - | Some (l',el,s') -> (l'@Stack.append_app [|el|] Stack.empty,s') in - (c,bs,(Stack.append_app_list params Stack.empty,params1),(Stack.append_app_list us Stack.empty,us2),(extra_args1,extra_args2),c1, - (n,Stack.zip(t2,sk2))) + | None -> raise Not_found + | Some (l',el,s') -> (l'@Stack.append_app [|el|] Stack.empty,s') in + let subst, ctx' = Universes.fresh_universe_context_set_instance ctx in + let c' = subst_univs_level_constr subst c in + let bs' = List.map (subst_univs_level_constr subst) bs in + ctx',c',bs',(Stack.append_app_list params Stack.empty,params1),(Stack.append_app_list us Stack.empty,us2),(extra_args1,extra_args2),c1, + (n,Stack.zip(t2,sk2)) (* Precondition: one of the terms of the pb is an uninstantiated evar, * possibly applied to arguments. *) @@ -206,6 +224,9 @@ let ise_stack2 no_app env evd f sk1 sk2 = | Success i'' -> ise_stack2 true i'' q1 q2 | UnifFailure _ as x -> fail x) | UnifFailure _ as x -> fail x) + | Stack.Proj (n1,a1,p1)::q1, Stack.Proj (n2,a2,p2)::q2 -> + if eq_constant p1 p2 then ise_stack2 true i q1 q2 + else fail (UnifFailure (i, NotSameHead)) | Stack.Fix (((li1, i1),(_,tys1,bds1 as recdef1)),a1,_)::q1, Stack.Fix (((li2, i2),(_,tys2,bds2)),a2,_)::q2 -> if Int.equal i1 i2 && Array.equal Int.equal li1 li2 then @@ -259,6 +280,13 @@ let exact_ise_stack2 env evd f sk1 sk2 = ise_stack2 evd (List.rev sk1) (List.rev sk2) else UnifFailure (evd, (* Dummy *) NotSameHead) +let eq_puniverses evd pbty f (x,u) (y,v) = + if f x y then + try + Success (Evd.set_eq_instances evd u v) + with Univ.UniverseInconsistency e -> UnifFailure (evd, UnifUnivInconsistency e) + else UnifFailure (evd, NotSameHead) + let rec evar_conv_x ts env evd pbty term1 term2 = let term1 = whd_head_evar evd term1 in let term2 = whd_head_evar evd term2 in @@ -266,15 +294,19 @@ let rec evar_conv_x ts env evd pbty term1 term2 = could have found, we do it only if the terms are free of evar. Note: incomplete heuristic... *) let ground_test = - if is_ground_term evd term1 && is_ground_term evd term2 then - if is_trans_fconv pbty ts env evd term1 term2 then - Some true - else if is_ground_env evd env then Some false - else None - else None in + if is_ground_term evd term1 && is_ground_term evd term2 then ( + let evd, b = + try infer_conv ~pb:pbty ~ts env evd term1 term2 + with Univ.UniverseInconsistency _ -> evd, false + in + if b then Some (evd, true) + else if is_ground_env evd env then Some (evd, false) + else None) + else None + in match ground_test with - | Some true -> Success evd - | Some false -> UnifFailure (evd,ConversionFailed (env,term1,term2)) + | Some (evd, true) -> Success evd + | Some (evd, false) -> UnifFailure (evd,ConversionFailed (env,term1,term2)) | None -> (* Until pattern-unification is used consistently, use nohdbeta to not destroy beta-redexes that can be used for 1st-order unification *) @@ -392,11 +424,13 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty in ise_try evd [f1; f2] - | Flexible ev1, MaybeFlexible v2 -> flex_maybeflex true ev1 (appr1,csts1) (appr2,csts2) v2 + | Flexible ev1, MaybeFlexible (v2,sk2) -> + flex_maybeflex true ev1 (appr1,csts1) ((term2,sk2),csts2) v2 - | MaybeFlexible v1, Flexible ev2 -> flex_maybeflex false ev2 (appr2,csts2) (appr1,csts1) v1 + | MaybeFlexible (v1,sk1), Flexible ev2 -> + flex_maybeflex false ev2 (appr2,csts2) ((term1,sk1),csts1) v1 - | MaybeFlexible v1, MaybeFlexible v2 -> begin + | MaybeFlexible (v1,sk1), MaybeFlexible (v2,sk2) -> begin match kind_of_term term1, kind_of_term term2 with | LetIn (na,b1,t1,c'1), LetIn (_,b2,_,c'2) -> let f1 i = @@ -414,12 +448,37 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty in ise_try evd [f1; f2] + | Proj (p, c), Proj (p', c') when eq_constant p p' -> + let f1 i = + ise_and i + [(fun i -> evar_conv_x ts env i CONV c c'); + (fun i -> exact_ise_stack2 env i (evar_conv_x ts) sk1 sk2)] + and f2 i = + if is_transparent_constant ts p then + match unfold_projection env p c sk1 with + | Some (c, sk1) -> + let out1 = whd_betaiota_deltazeta_for_iota_state ts env i csts1 (c,sk1) in + evar_eqappr_x ts env i pbty out1 (appr2, csts2) + | None -> assert false + else UnifFailure (i, NotSameHead) + in + ise_try evd [f1; f2] + | _, _ -> - let f1 i = - if eq_constr term1 term2 then - exact_ise_stack2 env i (evar_conv_x ts) sk1 sk2 - else - UnifFailure (i,NotSameHead) + let f1 i = + (* Gather the universe constraints that would make term1 and term2 equal. + If these only involve unifications of flexible universes to other universes, + allow this identification (first-order unification of universes). Otherwise + fallback to unfolding. + *) + let b,univs = eq_constr_universes term1 term2 in + if b then + ise_and i [(fun i -> + try Success (Evd.add_universe_constraints i univs) + with UniversesDiffer -> UnifFailure (i,NotSameHead) + | Univ.UniverseInconsistency p -> UnifFailure (i, UnifUnivInconsistency p)); + (fun i -> exact_ise_stack2 env i (evar_conv_x ts) sk1 sk2)] + else UnifFailure (i,NotSameHead) and f2 i = (try conv_record ts env i (try check_conv_record appr1 appr2 @@ -438,9 +497,11 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty (* false (* immediate solution without Canon Struct *)*) | Lambda _ -> assert (match args with [] -> true | _ -> false); true | LetIn (_,b,_,c) -> is_unnamed - (fst (whd_betaiota_deltazeta_for_iota_state + (fst (whd_betaiota_deltazeta_for_iota_state ts env i Cst_stack.empty (subst1 b c, args))) - | Case _| Fix _| App _| Cast _ -> assert false in + | Fix _ -> true (* Partially applied fix can be the result of a whd call *) + | Proj (p, c) -> true + | Case _ | App _| Cast _ -> assert false in let rhs_is_stuck_and_unnamed () = let applicative_stack = fst (Stack.strip_app sk2) in is_unnamed @@ -475,7 +536,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty | Flexible ev1, Rigid -> flex_rigid true ev1 appr1 appr2 | Rigid, Flexible ev2 -> flex_rigid false ev2 appr2 appr1 - | MaybeFlexible v1, Rigid -> + | MaybeFlexible (v1,sk1), Rigid -> let f3 i = (try conv_record ts env i (check_conv_record appr1 appr2) with Not_found -> UnifFailure (i,NoCanonicalStructure)) @@ -487,14 +548,14 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty in ise_try evd [f3; f4] - | Rigid, MaybeFlexible v2 -> + | Rigid, MaybeFlexible (v2,sk2) -> let f3 i = (try conv_record ts env i (check_conv_record appr2 appr1) with Not_found -> UnifFailure (i,NoCanonicalStructure)) and f4 i = - evar_eqappr_x ts env i pbty (appr1,csts1) - (whd_betaiota_deltazeta_for_iota_state - ts env i (Cst_stack.add_cst term2 csts2) (v2,sk2)) + evar_eqappr_x ts env i pbty (appr1,csts1) + (whd_betaiota_deltazeta_for_iota_state + ts env i (Cst_stack.add_cst term2 csts2) (v2,sk2)) in ise_try evd [f3; f4] @@ -515,8 +576,8 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty then Evd.set_eq_sort evd s1 s2 else Evd.set_leq_sort evd s1 s2 in Success evd' - with Univ.UniverseInconsistency _ -> - UnifFailure (evd,UnifUnivInconsistency) + with Univ.UniverseInconsistency p -> + UnifFailure (evd,UnifUnivInconsistency p) | e when Errors.noncritical e -> UnifFailure (evd,NotSameHead)) | Prod (n,c1,c'1), Prod (_,c2,c'2) when app_empty -> @@ -537,19 +598,19 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty else UnifFailure (evd,NotSameHead) | Const c1, Const c2 -> - if eq_constant c1 c2 then - exact_ise_stack2 env evd (evar_conv_x ts) sk1 sk2 - else UnifFailure (evd,NotSameHead) + ise_and evd + [(fun i -> eq_puniverses i pbty eq_constant c1 c2); + (fun i -> exact_ise_stack2 env i (evar_conv_x ts) sk1 sk2)] | Ind sp1, Ind sp2 -> - if eq_ind sp1 sp2 then - exact_ise_stack2 env evd (evar_conv_x ts) sk1 sk2 - else UnifFailure (evd,NotSameHead) + ise_and evd + [(fun i -> eq_puniverses i pbty eq_ind sp1 sp2); + (fun i -> exact_ise_stack2 env i (evar_conv_x ts) sk1 sk2)] | Construct sp1, Construct sp2 -> - if eq_constructor sp1 sp2 then - exact_ise_stack2 env evd (evar_conv_x ts) sk1 sk2 - else UnifFailure (evd,NotSameHead) + ise_and evd + [(fun i -> eq_puniverses i pbty eq_constructor sp1 sp2); + (fun i -> exact_ise_stack2 env i (evar_conv_x ts) sk1 sk2)] | Fix ((li1, i1),(_,tys1,bds1 as recdef1)), Fix ((li2, i2),(_,tys2,bds2)) -> (* Partially applied fixs *) if Int.equal i1 i2 && Array.equal Int.equal li1 li2 then @@ -583,13 +644,14 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty | _, (Ind _ | Construct _ | Sort _ | Prod _ | CoFix _ | Fix _ | Rel _ | Var _ | Const _) -> UnifFailure (evd,NotSameHead) - | (App _ | Cast _ | Case _), _ -> assert false + | (App _ | Cast _ | Case _ | Proj _), _ -> assert false | (LetIn _| Evar _), _ -> assert false | (Lambda _), _ -> assert false end -and conv_record trs env evd (c,bs,(params,params1),(us,us2),(ts,ts1),c1,(n,t2)) = +and conv_record trs env evd (ctx,c,bs,(params,params1),(us,us2),(ts,ts1),c1,(n,t2)) = + let evd = Evd.merge_context_set Evd.univ_flexible evd ctx in if Reductionops.Stack.compare_shape ts ts1 then let (evd',ks,_) = List.fold_left @@ -614,6 +676,28 @@ and conv_record trs env evd (c,bs,(params,params1),(us,us2),(ts,ts1),c1,(n,t2)) (fun i -> exact_ise_stack2 env i (evar_conv_x trs) ts ts1)] else UnifFailure(evd,(*dummy*)NotSameHead) +and eta_constructor ts env evd ((ind, i), u) l1 csts1 (c, csts2) = + let mib = lookup_mind (fst ind) env in + match mib.Declarations.mind_record with + | Some (exp,projs) when Array.length projs > 0 -> + let pars = mib.Declarations.mind_nparams in + (try + let l1' = Stack.tail pars l1 in + if Environ.is_projection projs.(0) env then + let sk2 = + let term = Stack.zip c in + List.map (fun p -> mkProj (p, term)) (Array.to_list projs) + in + exact_ise_stack2 env evd (evar_conv_x ts) l1' + (Stack.append_app_list sk2 Stack.empty) + else raise (Failure "") + with Failure _ -> UnifFailure(evd,NotSameHead)) + | _ -> UnifFailure (evd,NotSameHead) + +(* Profiling *) +(* let evar_conv_xkey = Profile.declare_profile "evar_conv_x";; *) +(* let evar_conv_x = Profile.profile6 evar_conv_xkey evar_conv_x *) + (* We assume here |l1| <= |l2| *) let first_order_unification ts env evd (ev1,l1) (term2,l2) = @@ -846,7 +930,7 @@ let apply_conversion_problem_heuristic ts env evd pbty t1 t2 = (* Some head evar have been instantiated, or unknown kind of problem *) evar_conv_x ts env evd pbty t1 t2 -let check_problems_are_solved evd = +let check_problems_are_solved env evd = match snd (extract_all_conv_pbs evd) with | (pbty,env,t1,t2)::_ -> Pretype_errors.error_cannot_unify env evd (t1, t2) | _ -> () @@ -890,10 +974,16 @@ let rec solve_unconstrained_evars_with_canditates ts evd = let evd = aux (List.rev l) in solve_unconstrained_evars_with_canditates ts evd -let solve_unconstrained_impossible_cases evd = +let solve_unconstrained_impossible_cases env evd = Evd.fold_undefined (fun evk ev_info evd' -> match ev_info.evar_source with - | _,Evar_kinds.ImpossibleCase -> Evd.define evk (j_type (coq_unit_judge ())) evd' + | _,Evar_kinds.ImpossibleCase -> + let j, ctx = coq_unit_judge () in + let evd' = Evd.merge_context_set Evd.univ_flexible_alg evd' ctx in + let ty = j_type j in + let conv_algo = evar_conv_x full_transparent_state in + let evd' = check_evar_instance evd' evk ty conv_algo in + Evd.define evk ty evd' | _ -> evd') evd evd let consider_remaining_unif_problems env @@ -925,8 +1015,8 @@ let consider_remaining_unif_problems env in let (evd,pbs) = extract_all_conv_pbs evd in let heuristic_solved_evd = aux evd pbs false [] in - check_problems_are_solved heuristic_solved_evd; - solve_unconstrained_impossible_cases heuristic_solved_evd + check_problems_are_solved env heuristic_solved_evd; + solve_unconstrained_impossible_cases env heuristic_solved_evd (* Main entry points *) diff --git a/pretyping/evarconv.mli b/pretyping/evarconv.mli index 3eb01439e..c99929b5e 100644 --- a/pretyping/evarconv.mli +++ b/pretyping/evarconv.mli @@ -38,12 +38,12 @@ val consider_remaining_unif_problems : env -> ?ts:transparent_state -> evar_map (** Check all pending unification problems are solved and raise an error otherwise *) -val check_problems_are_solved : evar_map -> unit +val check_problems_are_solved : env -> evar_map -> unit (** Check if a canonical structure is applicable *) val check_conv_record : constr * types Stack.t -> constr * types Stack.t -> - constr * constr list * (constr Stack.t * constr Stack.t) * + Univ.universe_context_set * constr * constr list * (constr Stack.t * constr Stack.t) * (constr Stack.t * types Stack.t) * (constr Stack.t * types Stack.t) * constr * (int * constr) diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index 4f982114a..b3c65ebaf 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -26,6 +26,24 @@ let normalize_evar evd ev = | Evar (evk,args) -> (evk,args) | _ -> assert false +let refresh_universes dir evd t = + let evdref = ref evd in + let modified = ref false in + let rec refresh t = match kind_of_term t with + | Sort (Type u as s) when Univ.universe_level u = None || + Evd.is_sort_variable evd s = None -> + (modified := true; + (* s' will appear in the term, it can't be algebraic *) + let s' = evd_comb0 (new_sort_variable Evd.univ_flexible) evdref in + evdref := + (if dir then set_leq_sort !evdref s' s else + set_leq_sort !evdref s s'); + mkSort s') + | Prod (na,u,v) -> mkProd (na,u,refresh v) + | _ -> t in + let t' = refresh t in + if !modified then !evdref, t' else evd, t + (************************) (* Unification results *) (************************) @@ -416,8 +434,8 @@ let make_projectable_subst aliases sigma evi args = let a',args = decompose_app_vect a in match kind_of_term a' with | Construct cstr -> - let l = try Constrmap.find cstr cstrs with Not_found -> [] in - Constrmap.add cstr ((args,id)::l) cstrs + let l = try Constrmap.find (fst cstr) cstrs with Not_found -> [] in + Constrmap.add (fst cstr) ((args,id)::l) cstrs | _ -> cstrs in (rest,Id.Map.add id [a,normalize_alias_opt aliases a,id] all,cstrs) | Some c, a::rest -> @@ -450,6 +468,7 @@ let make_projectable_subst aliases sigma evi args = let define_evar_from_virtual_equation define_fun env evd t_in_env sign filter inst_in_env = let ty_t_in_env = Retyping.get_type_of env evd t_in_env in + let evd,ty_t_in_env = refresh_universes false evd ty_t_in_env in let evd,evar_in_env = new_evar_instance sign evd ty_t_in_env ~filter inst_in_env in let t_in_env = whd_evar evd t_in_env in let evd = define_fun env evd None (destEvar evar_in_env) t_in_env in @@ -955,7 +974,7 @@ exception CannotProject of Filter.t option let rec is_constrainable_in k (ev,(fv_rels,fv_ids) as g) t = let f,args = decompose_app_vect t in match kind_of_term f with - | Construct (ind,_) -> + | Construct ((ind,_),u) -> let n = Inductiveops.inductive_nparams ind in if n > Array.length args then true (* We don't try to be more clever *) else @@ -1012,10 +1031,26 @@ let project_evar_on_evar g env evd aliases k2 (evk1,argsv1 as ev1) (evk2,argsv2 else raise (CannotProject filter1) +exception IllTypedInstance of env * types * types + +let check_evar_instance evd evk1 body conv_algo = + let evi = Evd.find evd evk1 in + let evenv = evar_env evi in + (* FIXME: The body might be ill-typed when this is called from w_merge *) + (* This happens in practice, cf MathClasses build failure on 2013-3-15 *) + let ty = + try Retyping.get_type_of ~lax:true evenv evd body + with Retyping.RetypeError _ -> error "Ill-typed evar instance" + in + match conv_algo evenv evd Reduction.CUMUL ty evi.evar_concl with + | Success evd -> evd + | UnifFailure _ -> raise (IllTypedInstance (evenv,ty,evi.evar_concl)) + let solve_evar_evar_l2r f g env evd aliases pbty ev1 (evk2,_ as ev2) = try let evd,body = project_evar_on_evar g env evd aliases 0 ev1 ev2 in - Evd.define evk2 body evd + let evd' = Evd.define evk2 body evd in + check_evar_instance evd' evk2 body g with EvarSolvedOnTheFly (evd,c) -> f env evd pbty ev2 c @@ -1037,27 +1072,39 @@ let solve_evar_evar ?(force=false) f g env evd pbty (evk1,args1 as ev1) (evk2,ar with CannotProject filter2 -> postpone_evar_evar f env evd pbty filter1 ev1 filter2 ev2 +let solve_evar_evar ?(force=false) f g env evd pbty (evk1,args1 as ev1) (evk2,args2 as ev2) = + let evi = Evd.find evd evk1 in + try + (* ?X : Π Δ. Type i = ?Y : Π Δ'. Type j. + The body of ?X and ?Y just has to be of type Π Δ. Type k for some k <= i, j. *) + let evienv = Evd.evar_env evi in + let ctx, i = Reduction.dest_arity evienv evi.evar_concl in + let evi2 = Evd.find evd evk2 in + let evi2env = Evd.evar_env evi2 in + let ctx', j = Reduction.dest_arity evi2env evi2.evar_concl in + if i == j || Evd.check_eq evd (univ_of_sort i) (univ_of_sort j) + then (* Shortcut, i = j *) + solve_evar_evar ~force f g env evd pbty ev1 ev2 + else + let evd, k = Evd.new_sort_variable univ_flexible_alg evd in + let evd, ev3 = + Evarutil.new_pure_evar evd (Evd.evar_hyps evi) + ~src:evi.evar_source ~filter:evi.evar_filter + ?candidates:evi.evar_candidates (it_mkProd_or_LetIn (mkSort k) ctx) + in + let evd = Evd.set_leq_sort (Evd.set_leq_sort evd k i) k j in + solve_evar_evar ~force f g env + (solve_evar_evar ~force f g env evd None (ev3,args1) ev1) + pbty (ev3,args1) ev2 + with Reduction.NotArity -> + solve_evar_evar ~force f g env evd None ev1 ev2 + type conv_fun = env -> evar_map -> conv_pb -> constr -> constr -> unification_result type conv_fun_bool = env -> evar_map -> conv_pb -> constr -> constr -> bool -exception IllTypedInstance of env * types * types - -let check_evar_instance evd evk1 body conv_algo = - let evi = Evd.find evd evk1 in - let evenv = evar_env evi in - (* FIXME: The body might be ill-typed when this is called from w_merge *) - (* This happens in practice, cf MathClasses build failure on 2013-3-15 *) - let ty = - try Retyping.get_type_of ~lax:true evenv evd body - with Retyping.RetypeError _ -> error "Ill-typed evar instance" - in - match conv_algo evenv evd Reduction.CUMUL ty evi.evar_concl with - | Success evd -> evd - | UnifFailure _ -> raise (IllTypedInstance (evenv,ty,evi.evar_concl)) - (* Solve pbs ?e[t1..tn] = ?e[u1..un] which arise often in fixpoint * definitions. We try to unify the ti with the ui pairwise. The pairs * that don't unify are discarded (i.e. ?e is redefined so that it does not @@ -1137,6 +1184,9 @@ exception NotEnoughInformationEvarEvar of constr exception OccurCheckIn of evar_map * constr exception MetaOccurInBodyInternal +let fast_stats = ref 0 +let not_fast_stats = ref 0 + let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = let aliases = make_alias_map env in let evdref = ref evd in @@ -1224,7 +1274,8 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = (* Try to project (a restriction of) the left evar ... *) try let evd,body = project_evar_on_evar conv_algo env' evd aliases 0 ev'' ev' in - Evd.define evk' body evd + let evd = Evd.define evk' body evd in + check_evar_instance evd evk' body conv_algo with | EvarSolvedOnTheFly _ -> assert false (* ev has no candidates *) | CannotProject filter'' -> @@ -1237,7 +1288,7 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = match let c,args = decompose_app_vect t in match kind_of_term c with - | Construct cstr when noccur_between 1 k t -> + | Construct (cstr,u) when noccur_between 1 k t -> (* This is common case when inferring the return clause of match *) (* (currently rudimentary: we do not treat the case of multiple *) (* possible inversions; we do not treat overlap with a possible *) @@ -1268,6 +1319,19 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = map_constr_with_full_binders (fun d (env,k) -> push_rel d env, k+1) imitate envk t in + let _fast rhs = + let filter_ctxt = evar_filtered_context evi in + let names = ref Idset.empty in + let rec is_id_subst ctxt s = + match ctxt, s with + | ((id, _, _) :: ctxt'), (c :: s') -> + names := Idset.add id !names; + isVarId id c && is_id_subst ctxt' s' + | [], [] -> true + | _ -> false in + is_id_subst filter_ctxt (Array.to_list argsv) && + closed0 rhs && + Idset.subset (collect_vars rhs) !names in let rhs = whd_beta evd rhs (* heuristic *) in let fast rhs = let filter_ctxt = evar_filtered_context evi in @@ -1296,7 +1360,7 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = * context "hyps" and not referring to itself. *) -and evar_define conv_algo ?(choose=false) env evd pbty (evk,argsv as ev) rhs = +and evar_define conv_algo ?(choose=false) ?(dir=false) env evd pbty (evk,argsv as ev) rhs = match kind_of_term rhs with | Evar (evk2,argsv2 as ev2) -> if Evar.equal evk evk2 then @@ -1315,7 +1379,7 @@ and evar_define conv_algo ?(choose=false) env evd pbty (evk,argsv as ev) rhs = (* so we recheck acyclicity *) if occur_evar evk body then raise (OccurCheckIn (evd',body)); (* needed only if an inferred type *) - let body = refresh_universes body in + let evd', body = refresh_universes dir evd' body in (* Cannot strictly type instantiations since the unification algorithm * does not unify applications from left to right. * e.g problem f x == g y yields x==y and f==g (in that order) @@ -1399,8 +1463,9 @@ let reconsider_conv_pbs conv_algo evd = let solve_simple_eqn conv_algo ?(choose=false) env evd (pbty,(evk1,args1 as ev1),t2) = try let t2 = whd_betaiota evd t2 in (* includes whd_evar *) - let evd = evar_define conv_algo ~choose env evd pbty ev1 t2 in - reconsider_conv_pbs conv_algo evd + let dir = match pbty with Some d -> d | None -> false in + let evd = evar_define conv_algo ~choose ~dir env evd pbty ev1 t2 in + reconsider_conv_pbs conv_algo evd with | NotInvertibleUsingOurAlgorithm t -> UnifFailure (evd,NotClean (ev1,t)) diff --git a/pretyping/evarsolve.mli b/pretyping/evarsolve.mli index 5d0063c47..7276669bf 100644 --- a/pretyping/evarsolve.mli +++ b/pretyping/evarsolve.mli @@ -31,9 +31,11 @@ type conv_fun = type conv_fun_bool = env -> evar_map -> conv_pb -> constr -> constr -> bool -val evar_define : conv_fun -> ?choose:bool -> env -> evar_map -> +val evar_define : conv_fun -> ?choose:bool -> ?dir:bool -> env -> evar_map -> bool option -> existential -> constr -> evar_map +val refresh_universes : bool -> evar_map -> types -> evar_map * types + val solve_refl : ?can_drop:bool -> conv_fun_bool -> env -> evar_map -> bool option -> existential_key -> constr array -> constr array -> evar_map diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml index 1605ef7cf..908e59227 100644 --- a/pretyping/evarutil.ml +++ b/pretyping/evarutil.ml @@ -21,6 +21,27 @@ open Evd open Reductionops open Pretype_errors +let evd_comb0 f evdref = + let (evd',x) = f !evdref in + evdref := evd'; + x + +let evd_comb1 f evdref x = + let (evd',y) = f !evdref x in + evdref := evd'; + y + +let evd_comb2 f evdref x y = + let (evd',z) = f !evdref x y in + evdref := evd'; + z + +let e_new_global evdref x = + evd_comb1 (Evd.fresh_global (Global.env())) evdref x + +let new_global evd x = + Evd.fresh_global (Global.env()) evd x + (****************************************************) (* Expanding/testing/exposing existential variables *) (****************************************************) @@ -37,6 +58,8 @@ let rec flush_and_check_evars sigma c = | Some c -> flush_and_check_evars sigma c) | _ -> map_constr (flush_and_check_evars sigma) c +(* let nf_evar_key = Profile.declare_profile "nf_evar" *) +(* let nf_evar = Profile.profile2 nf_evar_key Reductionops.nf_evar *) let nf_evar = Reductionops.nf_evar let j_nf_evar sigma j = { uj_val = nf_evar sigma j.uj_val; @@ -60,24 +83,38 @@ let env_nf_betaiotaevar sigma env = (fun d e -> push_rel (map_rel_declaration (Reductionops.nf_betaiota sigma) d) e) env +let nf_evars_universes evm = + Universes.nf_evars_and_universes_opt_subst (Reductionops.safe_evar_value evm) + (Evd.universe_subst evm) + +let nf_evars_and_universes evm = + let evm = Evd.nf_constraints evm in + evm, nf_evars_universes evm + +let e_nf_evars_and_universes evdref = + evdref := Evd.nf_constraints !evdref; + nf_evars_universes !evdref, Evd.universe_subst !evdref + +let nf_evar_map_universes evm = + let evm = Evd.nf_constraints evm in + let subst = Evd.universe_subst evm in + if Univ.LMap.is_empty subst then evm, nf_evar evm + else + let f = nf_evars_universes evm in + Evd.raw_map (fun _ -> map_evar_info f) evm, f + let nf_named_context_evar sigma ctx = - Context.map_named_context (Reductionops.nf_evar sigma) ctx + Context.map_named_context (nf_evar sigma) ctx let nf_rel_context_evar sigma ctx = - Context.map_rel_context (Reductionops.nf_evar sigma) ctx + Context.map_rel_context (nf_evar sigma) ctx let nf_env_evar sigma env = let nc' = nf_named_context_evar sigma (Environ.named_context env) in let rel' = nf_rel_context_evar sigma (Environ.rel_context env) in push_rel_context rel' (reset_with_named_context (val_of_named_context nc') env) -let nf_evar_info evc info = - { info with - evar_concl = Reductionops.nf_evar evc info.evar_concl; - evar_hyps = map_named_val (Reductionops.nf_evar evc) info.evar_hyps; - evar_body = match info.evar_body with - | Evar_empty -> Evar_empty - | Evar_defined c -> Evar_defined (Reductionops.nf_evar evc c) } +let nf_evar_info evc info = map_evar_info (nf_evar evc) info let nf_evar_map evm = Evd.raw_map (fun _ evi -> nf_evar_info evm evi) evm @@ -89,7 +126,7 @@ let nf_evar_map_undefined evm = (* Auxiliary functions for the conversion algorithms modulo evars *) -let has_undefined_evars_or_sorts evd t = +let has_undefined_evars or_sorts evd t = let rec has_ev t = match kind_of_term t with | Evar (ev,args) -> @@ -98,13 +135,16 @@ let has_undefined_evars_or_sorts evd t = has_ev c; Array.iter has_ev args | Evar_empty -> raise NotInstantiatedEvar) - | Sort s when is_sort_variable evd s -> raise Not_found + | Sort (Type _) (*FIXME could be finer, excluding Prop and Set universes *) when or_sorts -> + raise Not_found + | Ind (_,l) | Const (_,l) | Construct (_,l) + when l <> Univ.Instance.empty && or_sorts -> raise Not_found | _ -> iter_constr has_ev t in try let _ = has_ev t in false with (Not_found | NotInstantiatedEvar) -> true let is_ground_term evd t = - not (has_undefined_evars_or_sorts evd t) + not (has_undefined_evars true evd t) let is_ground_env evd env = let is_ground_decl = function @@ -333,9 +373,21 @@ let new_evar evd env ?src ?filter ?candidates typ = | Some filter -> Filter.filter_list filter instance in new_evar_instance sign evd typ' ?src ?filter ?candidates instance -let new_type_evar ?src ?filter evd env = - let evd', s = new_sort_variable evd in - new_evar evd' env ?src ?filter (mkSort s) +let new_type_evar ?src ?filter rigid evd env = + let evd', s = new_sort_variable rigid evd in + let evd', e = new_evar evd' env ?src ?filter (mkSort s) in + evd', (e, s) + + (* The same using side-effect *) +let e_new_evar evdref env ?(src=(Loc.ghost,Evar_kinds.InternalHole)) ?filter ?candidates ty = + let (evd',ev) = new_evar !evdref env ~src:src ?filter ?candidates ty in + evdref := evd'; + ev + +let e_new_type_evar evdref ?src ?filter rigid env = + let evd', c = new_type_evar ?src ?filter rigid !evdref env in + evdref := evd'; + c (* The same using side-effect *) let e_new_evar evdref env ?(src=default_source) ?filter ?candidates ty = @@ -470,7 +522,6 @@ let clear_hyps_in_evi evdref hyps concl ids = in (nhyps,nconcl) - (** The following functions return the set of evars immediately contained in the object, including defined evars *) @@ -597,6 +648,7 @@ let check_evars env initial_sigma sigma c = | _ -> iter_constr proc_rec c in proc_rec c + (****************************************) (* Operations on value/type constraints *) (****************************************) @@ -639,15 +691,25 @@ let define_pure_evar_as_product evd evk = let evi = Evd.find_undefined evd evk in let evenv = evar_env evi in let id = next_ident_away idx (ids_of_named_context (evar_context evi)) in - let evd1,dom = new_type_evar evd evenv ~filter:(evar_filter evi) in + let s = destSort evi.evar_concl in + let evd1,(dom,u1) = new_type_evar univ_flexible_alg evd evenv ~filter:(evar_filter evi) in let evd2,rng = let newenv = push_named (id, None, dom) evenv in let src = evar_source evk evd1 in let filter = Filter.extend 1 (evar_filter evi) in - new_type_evar evd1 newenv ~src ~filter in + if is_prop_sort s then + (* Impredicative product, conclusion must fall in [Prop]. *) + new_evar evd1 newenv evi.evar_concl ~src ~filter + else + let evd3, (rng, srng) = + new_type_evar univ_flexible_alg evd1 newenv ~src ~filter in + let prods = Univ.sup (univ_of_sort u1) (univ_of_sort srng) in + let evd3 = Evd.set_leq_sort evd3 (Type prods) s in + evd3, rng + in let prod = mkProd (Name id, dom, subst_var id rng) in let evd3 = Evd.define evk prod evd2 in - evd3,prod + evd3,prod (* Refine an applied evar to a product and returns its instantiation *) @@ -707,15 +769,18 @@ let rec evar_absorb_arguments env evd (evk,args as ev) = function (* Refining an evar to a sort *) let define_evar_as_sort evd (ev,args) = - let evd, s = new_sort_variable evd in - Evd.define ev (mkSort s) evd, s + let evd, u = new_univ_variable univ_rigid evd in + let evi = Evd.find_undefined evd ev in + let s = Type u in + let evd' = Evd.define ev (mkSort s) evd in + Evd.set_leq_sort evd' (Type (Univ.super u)) (destSort evi.evar_concl), s (* We don't try to guess in which sort the type should be defined, since any type has type Type. May cause some trouble, but not so far... *) let judge_of_new_Type evd = - let evd', s = new_univ_variable evd in - evd', Typeops.judge_of_type s + let evd', s = new_univ_variable univ_rigid evd in + evd', { uj_val = mkSort (Type s); uj_type = mkSort (Type (Univ.super s)) } (* Propagation of constraints through application and abstraction: Given a type constraint on a functional term, returns the type diff --git a/pretyping/evarutil.mli b/pretyping/evarutil.mli index f41f1ec86..b860ce337 100644 --- a/pretyping/evarutil.mli +++ b/pretyping/evarutil.mli @@ -39,7 +39,16 @@ val e_new_evar : (** Create a new Type existential variable, as we keep track of them during type-checking and unification. *) val new_type_evar : - ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> evar_map -> env -> evar_map * constr + ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> rigid -> evar_map -> env -> + evar_map * (constr * sorts) + +val e_new_type_evar : evar_map ref -> + ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> rigid -> env -> constr * sorts + +(** Polymorphic constants *) + +val new_global : evar_map -> Globnames.global_reference -> evar_map * constr +val e_new_global : evar_map ref -> Globnames.global_reference -> constr (** Create a fresh evar in a context different from its definition context: [new_evar_instance sign evd ty inst] creates a new evar of context @@ -65,6 +74,9 @@ val head_evar : constr -> existential_key (** may raise NoHeadEvar *) (* Expand head evar if any *) val whd_head_evar : evar_map -> constr -> constr +(* [has_undefined_evars or_sorts evd c] checks if [c] has undefined evars + and optionally if it contains undefined sorts. *) +val has_undefined_evars : bool -> evar_map -> constr -> bool val is_ground_term : evar_map -> constr -> bool val is_ground_env : evar_map -> env -> bool (** [check_evars env initial_sigma extended_sigma c] fails if some @@ -160,6 +172,15 @@ val jv_nf_betaiotaevar : evar_map -> unsafe_judgment array -> unsafe_judgment array (** Presenting terms without solved evars *) +val nf_evars_universes : evar_map -> constr -> constr + +val nf_evars_and_universes : evar_map -> evar_map * (constr -> constr) +val e_nf_evars_and_universes : evar_map ref -> (constr -> constr) * Universes.universe_opt_subst + +(** Normalize the evar map w.r.t. universes, after simplification of constraints. + Return the substitution function for constrs as well. *) +val nf_evar_map_universes : evar_map -> evar_map * (constr -> constr) + (** Replacing all evars, possibly raising [Uninstantiated_evar] *) exception Uninstantiated_evar of existential_key val flush_and_check_evars : evar_map -> constr -> constr @@ -189,3 +210,9 @@ val push_rel_context_to_named_context : Environ.env -> types -> named_context_val * types * constr list * constr list * (identifier*constr) list val generalize_evar_over_rels : evar_map -> existential -> types * constr list + +(** Evar combinators *) + +val evd_comb0 : (evar_map -> evar_map * 'a) -> evar_map ref -> 'a +val evd_comb1 : (evar_map -> 'b -> evar_map * 'a) -> evar_map ref -> 'b -> 'a +val evd_comb2 : (evar_map -> 'b -> 'c -> evar_map * 'a) -> evar_map ref -> 'b -> 'c -> 'a diff --git a/pretyping/evd.ml b/pretyping/evd.ml index 8fc6b8ab2..0776988d7 100644 --- a/pretyping/evd.ml +++ b/pretyping/evd.ml @@ -207,6 +207,18 @@ let eq_evar_info ei1 ei2 = eq_evar_body ei1.evar_body ei2.evar_body (** ppedrot: [eq_constr] may be a bit too permissive here *) + +let map_evar_body f = function + | Evar_empty -> Evar_empty + | Evar_defined d -> Evar_defined (f d) + +let map_evar_info f evi = + {evi with + evar_body = map_evar_body f evi.evar_body; + evar_hyps = map_named_val f evi.evar_hyps; + evar_concl = f evi.evar_concl; + evar_candidates = Option.map (List.map f) evi.evar_candidates } + (* spiwack: Revised hierarchy : - Evar.Map ( Maps of existential_keys ) - EvarInfoMap ( .t = evar_info Evar.Map.t * evar_info Evar.Map ) @@ -250,6 +262,202 @@ let instantiate_evar_array info c args = | [] -> c | _ -> replace_vars inst c +(* 2nd part used to check consistency on the fly. *) +type evar_universe_context = + { uctx_local : Univ.universe_context_set; (** The local context of variables *) + uctx_postponed : Univ.universe_constraints; + uctx_univ_variables : Universes.universe_opt_subst; + (** The local universes that are unification variables *) + uctx_univ_algebraic : Univ.universe_set; + (** The subset of unification variables that + can be instantiated with algebraic universes as they appear in types + and universe instances only. *) + uctx_universes : Univ.universes; (** The current graph extended with the local constraints *) + } + +let empty_evar_universe_context = + { uctx_local = Univ.ContextSet.empty; + uctx_postponed = Univ.UniverseConstraints.empty; + uctx_univ_variables = Univ.LMap.empty; + uctx_univ_algebraic = Univ.LSet.empty; + uctx_universes = Univ.initial_universes } + +let evar_universe_context_from e c = + {empty_evar_universe_context with + uctx_local = c; uctx_universes = universes e} + +let is_empty_evar_universe_context ctx = + Univ.ContextSet.is_empty ctx.uctx_local && + Univ.LMap.is_empty ctx.uctx_univ_variables + +let union_evar_universe_context ctx ctx' = + if ctx == ctx' then ctx + else if is_empty_evar_universe_context ctx then ctx' + else if is_empty_evar_universe_context ctx' then ctx + else + let local = + if ctx.uctx_local == ctx'.uctx_local then ctx.uctx_local + else Univ.ContextSet.union ctx.uctx_local ctx'.uctx_local + in + { uctx_local = local; + uctx_postponed = Univ.UniverseConstraints.union ctx.uctx_postponed ctx'.uctx_postponed; + uctx_univ_variables = + Univ.LMap.subst_union ctx.uctx_univ_variables ctx'.uctx_univ_variables; + uctx_univ_algebraic = + Univ.LSet.union ctx.uctx_univ_algebraic ctx'.uctx_univ_algebraic; + uctx_universes = + if local == ctx.uctx_local then ctx.uctx_universes + else + let cstrsr = Univ.ContextSet.constraints ctx'.uctx_local in + Univ.merge_constraints cstrsr ctx.uctx_universes} + +(* let union_evar_universe_context_key = Profile.declare_profile "union_evar_universe_context";; *) +(* let union_evar_universe_context = *) +(* Profile.profile2 union_evar_universe_context_key union_evar_universe_context;; *) + +let diff_evar_universe_context ctx' ctx = + if ctx == ctx' then empty_evar_universe_context + else + let local = Univ.ContextSet.diff ctx'.uctx_local ctx.uctx_local in + { uctx_local = local; + uctx_postponed = Univ.UniverseConstraints.diff ctx'.uctx_postponed ctx.uctx_postponed; + uctx_univ_variables = + Univ.LMap.diff ctx'.uctx_univ_variables ctx.uctx_univ_variables; + uctx_univ_algebraic = + Univ.LSet.diff ctx'.uctx_univ_algebraic ctx.uctx_univ_algebraic; + uctx_universes = Univ.empty_universes } + +(* let diff_evar_universe_context_key = Profile.declare_profile "diff_evar_universe_context";; *) +(* let diff_evar_universe_context = *) +(* Profile.profile2 diff_evar_universe_context_key diff_evar_universe_context;; *) + +type 'a in_evar_universe_context = 'a * evar_universe_context + +let evar_universe_context_set ctx = ctx.uctx_local +let evar_context_universe_context ctx = Univ.ContextSet.to_context ctx.uctx_local +let evar_universe_context_of ctx = { empty_evar_universe_context with uctx_local = ctx } +let evar_universe_context_subst ctx = ctx.uctx_univ_variables + +let instantiate_variable l b v = + (* let b = Univ.subst_large_constraint (Univ.Universe.make l) Univ.type0m_univ b in *) + (* if Univ.univ_depends (Univ.Universe.make l) b then *) + (* error ("Occur-check in universe variable instantiation") *) + (* else *) v := Univ.LMap.add l (Some b) !v + +exception UniversesDiffer + +let process_universe_constraints univs postponed vars alg local cstrs = + let vars = ref vars in + let normalize = Universes.normalize_universe_opt_subst vars in + let rec unify_universes fo l d r local postponed = + let l = normalize l and r = normalize r in + if Univ.Universe.eq l r then local, postponed + else + let varinfo x = + match Univ.Universe.level x with + | None -> Inl x + | Some l -> Inr (l, Univ.LMap.mem l !vars, Univ.LSet.mem l alg) + in + if d == Univ.ULe then + if Univ.check_leq univs l r then + (** Keep Prop <= var around if var might be instantiated by prop later. *) + if Univ.is_type0m_univ l && not (Univ.is_small_univ r) then + match Univ.Universe.level l, Univ.Universe.level r with + | Some l, Some r -> Univ.Constraint.add (l,Univ.Le,r) local, postponed + | _, _ -> local, postponed + else local, postponed + else + match Univ.Universe.level r with + | None -> (local, Univ.UniverseConstraints.add (l,d,r) postponed) + | Some _ -> (Univ.enforce_leq l r local, postponed) + else if d == Univ.ULub then + match varinfo l, varinfo r with + | (Inr (l, true, _), Inr (r, _, _)) + | (Inr (r, _, _), Inr (l, true, _)) -> + instantiate_variable l (Univ.Universe.make r) vars; + Univ.enforce_eq_level l r local, postponed + | Inr (_, _, _), Inr (_, _, _) -> + unify_universes true l Univ.UEq r local postponed + | _, _ -> (* Dead code *) + if Univ.check_eq univs l r then local, postponed + else local, Univ.UniverseConstraints.add (l,d,r) postponed + else (* d = Univ.UEq *) + match varinfo l, varinfo r with + | Inr (l', lloc, _), Inr (r', rloc, _) -> + let () = + if lloc then + instantiate_variable l' (Univ.Universe.make r') vars + else if rloc then + instantiate_variable r' (Univ.Universe.make l') vars + else + (* Two rigid/global levels, one of them being Prop/Set, disallow *) + (* if Univ.is_small_univ l' || Univ.is_small_univ r' then *) + (* raise UniversesDiffer *) + (* else *) + if fo then + if not (Univ.check_eq univs l r) then + raise UniversesDiffer + in + Univ.enforce_eq_level l' r' local, postponed + | _, _ (* Algebraic or globals: + try first-order unification of formal expressions. + THIS IS WRONG: it should be postponed and the equality + turned into a common lub constraint. *) -> + if Univ.check_eq univs l r then local, postponed + else raise UniversesDiffer + (* anomaly (Pp.str"Trying to equate algebraic universes") *) + (* local, Univ.UniverseConstraints.add (l,d,r) postponed *) + in + let rec fixpoint local postponed cstrs = + let local, postponed' = + Univ.UniverseConstraints.fold (fun (l,d,r) (local, p) -> unify_universes false l d r local p) + cstrs (local, postponed) + in + if Univ.UniverseConstraints.is_empty postponed' then local, postponed' + else if Univ.UniverseConstraints.equal cstrs postponed' then local, postponed' + else (* Progress: *) + fixpoint local Univ.UniverseConstraints.empty postponed' + in + let local, pbs = fixpoint Univ.Constraint.empty postponed cstrs in + !vars, local, pbs + +let add_constraints_context ctx cstrs = + let univs, local = ctx.uctx_local in + let cstrs' = Univ.Constraint.fold (fun (l,d,r) acc -> + let l = Univ.Universe.make l and r = Univ.Universe.make r in + let cstr' = + if d == Univ.Lt then (Univ.Universe.super l, Univ.ULe, r) + else (l, (if d == Univ.Le then Univ.ULe else Univ.UEq), r) + in Univ.UniverseConstraints.add cstr' acc) + cstrs Univ.UniverseConstraints.empty + in + let vars, local', pbs = + process_universe_constraints ctx.uctx_universes ctx.uctx_postponed + ctx.uctx_univ_variables ctx.uctx_univ_algebraic + local cstrs' + in + { ctx with uctx_local = (univs, Univ.Constraint.union local local'); + uctx_postponed = pbs; + uctx_univ_variables = vars; + uctx_universes = Univ.merge_constraints cstrs ctx.uctx_universes } + +(* let addconstrkey = Profile.declare_profile "add_constraints_context";; *) +(* let add_constraints_context = Profile.profile2 addconstrkey add_constraints_context;; *) + +let add_universe_constraints_context ctx cstrs = + let univs, local = ctx.uctx_local in + let vars, local', pbs = + process_universe_constraints ctx.uctx_universes ctx.uctx_postponed + ctx.uctx_univ_variables ctx.uctx_univ_algebraic local cstrs + in + { ctx with uctx_local = (univs, Univ.Constraint.union local local'); + uctx_postponed = pbs; + uctx_univ_variables = vars; + uctx_universes = Univ.merge_constraints local' ctx.uctx_universes } + +(* let addunivconstrkey = Profile.declare_profile "add_universe_constraints_context";; *) +(* let add_universe_constraints_context = *) +(* Profile.profile2 addunivconstrkey add_universe_constraints_context;; *) (*******************************************************************) (* Metamaps *) @@ -341,8 +549,7 @@ module EvMap = Evar.Map type evar_map = { defn_evars : evar_info EvMap.t; undf_evars : evar_info EvMap.t; - universes : Univ.UniverseLSet.t; - univ_cstrs : Univ.universes; + universes : evar_universe_context; conv_pbs : evar_constraint list; last_mods : Evar.Set.t; metas : clbinding Metamap.t; @@ -448,8 +655,11 @@ let existential_type d (n, args) = anomaly (str "Evar " ++ str (string_of_existential n) ++ str " was not declared") in instantiate_evar_array info info.evar_concl args -let add_constraints d cstrs = - { d with univ_cstrs = Univ.merge_constraints cstrs d.univ_cstrs } +let add_constraints d c = + { d with universes = add_constraints_context d.universes c } + +let add_universe_constraints d c = + { d with universes = add_universe_constraints_context d.universes c } (*** /Lifting... ***) @@ -473,8 +683,8 @@ let subst_evar_info s evi = evar_body = subst_evb evi.evar_body } let subst_evar_defs_light sub evd = - assert (Univ.is_initial_universes evd.univ_cstrs); - assert (match evd.conv_pbs with [] -> true | _ -> false); + assert (Univ.is_initial_universes evd.universes.uctx_universes); + assert (List.is_empty evd.conv_pbs); let map_info i = subst_evar_info sub i in { evd with undf_evars = EvMap.smartmap map_info evd.undf_evars; @@ -483,6 +693,13 @@ let subst_evar_defs_light sub evd = let subst_evar_map = subst_evar_defs_light +let cmap f evd = + { evd with + metas = Metamap.map (map_clb f) evd.metas; + defn_evars = EvMap.map (map_evar_info f) evd.defn_evars; + undf_evars = EvMap.map (map_evar_info f) evd.defn_evars + } + (* spiwack: deprecated *) let create_evar_defs sigma = { sigma with conv_pbs=[]; last_mods=Evar.Set.empty; metas=Metamap.empty } @@ -494,20 +711,32 @@ let create_goal_evar_defs sigma = { sigma with let empty = { defn_evars = EvMap.empty; undf_evars = EvMap.empty; - universes = Univ.UniverseLSet.empty; - univ_cstrs = Univ.initial_universes; + universes = empty_evar_universe_context; conv_pbs = []; last_mods = Evar.Set.empty; metas = Metamap.empty; effects = Declareops.no_seff; } +let from_env ?(ctx=Univ.ContextSet.empty) e = + { empty with universes = evar_universe_context_from e ctx } + + let has_undefined evd = not (EvMap.is_empty evd.undf_evars) -let evars_reset_evd ?(with_conv_pbs=false) evd d = +let evars_reset_evd ?(with_conv_pbs=false) ?(with_univs=true) evd d = let conv_pbs = if with_conv_pbs then evd.conv_pbs else d.conv_pbs in let last_mods = if with_conv_pbs then evd.last_mods else d.last_mods in - { evd with metas = d.metas; last_mods; conv_pbs; } + let universes = + if not with_univs then evd.universes + else union_evar_universe_context evd.universes d.universes + in + { evd with + metas = d.metas; + last_mods; conv_pbs; universes } + +let merge_universe_context evd uctx' = + { evd with universes = union_evar_universe_context evd.universes uctx' } let add_conv_pb pb d = {d with conv_pbs = pb::d.conv_pbs} @@ -608,80 +837,444 @@ let drop_side_effects evd = let eval_side_effects evd = evd.effects +let meta_diff ext orig = + Metamap.fold (fun m v acc -> + if Metamap.mem m orig then acc + else Metamap.add m v acc) + ext Metamap.empty + +(** ext is supposed to be an extension of odef: + it might have more defined evars, and more + or less undefined ones *) +let diff2 edef eundef odef oundef = + let def = + if odef == edef then EvMap.empty + else + EvMap.fold (fun e v acc -> + if EvMap.mem e odef then acc + else EvMap.add e v acc) + edef EvMap.empty + in + let undef = + if oundef == eundef then EvMap.empty + else + EvMap.fold (fun e v acc -> + if EvMap.mem e oundef then acc + else EvMap.add e v acc) + eundef EvMap.empty + in + (def, undef) + +let diff ext orig = + let defn, undf = diff2 ext.defn_evars ext.undf_evars orig.defn_evars orig.undf_evars in + { ext with + defn_evars = defn; undf_evars = undf; + universes = diff_evar_universe_context ext.universes orig.universes; + metas = meta_diff ext.metas orig.metas + } + +(** Invariant: sigma' is a partial extension of sigma: + It may define variables that are undefined in sigma, + or add new defined or undefined variables. It should not + undefine a defined variable in sigma. +*) + +let merge2 def undef def' undef' = + let def, undef = + EvMap.fold (fun n v (def,undef) -> + EvMap.add n v def, EvMap.remove n undef) + def' (def,undef) + in + let undef = EvMap.fold EvMap.add undef' undef in + (def, undef) + +let merge_metas metas1 metas2 = + List.fold_left (fun m (n,v) -> Metamap.add n v m) + metas2 (metamap_to_list metas1) + +let merge orig ext = + let defn, undf = merge2 orig.defn_evars orig.undf_evars ext.defn_evars ext.undf_evars in + let universes = union_evar_universe_context orig.universes ext.universes in + { orig with defn_evars = defn; undf_evars = undf; + universes; + metas = merge_metas orig.metas ext.metas } + (**********************************************************) (* Sort variables *) -let new_univ_variable evd = - let u = Termops.new_univ_level () in - let universes = Univ.UniverseLSet.add u evd.universes in - ({ evd with universes }, Univ.Universe.make u) +type rigid = + | UnivRigid + | UnivFlexible of bool (** Is substitution by an algebraic ok? *) + +let univ_rigid = UnivRigid +let univ_flexible = UnivFlexible false +let univ_flexible_alg = UnivFlexible true + +let evar_universe_context d = d.universes -let new_sort_variable d = - let (d', u) = new_univ_variable d in - (d', Type u) +let get_universe_context_set d = d.universes.uctx_local + +let universes evd = evd.universes.uctx_universes + +let universe_context evd = + Univ.ContextSet.to_context evd.universes.uctx_local + +let universe_subst evd = + evd.universes.uctx_univ_variables + +let merge_uctx rigid uctx ctx' = + let uctx = + match rigid with + | UnivRigid -> uctx + | UnivFlexible b -> + let uvars' = Univ.LMap.subst_union uctx.uctx_univ_variables + (Univ.LMap.of_set (Univ.ContextSet.levels ctx') None) in + if b then + { uctx with uctx_univ_variables = uvars'; + uctx_univ_algebraic = Univ.LSet.union uctx.uctx_univ_algebraic + (Univ.ContextSet.levels ctx') } + else { uctx with uctx_univ_variables = uvars' } + in + { uctx with uctx_local = Univ.ContextSet.union uctx.uctx_local ctx'; + uctx_universes = Univ.merge_constraints (Univ.ContextSet.constraints ctx') + uctx.uctx_universes } + +let merge_context_set rigid evd ctx' = + {evd with universes = merge_uctx rigid evd.universes ctx'} + +let with_context_set rigid d (a, ctx) = + (merge_context_set rigid d ctx, a) + +let uctx_new_univ_variable rigid + ({ uctx_local = ctx; uctx_univ_variables = uvars; uctx_univ_algebraic = avars} as uctx) = + let u = Universes.new_univ_level (Global.current_dirpath ()) in + let ctx' = Univ.ContextSet.union ctx (Univ.ContextSet.singleton u) in + let uctx' = + match rigid with + | UnivRigid -> uctx + | UnivFlexible b -> + let uvars' = Univ.LMap.add u None uvars in + if b then {uctx with uctx_univ_variables = uvars'; + uctx_univ_algebraic = Univ.LSet.add u avars} + else {uctx with uctx_univ_variables = Univ.LMap.add u None uvars} in + {uctx' with uctx_local = ctx'}, u + +let new_univ_variable rigid evd = + let uctx', u = uctx_new_univ_variable rigid evd.universes in + ({evd with universes = uctx'}, Univ.Universe.make u) + +let new_sort_variable rigid d = + let (d', u) = new_univ_variable rigid d in + (d', Type u) + +let make_flexible_variable evd b u = + let {uctx_univ_variables = uvars; uctx_univ_algebraic = avars} as ctx = evd.universes in + let uvars' = Univ.LMap.add u None uvars in + let avars' = + if b then + let uu = Univ.Universe.make u in + let substu_not_alg u' v = + Option.cata (fun vu -> Univ.Universe.eq uu vu && not (Univ.LSet.mem u' avars)) false v + in + if not (Univ.LMap.exists substu_not_alg uvars) + then Univ.LSet.add u avars else avars + else avars + in + {evd with universes = {ctx with uctx_univ_variables = uvars'; + uctx_univ_algebraic = avars'}} + + +let instantiate_univ_variable evd v u = + let uvars' = Univ.LMap.add v (Some u) evd.universes.uctx_univ_variables in + {evd with universes = {evd.universes with uctx_univ_variables = uvars'}} + +(****************************************) +(* Operations on constants *) +(****************************************) + +let fresh_sort_in_family env evd s = + with_context_set univ_flexible evd (Universes.fresh_sort_in_family env s) + +let fresh_constant_instance env evd c = + with_context_set univ_flexible evd (Universes.fresh_constant_instance env c) + +let fresh_inductive_instance env evd i = + with_context_set univ_flexible evd (Universes.fresh_inductive_instance env i) + +let fresh_constructor_instance env evd c = + with_context_set univ_flexible evd (Universes.fresh_constructor_instance env c) + +let fresh_global ?(rigid=univ_flexible) env evd gr = + (* match gr with *) + (* | ConstructRef c -> let evd, c = fresh_constructor_instance env evd c in *) + (* evd, mkConstructU c *) + (* | IndRef c -> let evd, c = fresh_inductive_instance env evd c in *) + (* evd, mkIndU c *) + (* | ConstRef c -> let evd, c = fresh_constant_instance env evd c in *) + (* evd, mkConstU c *) + (* | VarRef i -> evd, mkVar i *) + with_context_set rigid evd (Universes.fresh_global_instance env gr) -let is_sort_variable evd s = match s with Type u -> true | _ -> false let whd_sort_variable evd t = t -let univ_of_sort = function - | Type u -> u - | Prop Pos -> Univ.type0_univ - | Prop Null -> Univ.type0m_univ +let is_sort_variable evd s = + match s with + | Type u -> + (match Univ.universe_level u with + | Some l -> + let uctx = evd.universes in + if Univ.LSet.mem l (Univ.ContextSet.levels uctx.uctx_local) then + Some (l, not (Univ.LMap.mem l uctx.uctx_univ_variables)) + else None + | None -> None) + | _ -> None + let is_eq_sort s1 s2 = if Sorts.equal s1 s2 then None else let u1 = univ_of_sort s1 and u2 = univ_of_sort s2 in - if Univ.Universe.equal u1 u2 then None + if Univ.Universe.eq u1 u2 then None else Some (u1, u2) -let is_univ_var_or_set u = - Univ.is_univ_variable u || Univ.is_type0_univ u +let is_univ_var_or_set u = + not (Option.is_empty (Univ.universe_level u)) -let set_leq_sort evd s1 s2 = - match is_eq_sort s1 s2 with - | None -> evd - | Some (u1, u2) -> - match s1, s2 with - | Prop Null, Prop Pos -> evd - | Prop _, Prop _ -> - raise (Univ.UniverseInconsistency (Univ.Le, u1, u2,[])) - | Type u, Prop Pos -> - let cstr = Univ.enforce_leq u Univ.type0_univ Univ.empty_constraint in - add_constraints evd cstr - | Type _, Prop _ -> - raise (Univ.UniverseInconsistency (Univ.Le, u1, u2,[])) - | _, Type u -> - if is_univ_var_or_set u then - let cstr = Univ.enforce_leq u1 u2 Univ.empty_constraint in - add_constraints evd cstr - else raise (Univ.UniverseInconsistency (Univ.Le, u1, u2,[])) - -let is_univ_level_var us u = - match Univ.universe_level u with - | Some u -> Univ.UniverseLSet.mem u us - | None -> false +type universe_global = + | LocalUniv of Univ.universe_level + | GlobalUniv of Univ.universe_level + +type universe_kind = + | Algebraic of Univ.universe + | Variable of universe_global * bool -let set_eq_sort ({ universes = us; univ_cstrs = sm; } as d) s1 s2 = +let is_univ_level_var (us, cst) algs u = + match Univ.universe_level u with + | Some l -> + let glob = if Univ.LSet.mem l us then LocalUniv l else GlobalUniv l in + Variable (glob, Univ.LSet.mem l algs) + | None -> Algebraic u + +let normalize_universe evd = + let vars = ref evd.universes.uctx_univ_variables in + let normalize = Universes.normalize_universe_opt_subst vars in + normalize + +let memo_normalize_universe evd = + let vars = ref evd.universes.uctx_univ_variables in + let normalize = Universes.normalize_universe_opt_subst vars in + (fun () -> {evd with universes = {evd.universes with uctx_univ_variables = !vars}}), + normalize + +let normalize_universe_instance evd l = + let vars = ref evd.universes.uctx_univ_variables in + let normalize = Univ.level_subst_of (Universes.normalize_univ_variable_opt_subst vars) in + Univ.Instance.subst_fn normalize l + +let normalize_sort evars s = + match s with + | Prop _ -> s + | Type u -> + let u' = normalize_universe evars u in + if u' == u then s else Type u' + +(* FIXME inefficient *) +let set_eq_sort d s1 s2 = + let s1 = normalize_sort d s1 and s2 = normalize_sort d s2 in match is_eq_sort s1 s2 with | None -> d + | Some (u1, u2) -> add_universe_constraints d + (Univ.UniverseConstraints.singleton (u1,Univ.UEq,u2)) + +let has_lub evd u1 u2 = + (* let normalize = Universes.normalize_universe_opt_subst (ref univs.uctx_univ_variables) in *) + (* (\* let dref, norm = memo_normalize_universe d in *\) *) + (* let u1 = normalize u1 and u2 = normalize u2 in *) + if Univ.Universe.eq u1 u2 then evd + else add_universe_constraints evd + (Univ.UniverseConstraints.singleton (u1,Univ.ULub,u2)) + +let set_eq_level d u1 u2 = + add_constraints d (Univ.enforce_eq_level u1 u2 Univ.Constraint.empty) + +let set_leq_level d u1 u2 = + add_constraints d (Univ.enforce_leq_level u1 u2 Univ.Constraint.empty) + +let set_eq_instances d u1 u2 = + add_universe_constraints d + (Univ.enforce_eq_instances_univs false u1 u2 Univ.UniverseConstraints.empty) + +let set_leq_sort evd s1 s2 = + let s1 = normalize_sort evd s1 + and s2 = normalize_sort evd s2 in + match is_eq_sort s1 s2 with + | None -> evd | Some (u1, u2) -> match s1, s2 with - | Prop c, Type u when is_univ_level_var us u -> - add_constraints d (Univ.enforce_eq u1 u2 Univ.empty_constraint) - | Type u, Prop c when is_univ_level_var us u -> - add_constraints d (Univ.enforce_eq u1 u2 Univ.empty_constraint) - | Type u, Type v when (is_univ_level_var us u) || (is_univ_level_var us v) -> - add_constraints d (Univ.enforce_eq u1 u2 Univ.empty_constraint) - | Prop c, Type u when is_univ_var_or_set u && - Univ.lax_check_eq sm u1 u2 -> d - | Type u, Prop c when is_univ_var_or_set u && - Univ.lax_check_eq sm u1 u2 -> d - | Type u, Type v when is_univ_var_or_set u && is_univ_var_or_set v -> - add_constraints d (Univ.enforce_eq u1 u2 Univ.empty_constraint) - | _, _ -> raise (Univ.UniverseInconsistency (Univ.Eq, u1, u2, [])) - + | Prop c, Prop c' -> + if c == Null && c' == Pos then evd + else (raise (Univ.UniverseInconsistency (Univ.Le, u1, u2, []))) + | _, _ -> + add_universe_constraints evd (Univ.UniverseConstraints.singleton (u1,Univ.ULe,u2)) + +let check_eq evd s s' = + Univ.check_eq evd.universes.uctx_universes s s' + +let check_leq evd s s' = + Univ.check_leq evd.universes.uctx_universes s s' + +let subst_univs_context_with_def def usubst (ctx, cst) = + (Univ.LSet.diff ctx def, Univ.subst_univs_constraints usubst cst) + +let subst_univs_context usubst ctx = + subst_univs_context_with_def (Univ.LMap.universes usubst) (Univ.make_subst usubst) ctx + +let subst_univs_universes s g = + Univ.LMap.fold (fun u v g -> + (* Problem here: we might have instantiated an algebraic universe... *) + Univ.enforce_constraint (u, Univ.Eq, Option.get (Univ.Universe.level v)) g) s g + +let subst_univs_opt_universes s g = + Univ.LMap.fold (fun u v g -> + (* Problem here: we might have instantiated an algebraic universe... *) + match v with + | Some l -> + Univ.enforce_constraint (u, Univ.Eq, Option.get (Univ.Universe.level l)) g + | None -> g) s g + +let normalize_evar_universe_context_variables uctx = + let normalized_variables, undef, def, subst = + Universes.normalize_univ_variables uctx.uctx_univ_variables + in + let ctx_local = subst_univs_context_with_def def (Univ.make_subst subst) uctx.uctx_local in + (* let univs = subst_univs_universes subst uctx.uctx_universes in *) + let ctx_local', univs = Universes.refresh_constraints (Global.universes ()) ctx_local in + subst, { uctx with uctx_local = ctx_local'; + uctx_univ_variables = normalized_variables; + uctx_universes = univs } + +(* let normvarsconstrkey = Profile.declare_profile "normalize_evar_universe_context_variables";; *) +(* let normalize_evar_universe_context_variables = *) +(* Profile.profile1 normvarsconstrkey normalize_evar_universe_context_variables;; *) + +let mark_undefs_as_rigid uctx = + let vars' = + Univ.LMap.fold (fun u v acc -> + if v == None && not (Univ.LSet.mem u uctx.uctx_univ_algebraic) + then acc else Univ.LMap.add u v acc) + uctx.uctx_univ_variables Univ.LMap.empty + in { uctx with uctx_univ_variables = vars' } + +let mark_undefs_as_nonalg uctx = + let vars' = + Univ.LMap.fold (fun u v acc -> + if v == None then Univ.LSet.remove u acc + else acc) + uctx.uctx_univ_variables uctx.uctx_univ_algebraic + in { uctx with uctx_univ_algebraic = vars' } + +let abstract_undefined_variables evd = + {evd with universes = mark_undefs_as_nonalg evd.universes} + +let refresh_undefined_univ_variables uctx = + let subst, ctx' = Universes.fresh_universe_context_set_instance uctx.uctx_local in + let alg = Univ.LSet.fold (fun u acc -> Univ.LSet.add (Univ.subst_univs_level_level subst u) acc) + uctx.uctx_univ_algebraic Univ.LSet.empty + in + let vars = + Univ.LMap.fold + (fun u v acc -> + Univ.LMap.add (Univ.subst_univs_level_level subst u) + (Option.map (Univ.subst_univs_level_universe subst) v) acc) + uctx.uctx_univ_variables Univ.LMap.empty + in + let uctx' = {uctx_local = ctx'; + uctx_postponed = Univ.UniverseConstraints.empty;(*FIXME*) + uctx_univ_variables = vars; uctx_univ_algebraic = alg; + uctx_universes = Univ.initial_universes} in + uctx', subst + +let refresh_undefined_universes evd = + let uctx', subst = refresh_undefined_univ_variables evd.universes in + let evd' = cmap (subst_univs_level_constr subst) {evd with universes = uctx'} in + evd', subst + +let constraints_universes c = + Univ.Constraint.fold (fun (l',d,r') acc -> Univ.LSet.add l' (Univ.LSet.add r' acc)) + c Univ.LSet.empty + +let is_undefined_universe_variable l vars = + try (match Univ.LMap.find l vars with + | Some u -> false + | None -> true) + with Not_found -> false + +let normalize_evar_universe_context uctx = + let rec fixpoint uctx = + let ((vars',algs'), us') = + Universes.normalize_context_set uctx.uctx_local uctx.uctx_univ_variables + uctx.uctx_univ_algebraic + in + if Univ.LSet.equal (fst us') (fst uctx.uctx_local) then + uctx + else + let us', universes = Universes.refresh_constraints (Global.universes ()) us' in + (* let universes = subst_univs_opt_universes vars' uctx.uctx_universes in *) + let postponed = + Univ.subst_univs_universe_constraints (Universes.make_opt_subst vars') + uctx.uctx_postponed + in + let uctx' = + { uctx_local = us'; + uctx_univ_variables = vars'; + uctx_univ_algebraic = algs'; + uctx_postponed = postponed; + uctx_universes = universes} + in fixpoint uctx' + in fixpoint uctx + +let nf_univ_variables evd = + let subst, uctx' = normalize_evar_universe_context_variables evd.universes in + let evd' = {evd with universes = uctx'} in + evd', subst + +let normalize_univ_level fullsubst u = + try Univ.LMap.find u fullsubst + with Not_found -> Univ.Universe.make u + +let nf_constraints evd = + let subst, uctx' = normalize_evar_universe_context_variables evd.universes in + let uctx' = normalize_evar_universe_context uctx' in + {evd with universes = uctx'} + +(* let nfconstrkey = Profile.declare_profile "nf_constraints";; *) +(* let nf_constraints = Profile.profile1 nfconstrkey nf_constraints;; *) + +let universes evd = evd.universes.uctx_universes + +(* Conversion w.r.t. an evar map and its local universes. *) + +let conversion_gen env evd pb t u = + match pb with + | Reduction.CONV -> + Reduction.trans_conv_universes + full_transparent_state ~evars:(existential_opt_value evd) env + evd.universes.uctx_universes t u + | Reduction.CUMUL -> Reduction.trans_conv_leq_universes + full_transparent_state ~evars:(existential_opt_value evd) env + evd.universes.uctx_universes t u + +(* let conversion_gen_key = Profile.declare_profile "conversion_gen" *) +(* let conversion_gen = Profile.profile5 conversion_gen_key conversion_gen *) + +let conversion env d pb t u = + conversion_gen env d pb t u; d + +let test_conversion env d pb t u = + try conversion_gen env d pb t u; true + with _ -> false + (**********************************************************) (* Accessing metas *) @@ -691,7 +1284,6 @@ let set_metas evd metas = { defn_evars = evd.defn_evars; undf_evars = evd.undf_evars; universes = evd.universes; - univ_cstrs = evd.univ_cstrs; conv_pbs = evd.conv_pbs; last_mods = evd.last_mods; metas; @@ -787,9 +1379,12 @@ let meta_with_name evd id = (str "Binder name \"" ++ pr_id id ++ strbrk "\" occurs more than once in clause.") +let clear_metas evd = {evd with metas = Metamap.empty} + let meta_merge evd1 evd2 = let metas = Metamap.fold Metamap.add evd1.metas evd2.metas in - set_metas evd2 metas + let universes = union_evar_universe_context evd2.universes evd1.universes in + {evd2 with universes; metas; } type metabinding = metavariable * constr * instance_status @@ -907,7 +1502,7 @@ let pr_evar_source = function | Evar_kinds.ImplicitArg (c,(n,ido),b) -> let id = Option.get ido in str "parameter " ++ pr_id id ++ spc () ++ str "of" ++ - spc () ++ print_constr (constr_of_global c) + spc () ++ print_constr (printable_constr_of_global c) | Evar_kinds.InternalHole -> str "internal placeholder" | Evar_kinds.TomatchTypeParameter (ind,n) -> pr_nth n ++ str " argument of type " ++ print_constr (mkInd ind) @@ -989,6 +1584,16 @@ let evar_dependency_closure n sigma = let has_no_evar sigma = EvMap.is_empty sigma.defn_evars && EvMap.is_empty sigma.undf_evars +let pr_evar_universe_context ctx = + if is_empty_evar_universe_context ctx then mt () + else + (str"UNIVERSES:"++brk(0,1)++ h 0 (Univ.pr_universe_context_set ctx.uctx_local) ++ fnl () ++ + str"POSTPONED CONSTRAINTS:"++brk(0,1)++ + h 0 (Univ.UniverseConstraints.pr ctx.uctx_postponed) ++ fnl () ++ + str"ALGEBRAIC UNIVERSES:"++brk(0,1)++h 0 (Univ.LSet.pr ctx.uctx_univ_algebraic) ++ fnl() ++ + str"UNDEFINED UNIVERSES:"++brk(0,1)++ + h 0 (Universes.pr_universe_opt_subst ctx.uctx_univ_variables)) + let print_env_short env = let pr_body n = function | None -> pr_name n @@ -1012,17 +1617,9 @@ let pr_evar_constraints pbs = prlist_with_sep fnl pr_evconstr pbs let pr_evar_map_gen pr_evars sigma = - let { universes = uvs; univ_cstrs = univs; } = sigma in + let { universes = uvs } = sigma in let evs = if has_no_evar sigma then mt () else pr_evars sigma - and svs = - if Univ.UniverseLSet.is_empty uvs then mt () - else str "UNIVERSE VARIABLES:" ++ brk (0, 1) ++ - h 0 (prlist_with_sep fnl Univ.pr_uni_level - (Univ.UniverseLSet.elements uvs)) ++ fnl () - and cs = - if Univ.is_initial_universes univs then mt () - else str "UNIVERSES:" ++ brk (0, 1) ++ - h 0 (Univ.pr_universes univs) ++ fnl () + and svs = pr_evar_universe_context uvs and cstrs = if List.is_empty sigma.conv_pbs then mt () else @@ -1033,7 +1630,7 @@ let pr_evar_map_gen pr_evars sigma = else str "METAS:" ++ brk (0, 1) ++ pr_meta_map sigma.metas in - evs ++ svs ++ cs ++ cstrs ++ metas + evs ++ svs ++ cstrs ++ metas let pr_evar_list l = let pr (ev, evi) = diff --git a/pretyping/evd.mli b/pretyping/evd.mli index 55bce05de..18d68bebf 100644 --- a/pretyping/evd.mli +++ b/pretyping/evd.mli @@ -112,6 +112,9 @@ val evar_filter : evar_info -> Filter.t val evar_env : evar_info -> env val evar_filtered_env : evar_info -> env +val map_evar_body : (constr -> constr) -> evar_body -> evar_body +val map_evar_info : (constr -> constr) -> evar_info -> evar_info + (** {6 Unification state} **) type evar_map @@ -125,6 +128,10 @@ val progress_evar_map : evar_map -> evar_map -> bool val empty : evar_map (** The empty evar map. *) +val from_env : ?ctx:Univ.universe_context_set -> env -> evar_map +(** The empty evar map with given universe context, taking its initial + universes from env. *) + val is_empty : evar_map -> bool (** Whether an evarmap is empty. *) @@ -174,6 +181,17 @@ val define : evar -> constr -> evar_map -> evar_map {- All the evars present in the constr should be present in the evar map.} } *) +val cmap : (constr -> constr) -> evar_map -> evar_map +(** Map the function on all terms in the evar map. *) + +val diff : evar_map -> evar_map -> evar_map +(** [diff ext orig] assuming [ext] is an extension of [orig], + return an evar map containing just the extension *) + +val merge : evar_map -> evar_map -> evar_map +(** [merge orig ext] assuming [ext] is an extension of [orig], + return an evar map containing the union of the two maps *) + val is_evar : evar_map -> evar -> bool (** Alias for {!mem}. *) @@ -208,7 +226,7 @@ val instantiate_evar_array : evar_info -> constr -> constr array -> constr val subst_evar_defs_light : substitution -> evar_map -> evar_map (** Assume empty universe constraints in [evar_map] and [conv_pbs] *) -val evars_reset_evd : ?with_conv_pbs:bool -> evar_map -> evar_map -> evar_map +val evars_reset_evd : ?with_conv_pbs:bool -> ?with_univs:bool -> evar_map -> evar_map -> evar_map (** spiwack: this function seems to somewhat break the abstraction. *) (** {6 Misc} *) @@ -245,6 +263,13 @@ val whd_sort_variable : evar_map -> constr -> constr val set_leq_sort : evar_map -> sorts -> sorts -> evar_map val set_eq_sort : evar_map -> sorts -> sorts -> evar_map +exception UniversesDiffer + +val add_universe_constraints : evar_map -> Univ.universe_constraints -> evar_map +(** Add the given universe unification constraints to the evar map. + @raises UniversesDiffer in case a first-order unification fails. + @raises UniverseInconsistency +*) (** {5 Enriching with evar maps} *) type 'a sigma = { @@ -353,6 +378,8 @@ val meta_declare : val meta_assign : metavariable -> constr * instance_status -> evar_map -> evar_map val meta_reassign : metavariable -> constr * instance_status -> evar_map -> evar_map +val clear_metas : evar_map -> evar_map + (** [meta_merge evd1 evd2] returns [evd2] extended with the metas of [evd1] *) val meta_merge : evar_map -> evar_map -> evar_map @@ -366,6 +393,106 @@ val subst_defined_metas : metabinding list -> constr -> constr option (** {5 FIXME: Nothing to do here} *) +(********************************************************* + Sort/universe variables *) + +(** Rigid or flexible universe variables *) + +type rigid = + | UnivRigid + | UnivFlexible of bool (** Is substitution by an algebraic ok? *) + +val univ_rigid : rigid +val univ_flexible : rigid +val univ_flexible_alg : rigid + +(** The universe context associated to an evar map *) +type evar_universe_context + +type 'a in_evar_universe_context = 'a * evar_universe_context + +val evar_universe_context_set : evar_universe_context -> Univ.universe_context_set +val evar_context_universe_context : evar_universe_context -> Univ.universe_context +val evar_universe_context_of : Univ.universe_context_set -> evar_universe_context +val empty_evar_universe_context : evar_universe_context +val union_evar_universe_context : evar_universe_context -> evar_universe_context -> + evar_universe_context +val evar_universe_context_subst : evar_universe_context -> Universes.universe_opt_subst + +val universes : evar_map -> Univ.universes + +val add_constraints_context : evar_universe_context -> + Univ.constraints -> evar_universe_context + +val normalize_evar_universe_context_variables : evar_universe_context -> + Univ.universe_subst in_evar_universe_context + +val normalize_evar_universe_context : evar_universe_context -> + evar_universe_context + +val new_univ_variable : rigid -> evar_map -> evar_map * Univ.universe +val new_sort_variable : rigid -> evar_map -> evar_map * sorts +val make_flexible_variable : evar_map -> bool -> Univ.universe_level -> evar_map +val is_sort_variable : evar_map -> sorts -> (Univ.universe_level * bool) option +(** [is_sort_variable evm s] returns [Some (u, is_rigid)] or [None] if [s] is + not a sort variable declared in [evm] *) +val whd_sort_variable : evar_map -> constr -> constr +(* val normalize_universe_level : evar_map -> Univ.universe_level -> Univ.universe_level *) +val normalize_universe : evar_map -> Univ.universe -> Univ.universe +val normalize_universe_instance : evar_map -> Univ.universe_instance -> Univ.universe_instance + +val set_leq_sort : evar_map -> sorts -> sorts -> evar_map +val set_eq_sort : evar_map -> sorts -> sorts -> evar_map +val has_lub : evar_map -> Univ.universe -> Univ.universe -> evar_map +val set_eq_level : evar_map -> Univ.universe_level -> Univ.universe_level -> evar_map +val set_leq_level : evar_map -> Univ.universe_level -> Univ.universe_level -> evar_map +val set_eq_instances : evar_map -> Univ.universe_instance -> Univ.universe_instance -> evar_map + +val check_eq : evar_map -> Univ.universe -> Univ.universe -> bool +val check_leq : evar_map -> Univ.universe -> Univ.universe -> bool + +val evar_universe_context : evar_map -> evar_universe_context +val get_universe_context_set : evar_map -> Univ.universe_context_set +val universe_context : evar_map -> Univ.universe_context +val universe_subst : evar_map -> Universes.universe_opt_subst +val universes : evar_map -> Univ.universes + + +val merge_universe_context : evar_map -> evar_universe_context -> evar_map + +val merge_context_set : rigid -> evar_map -> Univ.universe_context_set -> evar_map + +val with_context_set : rigid -> evar_map -> 'a Univ.in_universe_context_set -> evar_map * 'a + +val nf_univ_variables : evar_map -> evar_map * Univ.universe_subst +val abstract_undefined_variables : evar_map -> evar_map + +val refresh_undefined_universes : evar_map -> evar_map * Univ.universe_level_subst + +val nf_constraints : evar_map -> evar_map + +(** Polymorphic universes *) + +val fresh_sort_in_family : env -> evar_map -> sorts_family -> evar_map * sorts +val fresh_constant_instance : env -> evar_map -> constant -> evar_map * pconstant +val fresh_inductive_instance : env -> evar_map -> inductive -> evar_map * pinductive +val fresh_constructor_instance : env -> evar_map -> constructor -> evar_map * pconstructor + +val fresh_global : ?rigid:rigid -> env -> evar_map -> Globnames.global_reference -> evar_map * constr + +(******************************************************************** + Conversion w.r.t. an evar map: might generate universe unifications + that are kept in the evarmap. + Raises [NotConvertible]. *) + +val conversion : env -> evar_map -> conv_pb -> constr -> constr -> evar_map + +(** This one forgets about the assignemts of universes. *) +val test_conversion : env -> evar_map -> conv_pb -> constr -> constr -> bool + +(******************************************************************** + constr with holes *) + type open_constr = evar_map * constr (** Partially constructed constrs. *) @@ -380,6 +507,7 @@ val pr_evar_map : int option -> evar_map -> Pp.std_ppcmds val pr_evar_map_filter : (Evar.t -> evar_info -> bool) -> evar_map -> Pp.std_ppcmds val pr_metaset : Metaset.t -> Pp.std_ppcmds +val pr_evar_universe_context : evar_universe_context -> Pp.std_ppcmds (** {5 Deprecated functions} *) diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml index f1e38d0f8..73bb343ee 100644 --- a/pretyping/glob_ops.ml +++ b/pretyping/glob_ops.ml @@ -61,7 +61,7 @@ let cast_type_eq eq t1 t2 = match t1, t2 with | _ -> false let rec glob_constr_eq c1 c2 = match c1, c2 with -| GRef (_, gr1), GRef (_, gr2) -> eq_gr gr1 gr2 +| GRef (_, gr1, _), GRef (_, gr2, _) -> eq_gr gr1 gr2 | GVar (_, id1), GVar (_, id2) -> Id.equal id1 id2 | GEvar (_, ev1, arg1), GEvar (_, ev2, arg2) -> Evar.equal ev1 ev2 && @@ -156,6 +156,9 @@ let map_glob_constr_left_to_right f = function let comp2 = Util.List.map_left (fun (tm,x) -> (f tm,x)) tml in let comp3 = Util.List.map_left (fun (loc,idl,p,c) -> (loc,idl,p,f c)) pl in GCases (loc,sty,comp1,comp2,comp3) + | GProj (loc,p,c) -> + let comp1 = f c in + GProj (loc,p,comp1) | GLetTuple (loc,nal,(na,po),b,c) -> let comp1 = Option.map f po in let comp2 = f b in @@ -183,6 +186,7 @@ let fold_glob_constr f acc = let rec fold acc = function | GVar _ -> acc | GApp (_,c,args) -> List.fold_left fold (fold acc c) args + | GProj (_,p,c) -> fold acc c | GLambda (_,_,_,b,c) | GProd (_,_,_,b,c) | GLetIn (_,_,b,c) -> fold (fold acc b) c | GCases (_,_,rtntypopt,tml,pl) -> @@ -221,6 +225,7 @@ let occur_glob_constr id = let rec occur = function | GVar (loc,id') -> Id.equal id id' | GApp (loc,f,args) -> (occur f) || (List.exists occur args) + | GProj (loc,p,c) -> occur c | GLambda (loc,na,bk,ty,c) -> (occur ty) || (not (same_id na id) && (occur c)) | GProd (loc,na,bk,ty,c) -> @@ -270,6 +275,7 @@ let free_glob_vars = let rec vars bounded vs = function | GVar (loc,id') -> if Id.Set.mem id' bounded then vs else Id.Set.add id' vs | GApp (loc,f,args) -> List.fold_left (vars bounded) vs (f::args) + | GProj (loc,p,c) -> vars bounded vs c | GLambda (loc,na,_,ty,c) | GProd (loc,na,_,ty,c) | GLetIn (loc,na,ty,c) -> let vs' = vars bounded vs ty in let bounded' = add_name_to_ids bounded na in @@ -326,11 +332,12 @@ let free_glob_vars = let loc_of_glob_constr = function - | GRef (loc,_) -> loc + | GRef (loc,_,_) -> loc | GVar (loc,_) -> loc | GEvar (loc,_,_) -> loc | GPatVar (loc,_) -> loc | GApp (loc,_,_) -> loc + | GProj (loc,p,c) -> loc | GLambda (loc,_,_,_,_) -> loc | GProd (loc,_,_,_,_) -> loc | GLetIn (loc,_,_,_) -> loc @@ -354,18 +361,18 @@ let rec cases_pattern_of_glob_constr na = function | Anonymous -> PatVar (loc,Name id) end | GHole (loc,_,_) -> PatVar (loc,na) - | GRef (loc,ConstructRef cstr) -> + | GRef (loc,ConstructRef cstr,_) -> PatCstr (loc,cstr,[],na) - | GApp (loc,GRef (_,ConstructRef cstr),l) -> + | GApp (loc,GRef (_,ConstructRef cstr,_),l) -> PatCstr (loc,cstr,List.map (cases_pattern_of_glob_constr Anonymous) l,na) | _ -> raise Not_found (* Turn a closed cases pattern into a glob_constr *) let rec glob_constr_of_closed_cases_pattern_aux = function | PatCstr (loc,cstr,[],Anonymous) -> - GRef (loc,ConstructRef cstr) + GRef (loc,ConstructRef cstr,None) | PatCstr (loc,cstr,l,Anonymous) -> - let ref = GRef (loc,ConstructRef cstr) in + let ref = GRef (loc,ConstructRef cstr,None) in GApp (loc,ref, List.map glob_constr_of_closed_cases_pattern_aux l) | _ -> raise Not_found diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml index bf9fd8a10..35a9cbdb2 100644 --- a/pretyping/indrec.ml +++ b/pretyping/indrec.ml @@ -33,7 +33,7 @@ type dep_flag = bool (* Errors related to recursors building *) type recursion_scheme_error = - | NotAllowedCaseAnalysis of (*isrec:*) bool * sorts * inductive + | NotAllowedCaseAnalysis of (*isrec:*) bool * sorts * pinductive | NotMutualInScheme of inductive * inductive exception RecursionSchemeError of recursion_scheme_error @@ -49,16 +49,16 @@ let mkLambda_string s t c = mkLambda (Name (Id.of_string s), t, c) (* Building case analysis schemes *) (* Christine Paulin, 1996 *) -let mis_make_case_com dep env sigma ind (mib,mip as specif) kind = - let lnamespar = List.map - (fun (n, c, t) -> (n, c, Termops.refresh_universes t)) +let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind = + let usubst = Inductive.make_inductive_subst mib u in + let lnamespar = Vars.subst_univs_context usubst mib.mind_params_ctxt in if not (Sorts.List.mem kind (elim_sorts specif)) then raise (RecursionSchemeError - (NotAllowedCaseAnalysis (false, Termops.new_sort_in_family kind, ind))); + (NotAllowedCaseAnalysis (false, fst (Universes.fresh_sort_in_family env kind), pind))); let ndepar = mip.mind_nrealargs_ctxt + 1 in @@ -66,7 +66,7 @@ let mis_make_case_com dep env sigma ind (mib,mip as specif) kind = (* mais pas trs joli ... (mais manque get_sort_of ce niveau) *) let env' = push_rel_context lnamespar env in - let indf = make_ind_family(ind, Termops.extended_rel_list 0 lnamespar) in + let indf = make_ind_family(pind, Termops.extended_rel_list 0 lnamespar) in let constrs = get_constructors env indf in let rec add_branch env k = @@ -78,7 +78,7 @@ let mis_make_case_com dep env sigma ind (mib,mip as specif) kind = let depind = build_dependent_inductive env indf' in let deparsign = (Anonymous,None,depind)::arsign in - let ci = make_case_info env ind RegularStyle in + let ci = make_case_info env (fst pind) RegularStyle in let pbody = appvect (mkRel (ndepar + nbprod), @@ -101,10 +101,13 @@ let mis_make_case_com dep env sigma ind (mib,mip as specif) kind = mkLambda_string "f" t (add_branch (push_rel (Anonymous, None, t) env) (k+1)) in - let typP = make_arity env' dep indf (Termops.new_sort_in_family kind) in - it_mkLambda_or_LetIn_name env + let sigma, s = Evd.fresh_sort_in_family env sigma kind in + let typP = make_arity env' dep indf s in + let c = + it_mkLambda_or_LetIn_name env (mkLambda_string "P" typP - (add_branch (push_rel (Anonymous,None,typP) env') 0)) lnamespar + (add_branch (push_rel (Anonymous,None,typP) env') 0)) lnamespar + in sigma, c (* check if the type depends recursively on one of the inductive scheme *) @@ -188,7 +191,7 @@ let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs = if dep then let realargs = List.rev_map (fun k -> mkRel (i-k)) li in let params = List.map (lift i) vargs in - let co = applist (mkConstruct cs.cs_cstr,params@realargs) in + let co = applist (mkConstructU cs.cs_cstr,params@realargs) in Reduction.beta_appvect c [|co|] else c in @@ -264,13 +267,14 @@ let context_chop k ctx = | (_, []) -> failwith "context_chop" in chop_aux [] (k,ctx) - (* Main function *) -let mis_make_indrec env sigma listdepkind mib = +let mis_make_indrec env sigma listdepkind mib u = let nparams = mib.mind_nparams in - let nparrec = mib. mind_nparams_rec in + let nparrec = mib.mind_nparams_rec in + let evdref = ref sigma in + let usubst = Inductive.make_inductive_subst mib u in let lnonparrec,lnamesparrec = - context_chop (nparams-nparrec) mib.mind_params_ctxt in + context_chop (nparams-nparrec) (Vars.subst_univs_context usubst mib.mind_params_ctxt) in let nrec = List.length listdepkind in let depPvec = Array.make mib.mind_ntypes (None : (bool * constr) option) in @@ -278,7 +282,7 @@ let mis_make_indrec env sigma listdepkind mib = let rec assign k = function | [] -> () - | (indi,mibi,mipi,dep,_)::rest -> + | ((indi,u),mibi,mipi,dep,_)::rest -> (Array.set depPvec (snd indi) (Some(dep,mkRel k)); assign (k-1) rest) in @@ -292,7 +296,7 @@ let mis_make_indrec env sigma listdepkind mib = let make_one_rec p = let makefix nbconstruct = let rec mrec i ln ltyp ldef = function - | (indi,mibi,mipi,dep,_)::rest -> + | ((indi,u),mibi,mipi,dep,_)::rest -> let tyi = snd indi in let nctyi = Array.length mipi.mind_consnames in (* nb constructeurs du type*) @@ -300,7 +304,7 @@ let mis_make_indrec env sigma listdepkind mib = (* arity in the context of the fixpoint, i.e. P1..P_nrec f1..f_nbconstruct *) let args = Termops.extended_rel_list (nrec+nbconstruct) lnamesparrec in - let indf = make_ind_family(indi,args) in + let indf = make_ind_family((indi,u),args) in let arsign,_ = get_arity env indf in let depind = build_dependent_inductive env indf in @@ -315,7 +319,7 @@ let mis_make_indrec env sigma listdepkind mib = P1..P_nrec f1..f_nbconstruct F_1..F_nrec a_1..a_nar x:I *) let args' = Termops.extended_rel_list (dect+nrec) lnamesparrec in let args'' = Termops.extended_rel_list ndepar lnonparrec in - let indf' = make_ind_family(indi,args'@args'') in + let indf' = make_ind_family((indi,u),args'@args'') in let branches = let constrs = get_constructors env indf' in @@ -325,7 +329,7 @@ let mis_make_indrec env sigma listdepkind mib = fi in Array.map3 - (make_rec_branch_arg env sigma + (make_rec_branch_arg env !evdref (nparrec,depPvec,larsign)) vecfi constrs (dest_subterms recargsvec.(tyi)) in @@ -389,7 +393,7 @@ let mis_make_indrec env sigma listdepkind mib = mrec 0 [] [] [] in let rec make_branch env i = function - | (indi,mibi,mipi,dep,_)::rest -> + | ((indi,u),mibi,mipi,dep,_)::rest -> let tyi = snd indi in let nconstr = Array.length mipi.mind_consnames in let rec onerec env j = @@ -399,10 +403,10 @@ let mis_make_indrec env sigma listdepkind mib = let recarg = (dest_subterms recargsvec.(tyi)).(j) in let recarg = recargpar@recarg in let vargs = Termops.extended_rel_list (nrec+i+j) lnamesparrec in - let cs = get_constructor (indi,mibi,mipi,vargs) (j+1) in + let cs = get_constructor ((indi,u),mibi,mipi,vargs) (j+1) in let p_0 = type_rec_branch - true dep env sigma (vargs,depPvec,i+j) tyi cs recarg + true dep env !evdref (vargs,depPvec,i+j) tyi cs recarg in mkLambda_string "f" p_0 (onerec (push_rel (Anonymous,None,p_0) env) (j+1)) @@ -411,9 +415,10 @@ let mis_make_indrec env sigma listdepkind mib = makefix i listdepkind in let rec put_arity env i = function - | (indi,_,_,dep,kinds)::rest -> - let indf = make_ind_family (indi, Termops.extended_rel_list i lnamesparrec) in - let typP = make_arity env dep indf (Termops.new_sort_in_family kinds) in + | ((indi,u),_,_,dep,kinds)::rest -> + let indf = make_ind_family ((indi,u), Termops.extended_rel_list i lnamesparrec) in + let s = Evarutil.evd_comb1 (Evd.fresh_sort_in_family env) evdref kinds in + let typP = make_arity env dep indf s in mkLambda_string "P" typP (put_arity (push_rel (Anonymous,None,typP) env) (i+1) rest) | [] -> @@ -421,36 +426,38 @@ let mis_make_indrec env sigma listdepkind mib = in (* Body on make_one_rec *) - let (indi,mibi,mipi,dep,kind) = List.nth listdepkind p in + let ((indi,u),mibi,mipi,dep,kind) = List.nth listdepkind p in if (mis_is_recursive_subset - (List.map (fun (indi,_,_,_,_) -> snd indi) listdepkind) + (List.map (fun ((indi,u),_,_,_,_) -> snd indi) listdepkind) mipi.mind_recargs) then let env' = push_rel_context lnamesparrec env in it_mkLambda_or_LetIn_name env (put_arity env' 0 listdepkind) lnamesparrec else - mis_make_case_com dep env sigma indi (mibi,mipi) kind + let evd', c = mis_make_case_com dep env !evdref (indi,u) (mibi,mipi) kind in + evdref := evd'; c in (* Body of mis_make_indrec *) - List.init nrec make_one_rec + !evdref, List.init nrec make_one_rec (**********************************************************************) (* This builds elimination predicate for Case tactic *) -let build_case_analysis_scheme env sigma ity dep kind = - let (mib,mip) = lookup_mind_specif env ity in - mis_make_case_com dep env sigma ity (mib,mip) kind +let build_case_analysis_scheme env sigma pity dep kind = + let (mib,mip) = lookup_mind_specif env (fst pity) in + mis_make_case_com dep env sigma pity (mib,mip) kind -let build_case_analysis_scheme_default env sigma ity kind = - let (mib,mip) = lookup_mind_specif env ity in - let dep = match inductive_sort_family mip with - | InProp -> false - | _ -> true - in - mis_make_case_com dep env sigma ity (mib,mip) kind +let is_in_prop mip = + match inductive_sort_family mip with + | InProp -> true + | _ -> false +let build_case_analysis_scheme_default env sigma pity kind = + let (mib,mip) = lookup_mind_specif env (fst pity) in + let dep = not (is_in_prop mip) in + mis_make_case_com dep env sigma pity (mib,mip) kind (**********************************************************************) (* [modify_sort_scheme s rec] replaces the sort of the scheme @@ -459,37 +466,25 @@ let build_case_analysis_scheme_default env sigma ity kind = let change_sort_arity sort = let rec drec a = match kind_of_term a with | Cast (c,_,_) -> drec c - | Prod (n,t,c) -> mkProd (n, t, drec c) - | LetIn (n,b,t,c) -> mkLetIn (n,b, t, drec c) - | Sort _ -> mkSort sort + | Prod (n,t,c) -> let s, c' = drec c in s, mkProd (n, t, c') + | LetIn (n,b,t,c) -> let s, c' = drec c in s, mkLetIn (n,b,t,c') + | Sort s -> s, mkSort sort | _ -> assert false in drec -(* [npar] is the number of expected arguments (then excluding letin's) *) -let modify_sort_scheme sort = - let rec drec npar elim = - match kind_of_term elim with - | Lambda (n,t,c) -> - if Int.equal npar 0 then - mkLambda (n, change_sort_arity sort t, c) - else - mkLambda (n, t, drec (npar-1) c) - | LetIn (n,b,t,c) -> mkLetIn (n,b,t,drec npar c) - | _ -> anomaly ~label:"modify_sort_scheme" (Pp.str "wrong elimination type") - in - drec - (* Change the sort in the type of an inductive definition, builds the corresponding eta-expanded term *) -let weaken_sort_scheme sort npars term = +let weaken_sort_scheme env evd set sort npars term ty = + let evdref = ref evd in let rec drec np elim = match kind_of_term elim with | Prod (n,t,c) -> if Int.equal np 0 then - let t' = change_sort_arity sort t in - mkProd (n, t', c), - mkLambda (n, t', mkApp(term,Termops.rel_vect 0 (npars+1))) + let osort, t' = change_sort_arity sort t in + evdref := (if set then Evd.set_eq_sort else Evd.set_leq_sort) !evdref sort osort; + mkProd (n, t', c), + mkLambda (n, t', mkApp(term,Termops.rel_vect 0 (npars+1))) else let c',term' = drec (np-1) c in mkProd (n, t, c'), mkLambda (n, t, term') @@ -497,7 +492,8 @@ let weaken_sort_scheme sort npars term = mkLetIn (n,b,t,c'), mkLetIn (n,b,t,term') | _ -> anomaly ~label:"weaken_sort_scheme" (Pp.str "wrong elimination type") in - drec npars + let ty, term = drec npars ty in + !evdref, ty, term (**********************************************************************) (* Interface to build complex Scheme *) @@ -506,11 +502,12 @@ let weaken_sort_scheme sort npars term = let check_arities listdepkind = let _ = List.fold_left - (fun ln ((_,ni as mind),mibi,mipi,dep,kind) -> + (fun ln (((_,ni as mind),u),mibi,mipi,dep,kind) -> let kelim = elim_sorts (mibi,mipi) in if not (Sorts.List.mem kind kelim) then raise (RecursionSchemeError - (NotAllowedCaseAnalysis (true, Termops.new_sort_in_family kind,mind))) + (NotAllowedCaseAnalysis (true, fst (Universes.fresh_sort_in_family (Global.env ()) + kind),(mind,u)))) else if Int.List.mem ni ln then raise (RecursionSchemeError (NotMutualInScheme (mind,mind))) else ni::ln) @@ -518,28 +515,29 @@ let check_arities listdepkind = in true let build_mutual_induction_scheme env sigma = function - | (mind,dep,s)::lrecspec -> + | ((mind,u),dep,s)::lrecspec -> let (mib,mip) = Global.lookup_inductive mind in let (sp,tyi) = mind in let listdepkind = - (mind,mib,mip,dep,s):: + ((mind,u),mib,mip,dep,s):: (List.map - (function (mind',dep',s') -> + (function ((mind',u'),dep',s') -> let (sp',_) = mind' in if eq_mind sp sp' then let (mibi',mipi') = lookup_mind_specif env mind' in - (mind',mibi',mipi',dep',s') + ((mind',u'),mibi',mipi',dep',s') else raise (RecursionSchemeError (NotMutualInScheme (mind,mind')))) lrecspec) in let _ = check_arities listdepkind in - mis_make_indrec env sigma listdepkind mib + mis_make_indrec env sigma listdepkind mib u | _ -> anomaly (Pp.str "build_induction_scheme expects a non empty list of inductive types") -let build_induction_scheme env sigma ind dep kind = - let (mib,mip) = lookup_mind_specif env ind in - List.hd (mis_make_indrec env sigma [(ind,mib,mip,dep,kind)] mib) +let build_induction_scheme env sigma pind dep kind = + let (mib,mip) = lookup_mind_specif env (fst pind) in + let sigma, l = mis_make_indrec env sigma [(pind,mib,mip,dep,kind)] mib (snd pind) in + sigma, List.hd l (*s Eliminations. *) @@ -564,11 +562,11 @@ let lookup_eliminator ind_sp s = try let cst =Global.constant_of_delta_kn (make_kn mp dp (Label.of_id id)) in let _ = Global.lookup_constant cst in - mkConst cst + ConstRef cst with Not_found -> (* Then try to get a user-defined eliminator in some other places *) (* using short name (e.g. for "eq_rec") *) - try constr_of_global (Nametab.locate (qualid_of_ident id)) + try Nametab.locate (qualid_of_ident id) with Not_found -> errorlabstrm "default_elim" (strbrk "Cannot find the elimination combinator " ++ diff --git a/pretyping/indrec.mli b/pretyping/indrec.mli index 6bcfac20e..54827281a 100644 --- a/pretyping/indrec.mli +++ b/pretyping/indrec.mli @@ -14,7 +14,7 @@ open Evd (** Errors related to recursors building *) type recursion_scheme_error = - | NotAllowedCaseAnalysis of (*isrec:*) bool * sorts * inductive + | NotAllowedCaseAnalysis of (*isrec:*) bool * sorts * pinductive | NotMutualInScheme of inductive * inductive exception RecursionSchemeError of recursion_scheme_error @@ -25,41 +25,38 @@ type dep_flag = bool (** Build a case analysis elimination scheme in some sort family *) -val build_case_analysis_scheme : env -> evar_map -> inductive -> - dep_flag -> sorts_family -> constr +val build_case_analysis_scheme : env -> evar_map -> pinductive -> + dep_flag -> sorts_family -> evar_map * constr (** Build a dependent case elimination predicate unless type is in Prop *) -val build_case_analysis_scheme_default : env -> evar_map -> inductive -> - sorts_family -> constr +val build_case_analysis_scheme_default : env -> evar_map -> pinductive -> + sorts_family -> evar_map * constr (** Builds a recursive induction scheme (Peano-induction style) in the same sort family as the inductive family; it is dependent if not in Prop *) -val build_induction_scheme : env -> evar_map -> inductive -> - dep_flag -> sorts_family -> constr +val build_induction_scheme : env -> evar_map -> pinductive -> + dep_flag -> sorts_family -> evar_map * constr (** Builds mutual (recursive) induction schemes *) val build_mutual_induction_scheme : - env -> evar_map -> (inductive * dep_flag * sorts_family) list -> constr list + env -> evar_map -> (pinductive * dep_flag * sorts_family) list -> evar_map * constr list (** Scheme combinators *) -(** [modify_sort_scheme s n c] modifies the quantification sort of - scheme c whose predicate is abstracted at position [n] of [c] *) +(** [weaken_sort_scheme env sigma eq s n c t] derives by subtyping from [c:t] + whose conclusion is quantified on [Type i] at position [n] of [t] a + scheme quantified on sort [s]. [set] asks for [s] be declared equal to [i], + otherwise just less or equal to [i]. *) -val modify_sort_scheme : sorts -> int -> constr -> constr - -(** [weaken_sort_scheme s n c t] derives by subtyping from [c:t] - whose conclusion is quantified on [Type] at position [n] of [t] a - scheme quantified on sort [s] *) - -val weaken_sort_scheme : sorts -> int -> constr -> types -> constr * types +val weaken_sort_scheme : env -> evar_map -> bool -> sorts -> int -> constr -> types -> + evar_map * types * constr (** Recursor names utilities *) -val lookup_eliminator : inductive -> sorts_family -> constr +val lookup_eliminator : inductive -> sorts_family -> Globnames.global_reference val elimination_suffix : sorts_family -> string val make_elimination_ident : Id.t -> sorts_family -> Id.t diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index 775795ce0..7e4d37b2e 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -19,32 +19,38 @@ open Declarations open Declareops open Environ open Reductionops +open Inductive (* The following three functions are similar to the ones defined in Inductive, but they expect an env *) -let type_of_inductive env ind = +let type_of_inductive env (ind,u) = let specif = Inductive.lookup_mind_specif env ind in - Inductive.type_of_inductive env specif + Inductive.type_of_inductive env (specif,u) (* Return type as quoted by the user *) -let type_of_constructor env cstr = +let type_of_constructor env (cstr,u) = let specif = Inductive.lookup_mind_specif env (inductive_of_constructor cstr) in - Inductive.type_of_constructor cstr specif + Inductive.type_of_constructor (cstr,u) specif + +let type_of_constructor_in_ctx env cstr = + let specif = + Inductive.lookup_mind_specif env (inductive_of_constructor cstr) in + Inductive.type_of_constructor_in_ctx cstr specif (* Return constructor types in user form *) -let type_of_constructors env ind = +let type_of_constructors env (ind,u as indu) = let specif = Inductive.lookup_mind_specif env ind in - Inductive.type_of_constructors ind specif + Inductive.type_of_constructors indu specif (* Return constructor types in normal form *) -let arities_of_constructors env ind = +let arities_of_constructors env (ind,u as indu) = let specif = Inductive.lookup_mind_specif env ind in - Inductive.arities_of_constructors ind specif + Inductive.arities_of_constructors indu specif (* [inductive_family] = [inductive_instance] applied to global parameters *) -type inductive_family = inductive * constr list +type inductive_family = pinductive * constr list let make_ind_family (mis, params) = (mis,params) let dest_ind_family (mis,params) = (mis,params) @@ -71,7 +77,7 @@ let lift_inductive_type n = liftn_inductive_type n 1 let substnl_ind_type l n = map_inductive_type (substnl l n) let mkAppliedInd (IndType ((ind,params), realargs)) = - applist (mkInd ind,params@realargs) + applist (mkIndU ind,params@realargs) (* Does not consider imbricated or mutually recursive types *) let mis_is_recursive_subset listind rarg = @@ -88,13 +94,14 @@ let mis_is_recursive (ind,mib,mip) = mis_is_recursive_subset (List.interval 0 (mib.mind_ntypes - 1)) mip.mind_recargs -let mis_nf_constructor_type (ind,mib,mip) j = +let mis_nf_constructor_type ((ind,u),mib,mip) j = let specif = mip.mind_nf_lc and ntypes = mib.mind_ntypes and nconstr = Array.length mip.mind_consnames in - let make_Ik k = mkInd ((fst ind),ntypes-k-1) in + let make_Ik k = mkIndU (((fst ind),ntypes-k-1),u) in if j > nconstr then error "Not enough constructors in the type."; - substl (List.init ntypes make_Ik) specif.(j-1) + let univsubst = make_inductive_subst mib u in + substl (List.init ntypes make_Ik) (subst_univs_constr univsubst specif.(j-1)) (* Arity of constructors excluding parameters and local defs *) @@ -139,9 +146,10 @@ let constructor_nrealhyps (ind,j) = let (mib,mip) = Global.lookup_inductive ind in mip.mind_consnrealdecls.(j-1) -let get_full_arity_sign env ind = +let get_full_arity_sign env (ind,u) = let (mib,mip) = Inductive.lookup_mind_specif env ind in - mip.mind_arity_ctxt + let subst = Inductive.make_inductive_subst mib u in + Vars.subst_univs_context subst mip.mind_arity_ctxt let nconstructors ind = let (mib,mip) = Inductive.lookup_mind_specif (Global.env()) ind in @@ -164,6 +172,10 @@ let inductive_has_local_defs ind = let inductive_nparams ind = (fst (Global.lookup_inductive ind)).mind_nparams +let inductive_params_ctxt (ind,u) = + let (mib,mip) = Global.lookup_inductive ind in + Inductive.inductive_params_ctxt (mib,u) + let inductive_nargs ind = let (mib,mip) = Global.lookup_inductive ind in (rel_context_length (mib.mind_params_ctxt), mip.mind_nrealargs_ctxt) @@ -189,7 +201,7 @@ let make_case_info env ind style = (*s Useful functions *) type constructor_summary = { - cs_cstr : constructor; + cs_cstr : pconstructor; cs_params : constr list; cs_nargs : int; cs_args : rel_context; @@ -219,21 +231,21 @@ let instantiate_params t args sign = | _ -> anomaly ~label:"instantiate_params" (Pp.str "type, ctxt and args mismatch") in inst [] t (List.rev sign,args) -let get_constructor (ind,mib,mip,params) j = +let get_constructor ((ind,u as indu),mib,mip,params) j = assert (j <= Array.length mip.mind_consnames); - let typi = mis_nf_constructor_type (ind,mib,mip) j in + let typi = mis_nf_constructor_type (indu,mib,mip) j in let typi = instantiate_params typi params mib.mind_params_ctxt in let (args,ccl) = decompose_prod_assum typi in let (_,allargs) = decompose_app ccl in let vargs = List.skipn (List.length params) allargs in - { cs_cstr = ith_constructor_of_inductive ind j; + { cs_cstr = (ith_constructor_of_inductive ind j,u); cs_params = params; cs_nargs = rel_context_length args; cs_args = args; cs_concl_realargs = Array.of_list vargs } let get_constructors env (ind,params) = - let (mib,mip) = Inductive.lookup_mind_specif env ind in + let (mib,mip) = Inductive.lookup_mind_specif env (fst ind) in Array.init (Array.length mip.mind_consnames) (fun j -> get_constructor (ind,mib,mip,params) (j+1)) @@ -255,8 +267,9 @@ let instantiate_context sign args = | _ -> anomaly (Pp.str "Signature/instance mismatch in inductive family") in aux [] (List.rev sign,args) -let get_arity env (ind,params) = +let get_arity env ((ind,u),params) = let (mib,mip) = Inductive.lookup_mind_specif env ind in + let univsubst = make_inductive_subst mib u in let parsign = (* Dynamically detect if called with an instance of recursively uniform parameter only or also of non recursively uniform @@ -267,15 +280,17 @@ let get_arity env (ind,params) = snd (List.chop nnonrecparams mib.mind_params_ctxt) else parsign in + let parsign = Vars.subst_univs_context univsubst parsign in let arproperlength = List.length mip.mind_arity_ctxt - List.length parsign in let arsign,_ = List.chop arproperlength mip.mind_arity_ctxt in let subst = instantiate_context parsign params in + let arsign = Vars.subst_univs_context univsubst arsign in (substl_rel_context subst arsign, Inductive.inductive_sort_family mip) (* Functions to build standard types related to inductive *) let build_dependent_constructor cs = applist - (mkConstruct cs.cs_cstr, + (mkConstructU cs.cs_cstr, (List.map (lift cs.cs_nargs) cs.cs_params) @(extended_rel_list 0 cs.cs_args)) @@ -283,7 +298,7 @@ let build_dependent_inductive env ((ind, params) as indf) = let arsign,_ = get_arity env indf in let nrealargs = List.length arsign in applist - (mkInd ind, + (mkIndU ind, (List.map (lift nrealargs) params)@(extended_rel_list 0 arsign)) (* builds the arity of an elimination predicate in sort [s] *) @@ -328,18 +343,18 @@ let find_mrectype env sigma c = let find_rectype env sigma c = let (t, l) = decompose_app (whd_betadeltaiota env sigma c) in match kind_of_term t with - | Ind ind -> + | Ind (ind,u as indu) -> let (mib,mip) = Inductive.lookup_mind_specif env ind in if mib.mind_nparams > List.length l then raise Not_found; let (par,rargs) = List.chop mib.mind_nparams l in - IndType((ind, par),rargs) + IndType((indu, par),rargs) | _ -> raise Not_found let find_inductive env sigma c = let (t, l) = decompose_app (whd_betadeltaiota env sigma c) in match kind_of_term t with | Ind ind - when (fst (Inductive.lookup_mind_specif env ind)).mind_finite -> + when (fst (Inductive.lookup_mind_specif env (fst ind))).mind_finite -> (ind, l) | _ -> raise Not_found @@ -347,7 +362,7 @@ let find_coinductive env sigma c = let (t, l) = decompose_app (whd_betadeltaiota env sigma c) in match kind_of_term t with | Ind ind - when not (fst (Inductive.lookup_mind_specif env ind)).mind_finite -> + when not (fst (Inductive.lookup_mind_specif env (fst ind))).mind_finite -> (ind, l) | _ -> raise Not_found @@ -414,7 +429,7 @@ let set_pattern_names env ind brv = let type_case_branches_with_names env indspec p c = let (ind,args) = indspec in - let (mib,mip as specif) = Inductive.lookup_mind_specif env ind in + let (mib,mip as specif) = Inductive.lookup_mind_specif env (fst ind) in let nparams = mib.mind_nparams in let (params,realargs) = List.chop nparams args in let lbrty = Inductive.build_branches_type ind specif params p in @@ -422,7 +437,7 @@ let type_case_branches_with_names env indspec p c = let conclty = Reduction.beta_appvect p (Array.of_list (realargs@[c])) in (* Adjust names *) if is_elim_predicate_explicitly_dependent env p (ind,params) then - (set_pattern_names env ind lbrty, conclty) + (set_pattern_names env (fst ind) lbrty, conclty) else (lbrty, conclty) (* Type of Case predicates *) @@ -436,40 +451,9 @@ let arity_of_case_predicate env (ind,params) dep k = (* Inferring the sort of parameters of a polymorphic inductive type knowing the sort of the conclusion *) -(* Compute the inductive argument types: replace the sorts - that appear in the type of the inductive by the sort of the - conclusion, and the other ones by fresh universes. *) -let rec instantiate_universes env scl is = function - | (_,Some _,_ as d)::sign, exp -> - d :: instantiate_universes env scl is (sign, exp) - | d::sign, None::exp -> - d :: instantiate_universes env scl is (sign, exp) - | (na,None,ty)::sign, Some u::exp -> - let ctx,_ = Reduction.dest_arity env ty in - let s = - (* Does the sort of parameter [u] appear in (or equal) - the sort of inductive [is] ? *) - if univ_depends u is then - scl (* constrained sort: replace by scl *) - else - (* unconstriained sort: replace by fresh universe *) - new_Type_sort() in - (na,None,mkArity(ctx,s)):: instantiate_universes env scl is (sign, exp) - | sign, [] -> sign (* Uniform parameters are exhausted *) - | [], _ -> assert false - -(* Does not deal with universes, but only with Set/Type distinction *) -let type_of_inductive_knowing_conclusion env mip conclty = - match mip.mind_arity with - | Monomorphic s -> - s.mind_user_arity - | Polymorphic ar -> - let _,scl = Reduction.dest_arity env conclty in - let ctx = List.rev mip.mind_arity_ctxt in - let ctx = - instantiate_universes - env scl ar.poly_level (ctx,ar.poly_param_levels) in - mkArity (List.rev ctx,scl) +let type_of_inductive_knowing_conclusion env ((mib,mip),u) conclty = + let subst = Inductive.make_inductive_subst mib u in + subst_univs_constr subst mip.mind_arity.mind_user_arity (***********************************************) (* Guard condition *) @@ -490,7 +474,3 @@ let control_only_guard env c = iter_constr_with_full_binders push_rel iter env c in iter env c - -let subst_inductive subst (kn,i as ind) = - let kn' = Mod_subst.subst_ind subst kn in - if kn == kn' then ind else (kn',i) diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli index 204f506a6..39451ec05 100644 --- a/pretyping/inductiveops.mli +++ b/pretyping/inductiveops.mli @@ -16,19 +16,20 @@ open Evd (** The following three functions are similar to the ones defined in Inductive, but they expect an env *) -val type_of_inductive : env -> inductive -> types +val type_of_inductive : env -> pinductive -> types (** Return type as quoted by the user *) -val type_of_constructor : env -> constructor -> types -val type_of_constructors : env -> inductive -> types array +val type_of_constructor : env -> pconstructor -> types +val type_of_constructor_in_ctx : env -> constructor -> types Univ.in_universe_context +val type_of_constructors : env -> pinductive -> types array (** Return constructor types in normal form *) -val arities_of_constructors : env -> inductive -> types array +val arities_of_constructors : env -> pinductive -> types array (** An inductive type with its parameters *) type inductive_family -val make_ind_family : inductive * constr list -> inductive_family -val dest_ind_family : inductive_family -> inductive * constr list +val make_ind_family : inductive puniverses * constr list -> inductive_family +val dest_ind_family : inductive_family -> inductive puniverses * constr list val map_ind_family : (constr -> constr) -> inductive_family -> inductive_family val liftn_inductive_family : int -> int -> inductive_family -> inductive_family val lift_inductive_family : int -> inductive_family -> inductive_family @@ -49,7 +50,7 @@ val mis_is_recursive_subset : int list -> wf_paths -> bool val mis_is_recursive : inductive * mutual_inductive_body * one_inductive_body -> bool val mis_nf_constructor_type : - inductive * mutual_inductive_body * one_inductive_body -> int -> constr + pinductive * mutual_inductive_body * one_inductive_body -> int -> constr (** {6 Extract information from an inductive name} @@ -69,6 +70,7 @@ val inductive_nargs_env : env -> inductive -> int * int (** @return nb of params without letin *) val inductive_nparams : inductive -> int +val inductive_params_ctxt : pinductive -> rel_context (** @return param + args without letin *) val mis_constructor_nargs : constructor -> int @@ -88,14 +90,14 @@ val constructor_nrealhyps : constructor -> int val mis_constructor_has_local_defs : constructor -> bool val inductive_has_local_defs : inductive -> bool -val get_full_arity_sign : env -> inductive -> rel_context +val get_full_arity_sign : env -> pinductive -> rel_context val allowed_sorts : env -> inductive -> sorts_family list (** Extract information from an inductive family *) type constructor_summary = { - cs_cstr : constructor; (* internal name of the constructor *) + cs_cstr : pconstructor; (* internal name of the constructor plus universes *) cs_params : constr list; (* parameters of the constructor in current ctx *) cs_nargs : int; (* length of arguments signature (letin included) *) cs_args : rel_context; (* signature of the arguments (letin included) *) @@ -103,7 +105,7 @@ type constructor_summary = { } val lift_constructor : int -> constructor_summary -> constructor_summary val get_constructor : - inductive * mutual_inductive_body * one_inductive_body * constr list -> + pinductive * mutual_inductive_body * one_inductive_body * constr list -> int -> constructor_summary val get_arity : env -> inductive_family -> rel_context * sorts_family val get_constructors : env -> inductive_family -> constructor_summary array @@ -114,11 +116,11 @@ val make_arity : env -> bool -> inductive_family -> sorts -> types val build_branch_type : env -> bool -> constr -> constructor_summary -> types (** Raise [Not_found] if not given an valid inductive type *) -val extract_mrectype : constr -> inductive * constr list -val find_mrectype : env -> evar_map -> types -> inductive * constr list +val extract_mrectype : constr -> pinductive * constr list +val find_mrectype : env -> evar_map -> types -> pinductive * constr list val find_rectype : env -> evar_map -> types -> inductive_type -val find_inductive : env -> evar_map -> types -> inductive * constr list -val find_coinductive : env -> evar_map -> types -> inductive * constr list +val find_inductive : env -> evar_map -> types -> pinductive * constr list +val find_coinductive : env -> evar_map -> types -> pinductive * constr list (********************) @@ -127,7 +129,7 @@ val arity_of_case_predicate : env -> inductive_family -> bool -> sorts -> types val type_case_branches_with_names : - env -> inductive * constr list -> constr -> constr -> + env -> pinductive * constr list -> constr -> constr -> types array * types (** Annotation for cases *) @@ -140,9 +142,7 @@ i*) (********************) val type_of_inductive_knowing_conclusion : - env -> one_inductive_body -> types -> types + env -> Inductive.mind_specif puniverses -> types -> types (********************) val control_only_guard : env -> types -> unit - -val subst_inductive : Mod_subst.substitution -> inductive -> inductive diff --git a/pretyping/namegen.ml b/pretyping/namegen.ml index d4435489a..c6c21f025 100644 --- a/pretyping/namegen.ml +++ b/pretyping/namegen.ml @@ -76,9 +76,10 @@ let hdchar env c = | LetIn (_,_,_,c) -> hdrec (k+1) c | Cast (c,_,_) -> hdrec k c | App (f,l) -> hdrec k f - | Const kn -> lowercase_first_char (Label.to_id (con_label kn)) - | Ind x -> lowercase_first_char (basename_of_global (IndRef x)) - | Construct x -> lowercase_first_char (basename_of_global (ConstructRef x)) + | Proj (kn,_) + | Const (kn,_) -> lowercase_first_char (Label.to_id (con_label kn)) + | Ind (x,_) -> lowercase_first_char (basename_of_global (IndRef x)) + | Construct (x,_) -> lowercase_first_char (basename_of_global (ConstructRef x)) | Var id -> lowercase_first_char id | Sort s -> sort_hdchar s | Rel n -> diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index b635229cf..829fa106c 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -59,7 +59,7 @@ let find_rectype_a env c = (* Instantiate inductives and parameters in constructor type *) let type_constructor mind mib typ params = - let s = ind_subst mind mib in + let s = ind_subst mind mib Univ.Instance.empty (* FIXME *)in let ctyp = substl s typ in let nparams = Array.length params in if Int.equal nparams 0 then ctyp @@ -67,7 +67,7 @@ let type_constructor mind mib typ params = let _,ctyp = decompose_prod_n nparams ctyp in substl (List.rev (Array.to_list params)) ctyp -let construct_of_constr_notnative const env tag (mind, _ as ind) allargs = +let construct_of_constr_notnative const env tag (mind, _ as ind) u allargs = let mib,mip = lookup_mind_specif env ind in let nparams = mib.mind_nparams in let params = Array.sub allargs 0 nparams in @@ -80,14 +80,14 @@ let construct_of_constr_notnative const env tag (mind, _ as ind) allargs = with Not_found -> let i = invert_tag const tag mip.mind_reloc_tbl in let ctyp = type_constructor mind mib (mip.mind_nf_lc.(i-1)) params in - (mkApp(mkConstruct(ind,i), params), ctyp) + (mkApp(mkConstructU((ind,i),u), params), ctyp) let construct_of_constr const env tag typ = let t, l = app_type env typ in match kind_of_term t with - | Ind ind -> - construct_of_constr_notnative const env tag ind l + | Ind (ind,u) -> + construct_of_constr_notnative const env tag ind u l | _ -> assert false let construct_of_constr_const env tag typ = @@ -109,9 +109,9 @@ let build_branches_type env (mind,_ as _ind) mib mip params dep p = let codom = let papp = mkApp(lift (List.length decl) p,crealargs) in if dep then - let cstr = ith_constructor_of_inductive ind (i+1) in + let cstr = ith_constructor_of_inductive (fst ind) (i+1) in let relargs = Array.init carity (fun i -> mkRel (carity-i)) in - let dep_cstr = mkApp(mkApp(mkConstruct cstr,params),relargs) in + let dep_cstr = mkApp(mkApp(mkConstructU (cstr,snd ind),params),relargs) in mkApp(papp,[|dep_cstr|]) else papp in @@ -266,6 +266,9 @@ and nf_atom env atom = mkProd(n,dom,codom) | Ameta (mv,_) -> mkMeta mv | Aevar (ev,_) -> mkEvar ev + | Aproj(p,c) -> + let c = nf_accu env c in + mkProj(p,c) | _ -> fst (nf_atom_type env atom) and nf_atom_type env atom = @@ -274,17 +277,17 @@ and nf_atom_type env atom = let n = (nb_rel env - i) in mkRel n, type_of_rel env n | Aconstant cst -> - mkConst cst, Typeops.type_of_constant env cst + mkConst cst, fst (Typeops.type_of_constant env (cst,Univ.Instance.empty)) (* FIXME *) | Aind ind -> - mkInd ind, Inductiveops.type_of_inductive env ind + mkInd ind, Inductiveops.type_of_inductive env (ind,Univ.Instance.empty) | Asort s -> mkSort s, type_of_sort s | Avar id -> mkVar id, type_of_var env id | Acase(ans,accu,p,bs) -> let a,ta = nf_accu_type env accu in - let (mind,_ as ind),allargs = find_rectype_a env ta in - let (mib,mip) = Inductive.lookup_mind_specif env ind in + let ((mind,_),u as ind),allargs = find_rectype_a env ta in + let (mib,mip) = Inductive.lookup_mind_specif env (fst ind) in let nparams = mib.mind_nparams in let params,realargs = Array.chop nparams allargs in let pT = @@ -293,7 +296,7 @@ and nf_atom_type env atom = let pT = whd_betadeltaiota env pT in let dep, p = nf_predicate env ind mip params p pT in (* Calcul du type des branches *) - let btypes = build_branches_type env ind mib mip params dep p in + let btypes = build_branches_type env (fst ind) mib mip params dep p in (* calcul des branches *) let bsw = branch_of_switch (nb_rel env) ans bs in let mkbranch i v = @@ -336,6 +339,12 @@ and nf_atom_type env atom = | Ameta(mv,ty) -> let ty = nf_type env ty in mkMeta mv, ty + | Aproj(p,c) -> + let c,tc = nf_accu_type env c in + let cj = make_judge c tc in + let uj = Typeops.judge_of_projection env p cj in + uj.uj_val, uj.uj_type + and nf_predicate env ind mip params v pT = match kind_of_value v, kind_of_term pT with @@ -358,7 +367,7 @@ and nf_predicate env ind mip params v pT = let n = mip.mind_nrealargs in let rargs = Array.init n (fun i -> mkRel (n-i)) in let params = if Int.equal n 0 then params else Array.map (lift n) params in - let dom = mkApp(mkInd ind,Array.append params rargs) in + let dom = mkApp(mkIndU ind,Array.append params rargs) in let body = nf_type (push_rel (name,None,dom) env) vb in true, mkLambda(name,dom,body) | _, _ -> false, nf_type env v diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index cc13d342a..8557953cc 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -81,6 +81,7 @@ and rec_declaration_eq (n1, c1, r1) (n2, c2, r2) = let rec occur_meta_pattern = function | PApp (f,args) -> (occur_meta_pattern f) || (Array.exists occur_meta_pattern args) + | PProj (_,arg) -> occur_meta_pattern arg | PLambda (na,t,c) -> (occur_meta_pattern t) || (occur_meta_pattern c) | PProd (na,t,c) -> (occur_meta_pattern t) || (occur_meta_pattern c) | PLetIn (na,t,c) -> (occur_meta_pattern t) || (occur_meta_pattern c) @@ -105,6 +106,7 @@ let rec head_pattern_bound t = | PCase (_,p,c,br) -> head_pattern_bound c | PRef r -> r | PVar id -> VarRef id + | PProj (p,c) -> ConstRef p | PEvar _ | PRel _ | PMeta _ | PSoApp _ | PSort _ | PFix _ -> raise BoundPattern (* Perhaps they were arguments, but we don't beta-reduce *) @@ -112,9 +114,9 @@ let rec head_pattern_bound t = | PCoFix _ -> anomaly ~label:"head_pattern_bound" (Pp.str "not a type") let head_of_constr_reference c = match kind_of_term c with - | Const sp -> ConstRef sp - | Construct sp -> ConstructRef sp - | Ind sp -> IndRef sp + | Const (sp,_) -> ConstRef sp + | Construct (sp,_) -> ConstructRef sp + | Ind (sp,_) -> IndRef sp | Var id -> VarRef id | _ -> anomaly (Pp.str "Not a rigid reference") @@ -145,9 +147,11 @@ let pattern_of_constr sigma t = with | Some n -> PSoApp (n,Array.to_list (Array.map pattern_of_constr a)) | None -> PApp (pattern_of_constr f,Array.map (pattern_of_constr) a)) - | Const sp -> PRef (ConstRef (constant_of_kn(canonical_con sp))) - | Ind sp -> PRef (canonical_gr (IndRef sp)) - | Construct sp -> PRef (canonical_gr (ConstructRef sp)) + | Const (sp,u) -> PRef (ConstRef (constant_of_kn(canonical_con sp))) + | Ind (sp,u) -> PRef (canonical_gr (IndRef sp)) + | Construct (sp,u) -> PRef (canonical_gr (ConstructRef sp)) + | Proj (p, c) -> + PProj (constant_of_kn(canonical_con p), pattern_of_constr c) | Evar (evk,ctxt as ev) -> (match snd (Evd.evar_source evk sigma) with | Evar_kinds.MatchingVar (b,id) -> @@ -185,6 +189,7 @@ let map_pattern_with_binders g f l = function | PIf (c,b1,b2) -> PIf (f l c,f l b1,f l b2) | PCase (ci,po,p,pl) -> PCase (ci,f l po,f l p, List.map (fun (i,n,c) -> (i,n,f l c)) pl) + | PProj (p,pc) -> PProj (p, f l pc) (* Non recursive *) | (PVar _ | PEvar _ | PRel _ | PRef _ | PSort _ | PMeta _ (* Bound to terms *) @@ -240,6 +245,12 @@ let rec subst_pattern subst pat = | PVar _ | PEvar _ | PRel _ -> pat + | PProj (p,c) -> + let p',t = subst_global subst (ConstRef p) in + let p' = destConstRef p' in + let c' = subst_pattern subst c in + if p' == p && c' == c then pat else + PProj(p',c') | PApp (f,args) -> let f' = subst_pattern subst f in let args' = Array.smartmap (subst_pattern subst) args in @@ -274,7 +285,7 @@ let rec subst_pattern subst pat = PIf (c',c1',c2') | PCase (cip,typ,c,branches) -> let ind = cip.cip_ind in - let ind' = Option.smartmap (Inductiveops.subst_inductive subst) ind in + let ind' = Option.smartmap (subst_ind subst) ind in let cip' = if ind' == ind then cip else { cip with cip_ind = ind' } in let typ' = subst_pattern subst typ in let c' = subst_pattern subst c in @@ -308,11 +319,13 @@ let rec pat_of_raw metas vars = function with Not_found -> PVar id) | GPatVar (_,(false,n)) -> metas := n::!metas; PMeta (Some n) - | GRef (_,gr) -> + | GRef (_,gr,_) -> PRef (canonical_gr gr) (* Hack pour ne pas rcrire une interprtation complte des patterns*) | GApp (_, GPatVar (_,(true,n)), cl) -> metas := n::!metas; PSoApp (n, List.map (pat_of_raw metas vars) cl) + | GProj (_, p, c) -> + PProj (p, pat_of_raw metas vars c) | GApp (_,c,cl) -> PApp (pat_of_raw metas vars c, Array.of_list (List.map (pat_of_raw metas vars) cl)) diff --git a/pretyping/pretype_errors.ml b/pretyping/pretype_errors.ml index 8ffd53055..003665db5 100644 --- a/pretyping/pretype_errors.ml +++ b/pretyping/pretype_errors.ml @@ -21,7 +21,7 @@ type unification_error = | ConversionFailed of env * constr * constr | MetaOccurInBody of existential_key | InstanceNotSameType of existential_key * env * types * types - | UnifUnivInconsistency + | UnifUnivInconsistency of Univ.univ_inconsistency type pretype_error = (* Old Case *) diff --git a/pretyping/pretype_errors.mli b/pretyping/pretype_errors.mli index 8e98f6307..d9ee969e3 100644 --- a/pretyping/pretype_errors.mli +++ b/pretyping/pretype_errors.mli @@ -22,7 +22,7 @@ type unification_error = | ConversionFailed of env * constr * constr | MetaOccurInBody of existential_key | InstanceNotSameType of existential_key * env * types * types - | UnifUnivInconsistency + | UnifUnivInconsistency of Univ.univ_inconsistency type pretype_error = (** Old Case *) @@ -70,7 +70,7 @@ val error_case_not_inductive_loc : val error_ill_formed_branch_loc : Loc.t -> env -> Evd.evar_map -> - constr -> constructor -> constr -> constr -> 'b + constr -> pconstructor -> constr -> constr -> 'b val error_number_branches_loc : Loc.t -> env -> Evd.evar_map -> diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index c66221e5f..7777de514 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -93,10 +93,10 @@ let ((constr_in : constr -> Dyn.t), (** Miscellaneous interpretation functions *) -let interp_sort = function - | GProp -> Prop Null - | GSet -> Prop Pos - | GType _ -> new_Type_sort () +let interp_sort evd = function + | GProp -> evd, Prop Null + | GSet -> evd, Prop Pos + | GType _ -> new_sort_variable univ_rigid evd let interp_elimination_sort = function | GProp -> InProp @@ -157,7 +157,7 @@ let check_extra_evars_are_solved env initial_sigma sigma = let check_evars_are_solved env initial_sigma sigma = check_typeclasses_instances_are_solved env sigma; - check_problems_are_solved sigma; + check_problems_are_solved env sigma; check_extra_evars_are_solved env initial_sigma sigma (* Try typeclasses, hooks, unification heuristics ... *) @@ -179,21 +179,6 @@ let process_inference_flags flags env initial_sigma (sigma,c) = (* Allow references to syntaxically inexistent variables (i.e., if applied on an inductive) *) let allow_anonymous_refs = ref false -let evd_comb0 f evdref = - let (evd',x) = f !evdref in - evdref := evd'; - x - -let evd_comb1 f evdref x = - let (evd',y) = f !evdref x in - evdref := evd'; - y - -let evd_comb2 f evdref x y = - let (evd',z) = f !evdref x y in - evdref := evd'; - z - (* Utilis pour infrer le prdicat des Cases *) (* Semble exagrement fort *) (* Faudra prfrer une unification entre les types de toutes les clauses *) @@ -236,7 +221,8 @@ let protected_get_type_of env sigma c = (str "Cannot reinterpret " ++ quote (print_constr c) ++ str " in the current environment.") -let pretype_id loc env sigma (lvar,unbndltacvars) id = +let pretype_id loc env evdref (lvar,unbndltacvars) id = + let sigma = !evdref in (* Look for the binder of [id] *) try let (n,_,typ) = lookup_rel_id id (rel_context env) in @@ -257,6 +243,12 @@ let pretype_id loc env sigma (lvar,unbndltacvars) id = (* Check if [id] is a section or goal variable *) try let (_,_,typ) = lookup_named id env in + (* let _ = *) + (* try *) + (* let ctx = Decls.variable_context id in *) + (* evdref := Evd.merge_context_set univ_rigid !evdref ctx; *) + (* with Not_found -> () *) + (* in *) { uj_val = mkVar id; uj_type = typ } with Not_found -> (* [id] not found, standard error message *) @@ -268,18 +260,26 @@ let evar_kind_of_term sigma c = (*************************************************************************) (* Main pretyping function *) -let pretype_ref loc evdref env = function +(* Check with universe list? *) +let pretype_global rigid env evd gr us = Evd.fresh_global ~rigid env evd gr + +let pretype_ref loc evdref env ref us = + match ref with | VarRef id -> (* Section variable *) - (try let (_,_,ty) = lookup_named id env in make_judge (mkVar id) ty + (try let (_,_,ty) = lookup_named id env in + (* let ctx = Decls.variable_context id in *) + (* evdref := Evd.merge_context_set univ_rigid !evdref ctx; *) + make_judge (mkVar id) ty with Not_found -> (* This may happen if env is a goal env and section variables have been cleared - section variables should be different from goal variables *) Pretype_errors.error_var_not_found_loc loc id) | ref -> - let c = constr_of_global ref in - make_judge c (Retyping.get_type_of env Evd.empty c) + let evd, c = pretype_global univ_flexible env !evdref ref us in + evdref := evd; + make_judge c (Retyping.get_type_of env evd c) let pretype_sort evdref = function | GProp -> judge_of_prop @@ -287,27 +287,37 @@ let pretype_sort evdref = function | GType _ -> evd_comb0 judge_of_new_Type evdref let new_type_evar evdref env loc = - evd_comb0 (fun evd -> Evarutil.new_type_evar evd env ~src:(loc,Evar_kinds.InternalHole)) evdref + let e, s = + evd_comb0 (fun evd -> Evarutil.new_type_evar univ_flexible_alg evd env ~src:(loc,Evar_kinds.InternalHole)) evdref + in e + +let get_projection env cst = + let cb = lookup_constant cst env in + match cb.Declarations.const_proj with + | Some {Declarations.proj_ind = mind; proj_npars = n; proj_arg = m; proj_type = ty} -> + (cst,mind,n,m,ty) + | None -> raise Not_found let (f_genarg_interp, genarg_interp_hook) = Hook.make () (* [pretype tycon env evdref lvar lmeta cstr] attempts to type [cstr] *) (* in environment [env], with existential variables [evdref] and *) (* the type constraint tycon *) + let rec pretype resolve_tc (tycon : type_constraint) env evdref lvar t = let inh_conv_coerce_to_tycon = inh_conv_coerce_to_tycon resolve_tc in let pretype_type = pretype_type resolve_tc in let pretype = pretype resolve_tc in match t with - | GRef (loc,ref) -> + | GRef (loc,ref,u) -> inh_conv_coerce_to_tycon loc env evdref - (pretype_ref loc evdref env ref) + (pretype_ref loc evdref env ref u) tycon | GVar (loc, id) -> - inh_conv_coerce_to_tycon loc env evdref - (pretype_id loc env !evdref lvar id) - tycon + inh_conv_coerce_to_tycon loc env evdref + (pretype_id loc env evdref lvar id) + tycon | GEvar (loc, evk, instopt) -> (* Ne faudrait-il pas s'assurer que hyps est bien un @@ -321,12 +331,12 @@ let rec pretype resolve_tc (tycon : type_constraint) env evdref lvar t = inh_conv_coerce_to_tycon loc env evdref j tycon | GPatVar (loc,(someta,n)) -> - let ty = - match tycon with - | Some ty -> ty - | None -> new_type_evar evdref env loc in - let k = Evar_kinds.MatchingVar (someta,n) in - { uj_val = e_new_evar evdref env ~src:(loc,k) ty; uj_type = ty } + let ty = + match tycon with + | Some ty -> ty + | None -> new_type_evar evdref env loc in + let k = Evar_kinds.MatchingVar (someta,n) in + { uj_val = e_new_evar evdref env ~src:(loc,k) ty; uj_type = ty } | GHole (loc, k, None) -> let ty = @@ -348,178 +358,216 @@ let rec pretype resolve_tc (tycon : type_constraint) env evdref lvar t = { uj_val = c; uj_type = ty } | GRec (loc,fixkind,names,bl,lar,vdef) -> - let rec type_bl env ctxt = function - [] -> ctxt - | (na,bk,None,ty)::bl -> - let ty' = pretype_type empty_valcon env evdref lvar ty in - let dcl = (na,None,ty'.utj_val) in - type_bl (push_rel dcl env) (add_rel_decl dcl ctxt) bl - | (na,bk,Some bd,ty)::bl -> - let ty' = pretype_type empty_valcon env evdref lvar ty in - let bd' = pretype (mk_tycon ty'.utj_val) env evdref lvar ty in - let dcl = (na,Some bd'.uj_val,ty'.utj_val) in - type_bl (push_rel dcl env) (add_rel_decl dcl ctxt) bl in - let ctxtv = Array.map (type_bl env empty_rel_context) bl in - let larj = - Array.map2 - (fun e ar -> - pretype_type empty_valcon (push_rel_context e env) evdref lvar ar) - ctxtv lar in - let lara = Array.map (fun a -> a.utj_val) larj in - let ftys = Array.map2 (fun e a -> it_mkProd_or_LetIn a e) ctxtv lara in - let nbfix = Array.length lar in - let names = Array.map (fun id -> Name id) names in - let _ = - match tycon with - | Some t -> - let fixi = match fixkind with - | GFix (vn,i) -> i - | GCoFix i -> i - in e_conv env evdref ftys.(fixi) t - | None -> true - in - (* Note: bodies are not used by push_rec_types, so [||] is safe *) - let newenv = push_rec_types (names,ftys,[||]) env in - let vdefj = - Array.map2_i - (fun i ctxt def -> + let rec type_bl env ctxt = function + [] -> ctxt + | (na,bk,None,ty)::bl -> + let ty' = pretype_type empty_valcon env evdref lvar ty in + let dcl = (na,None,ty'.utj_val) in + type_bl (push_rel dcl env) (add_rel_decl dcl ctxt) bl + | (na,bk,Some bd,ty)::bl -> + let ty' = pretype_type empty_valcon env evdref lvar ty in + let bd' = pretype (mk_tycon ty'.utj_val) env evdref lvar ty in + let dcl = (na,Some bd'.uj_val,ty'.utj_val) in + type_bl (push_rel dcl env) (add_rel_decl dcl ctxt) bl in + let ctxtv = Array.map (type_bl env empty_rel_context) bl in + let larj = + Array.map2 + (fun e ar -> + pretype_type empty_valcon (push_rel_context e env) evdref lvar ar) + ctxtv lar in + let lara = Array.map (fun a -> a.utj_val) larj in + let ftys = Array.map2 (fun e a -> it_mkProd_or_LetIn a e) ctxtv lara in + let nbfix = Array.length lar in + let names = Array.map (fun id -> Name id) names in + let _ = + match tycon with + | Some t -> + let fixi = match fixkind with + | GFix (vn,i) -> i + | GCoFix i -> i + in e_conv env evdref ftys.(fixi) t + | None -> true + in + (* Note: bodies are not used by push_rec_types, so [||] is safe *) + let newenv = push_rec_types (names,ftys,[||]) env in + let vdefj = + Array.map2_i + (fun i ctxt def -> (* we lift nbfix times the type in tycon, because of * the nbfix variables pushed to newenv *) - let (ctxt,ty) = - decompose_prod_n_assum (rel_context_length ctxt) - (lift nbfix ftys.(i)) in - let nenv = push_rel_context ctxt newenv in - let j = pretype (mk_tycon ty) nenv evdref lvar def in - { uj_val = it_mkLambda_or_LetIn j.uj_val ctxt; - uj_type = it_mkProd_or_LetIn j.uj_type ctxt }) - ctxtv vdef in - evar_type_fixpoint loc env evdref names ftys vdefj; - let ftys = Array.map (nf_evar !evdref) ftys in - let fdefs = Array.map (fun x -> nf_evar !evdref (j_val x)) vdefj in - let fixj = match fixkind with - | GFix (vn,i) -> + let (ctxt,ty) = + decompose_prod_n_assum (rel_context_length ctxt) + (lift nbfix ftys.(i)) in + let nenv = push_rel_context ctxt newenv in + let j = pretype (mk_tycon ty) nenv evdref lvar def in + { uj_val = it_mkLambda_or_LetIn j.uj_val ctxt; + uj_type = it_mkProd_or_LetIn j.uj_type ctxt }) + ctxtv vdef in + evar_type_fixpoint loc env evdref names ftys vdefj; + let ftys = Array.map (nf_evar !evdref) ftys in + let fdefs = Array.map (fun x -> nf_evar !evdref (j_val x)) vdefj in + let fixj = match fixkind with + | GFix (vn,i) -> (* First, let's find the guard indexes. *) (* If recursive argument was not given by user, we try all args. An earlier approach was to look only for inductive arguments, but doing it properly involves delta-reduction, and it finally doesn't seem worth the effort (except for huge mutual fixpoints ?) *) - let possible_indexes = - Array.to_list (Array.mapi - (fun i (n,_) -> match n with - | Some n -> [n] - | None -> List.map_i (fun i _ -> i) 0 ctxtv.(i)) - vn) - in - let fixdecls = (names,ftys,fdefs) in - let indexes = search_guard loc env possible_indexes fixdecls in - make_judge (mkFix ((indexes,i),fixdecls)) ftys.(i) - | GCoFix i -> - let cofix = (i,(names,ftys,fdefs)) in - (try check_cofix env cofix - with reraise -> - let e = Errors.push reraise in Loc.raise loc e); - make_judge (mkCoFix cofix) ftys.(i) - in + let possible_indexes = + Array.to_list (Array.mapi + (fun i (n,_) -> match n with + | Some n -> [n] + | None -> List.map_i (fun i _ -> i) 0 ctxtv.(i)) + vn) + in + let fixdecls = (names,ftys,fdefs) in + let indexes = search_guard loc env possible_indexes fixdecls in + make_judge (mkFix ((indexes,i),fixdecls)) ftys.(i) + | GCoFix i -> + let cofix = (i,(names,ftys,fdefs)) in + (try check_cofix env cofix + with reraise -> + let e = Errors.push reraise in Loc.raise loc e); + make_judge (mkCoFix cofix) ftys.(i) + in inh_conv_coerce_to_tycon loc env evdref fixj tycon | GSort (loc,s) -> - let j = pretype_sort evdref s in - inh_conv_coerce_to_tycon loc env evdref j tycon + let j = pretype_sort evdref s in + inh_conv_coerce_to_tycon loc env evdref j tycon + + | GProj (loc, p, arg) -> + let (cst, mind, n, m, ty) = + try get_projection env p + with Not_found -> + user_err_loc (loc,"",str "Not a projection") + in + let mk_ty k = + let ind = + Evarutil.evd_comb1 (Evd.fresh_inductive_instance env) evdref (mind,0) + in + let args = + let ctx = smash_rel_context (Inductiveops.inductive_params_ctxt ind) in + List.fold_right (fun (n, b, ty) (* par *)args -> + let ty = substl args ty in + let ev = e_new_evar evdref env ~src:(loc,k) ty in + ev :: args) ctx [] + (* let j = pretype (mk_tycon ty) env evdref lvar par in *) + (* j.uj_val :: args) ctx pars [] *) + in (ind, List.rev args) + in + let argtycon = + match arg with + (** FIXME ? *) + | GHole (loc, k, _) -> (* Typeclass projection application: + create the necessary type constraint *) + let ind, args = mk_ty k in + mk_tycon (applist (mkIndU ind, args)) + | _ -> empty_tycon + in + let recty = pretype argtycon env evdref lvar arg in + let recty, ((ind,u), pars) = + try + let IndType (indf, _ (*[]*)) = + find_rectype env !evdref recty.uj_type + in recty, dest_ind_family indf + with Not_found -> + (match argtycon with + | Some ty -> assert false + (* let IndType (indf, _) = find_rectype env !evdref ty in *) + (* recty, dest_ind_family indf *) + | None -> + let ind, args = mk_ty Evar_kinds.InternalHole in + let j' = + inh_conv_coerce_to_tycon loc env evdref recty + (mk_tycon (applist (mkIndU ind, args))) in + j', (ind, args)) + in + let usubst = make_inductive_subst (fst (lookup_mind_specif env ind)) u in + let ty = Vars.subst_univs_constr usubst ty in + let ty = substl (recty.uj_val :: List.rev pars) ty in + let j = {uj_val = mkProj (cst,recty.uj_val); uj_type = ty} in + inh_conv_coerce_to_tycon loc env evdref j tycon | GApp (loc,f,args) -> - let fj = pretype empty_tycon env evdref lvar f in - let floc = loc_of_glob_constr f in - let length = List.length args in - let candargs = + let fj = pretype empty_tycon env evdref lvar f in + let floc = loc_of_glob_constr f in + let length = List.length args in + let candargs = (* Bidirectional typechecking hint: parameters of a constructor are completely determined by a typing constraint *) - if Flags.is_program_mode () && length > 0 && isConstruct fj.uj_val then - match tycon with - | None -> [] - | Some ty -> - let (ind, i) = destConstruct fj.uj_val in - let npars = inductive_nparams ind in - if Int.equal npars 0 then [] - else - try - (* Does not treat partially applied constructors. *) - let ty = evd_comb1 (Coercion.inh_coerce_to_prod loc env) evdref ty in - let IndType (indf, args) = find_rectype env !evdref ty in - let (ind',pars) = dest_ind_family indf in - if eq_ind ind ind' then pars - else (* Let the usual code throw an error *) [] - with Not_found -> [] - else [] - in - let rec apply_rec env n resj candargs = function - | [] -> resj - | c::rest -> - let argloc = loc_of_glob_constr c in - let resj = evd_comb1 (Coercion.inh_app_fun resolve_tc env) evdref resj in - let resty = whd_betadeltaiota env !evdref resj.uj_type in - match kind_of_term resty with - | Prod (na,c1,c2) -> - let hj = pretype (mk_tycon c1) env evdref lvar c in - let candargs, ujval = - match candargs with - | [] -> [], j_val hj - | arg :: args -> - if e_conv env evdref (j_val hj) arg then - args, nf_evar !evdref (j_val hj) - else [], j_val hj - in - let value, typ = applist (j_val resj, [ujval]), subst1 ujval c2 in - apply_rec env (n+1) - { uj_val = value; - uj_type = typ } - candargs rest - - | _ -> - let hj = pretype empty_tycon env evdref lvar c in - error_cant_apply_not_functional_loc - (Loc.merge floc argloc) env !evdref - resj [hj] - in - let resj = apply_rec env 1 fj candargs args in - let resj = - match evar_kind_of_term !evdref resj.uj_val with - | App (f,args) -> - let f = whd_evar !evdref f in - begin match kind_of_term f with - | Ind _ | Const _ - when isInd f || has_polymorphic_type (destConst f) - -> - let sigma = !evdref in - let c = mkApp (f,Array.map (whd_evar sigma) args) in - let t = Retyping.get_type_of env sigma c in - make_judge c (* use this for keeping evars: resj.uj_val *) t - | _ -> resj end - | _ -> resj in - inh_conv_coerce_to_tycon loc env evdref resj tycon + if Flags.is_program_mode () && length > 0 && isConstruct fj.uj_val then + match tycon with + | None -> [] + | Some ty -> + let ((ind, i), u) = destConstruct fj.uj_val in + let npars = inductive_nparams ind in + if Int.equal npars 0 then [] + else + try + let ty = evd_comb1 (Coercion.inh_coerce_to_prod loc env) evdref ty in + let IndType (indf, args) = find_rectype env !evdref ty in + let ((ind',u'),pars) = dest_ind_family indf in + if eq_ind ind ind' then pars + else (* Let the usual code throw an error *) [] + with Not_found -> [] + else [] + in + let rec apply_rec env n resj candargs = function + | [] -> resj + | c::rest -> + let argloc = loc_of_glob_constr c in + let resj = evd_comb1 (Coercion.inh_app_fun resolve_tc env) evdref resj in + let resty = whd_betadeltaiota env !evdref resj.uj_type in + match kind_of_term resty with + | Prod (na,c1,c2) -> + let hj = pretype (mk_tycon c1) env evdref lvar c in + let candargs, ujval = + match candargs with + | [] -> [], j_val hj + | arg :: args -> + if e_conv env evdref (j_val hj) arg then + args, nf_evar !evdref (j_val hj) + else [], j_val hj + in + let value, typ = applist (j_val resj, [ujval]), subst1 ujval c2 in + apply_rec env (n+1) + { uj_val = value; + uj_type = typ } + candargs rest + + | _ -> + let hj = pretype empty_tycon env evdref lvar c in + error_cant_apply_not_functional_loc + (Loc.merge floc argloc) env !evdref + resj [hj] + in + let resj = apply_rec env 1 fj candargs args in + inh_conv_coerce_to_tycon loc env evdref resj tycon | GLambda(loc,name,bk,c1,c2) -> - let tycon' = evd_comb1 - (fun evd tycon -> - match tycon with - | None -> evd, tycon - | Some ty -> - let evd, ty' = Coercion.inh_coerce_to_prod loc env evd ty in - evd, Some ty') - evdref tycon - in - let (name',dom,rng) = evd_comb1 (split_tycon loc env) evdref tycon' in - let dom_valcon = valcon_of_tycon dom in - let j = pretype_type dom_valcon env evdref lvar c1 in - let var = (name,None,j.utj_val) in - let j' = pretype rng (push_rel var env) evdref lvar c2 in - let resj = judge_of_abstraction env (orelse_name name name') j j' in - inh_conv_coerce_to_tycon loc env evdref resj tycon + let tycon' = evd_comb1 + (fun evd tycon -> + match tycon with + | None -> evd, tycon + | Some ty -> + let evd, ty' = Coercion.inh_coerce_to_prod loc env evd ty in + evd, Some ty') + evdref tycon + in + let (name',dom,rng) = evd_comb1 (split_tycon loc env) evdref tycon' in + let dom_valcon = valcon_of_tycon dom in + let j = pretype_type dom_valcon env evdref lvar c1 in + let var = (name,None,j.utj_val) in + let j' = pretype rng (push_rel var env) evdref lvar c2 in + let resj = judge_of_abstraction env (orelse_name name name') j j' in + inh_conv_coerce_to_tycon loc env evdref resj tycon | GProd(loc,name,bk,c1,c2) -> - let j = pretype_type empty_valcon env evdref lvar c1 in - let j' = match name with + let j = pretype_type empty_valcon env evdref lvar c1 in + let j' = match name with | Anonymous -> let j = pretype_type empty_valcon env evdref lvar c2 in { j with utj_val = lift 1 j.utj_val } @@ -527,212 +575,208 @@ let rec pretype resolve_tc (tycon : type_constraint) env evdref lvar t = let var = (name,j.utj_val) in let env' = push_rel_assum var env in pretype_type empty_valcon env' evdref lvar c2 - in - let resj = - try judge_of_product env name j j' - with TypeError _ as e -> let e = Errors.push e in Loc.raise loc e in - inh_conv_coerce_to_tycon loc env evdref resj tycon + in + let resj = + try judge_of_product env name j j' + with TypeError _ as e -> let e = Errors.push e in Loc.raise loc e in + inh_conv_coerce_to_tycon loc env evdref resj tycon | GLetIn(loc,name,c1,c2) -> - let j = - match c1 with - | GCast (loc, c, CastConv t) -> - let tj = pretype_type empty_valcon env evdref lvar t in - pretype (mk_tycon tj.utj_val) env evdref lvar c - | _ -> pretype empty_tycon env evdref lvar c1 - in - let t = refresh_universes j.uj_type in - let var = (name,Some j.uj_val,t) in - let tycon = lift_tycon 1 tycon in - let j' = pretype tycon (push_rel var env) evdref lvar c2 in - { uj_val = mkLetIn (name, j.uj_val, t, j'.uj_val) ; - uj_type = subst1 j.uj_val j'.uj_type } + let j = + match c1 with + | GCast (loc, c, CastConv t) -> + let tj = pretype_type empty_valcon env evdref lvar t in + pretype (mk_tycon tj.utj_val) env evdref lvar c + | _ -> pretype empty_tycon env evdref lvar c1 + in + let t = j.uj_type in + let var = (name,Some j.uj_val,t) in + let tycon = lift_tycon 1 tycon in + let j' = pretype tycon (push_rel var env) evdref lvar c2 in + { uj_val = mkLetIn (name, j.uj_val, t, j'.uj_val) ; + uj_type = subst1 j.uj_val j'.uj_type } | GLetTuple (loc,nal,(na,po),c,d) -> - let cj = pretype empty_tycon env evdref lvar c in - let (IndType (indf,realargs)) = - try find_rectype env !evdref cj.uj_type - with Not_found -> - let cloc = loc_of_glob_constr c in - error_case_not_inductive_loc cloc env !evdref cj - in - let cstrs = get_constructors env indf in - if not (Int.equal (Array.length cstrs) 1) then - user_err_loc (loc,"",str "Destructing let is only for inductive types" ++ - str " with one constructor."); - let cs = cstrs.(0) in - if not (Int.equal (List.length nal) cs.cs_nargs) then - user_err_loc (loc,"", str "Destructing let on this type expects " ++ - int cs.cs_nargs ++ str " variables."); - let fsign = List.map2 (fun na (_,c,t) -> (na,c,t)) - (List.rev nal) cs.cs_args in - let env_f = push_rel_context fsign env in - (* Make dependencies from arity signature impossible *) - let arsgn = - let arsgn,_ = get_arity env indf in - if not !allow_anonymous_refs then - List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn - else arsgn - in - let psign = (na,None,build_dependent_inductive env indf)::arsgn in - let nar = List.length arsgn in - (match po with - | Some p -> - let env_p = push_rel_context psign env in - let pj = pretype_type empty_valcon env_p evdref lvar p in - let ccl = nf_evar !evdref pj.utj_val in - let psign = make_arity_signature env true indf in (* with names *) - let p = it_mkLambda_or_LetIn ccl psign in - let inst = - (Array.to_list cs.cs_concl_realargs) - @[build_dependent_constructor cs] in - let lp = lift cs.cs_nargs p in - let fty = hnf_lam_applist env !evdref lp inst in - let fj = pretype (mk_tycon fty) env_f evdref lvar d in - let f = it_mkLambda_or_LetIn fj.uj_val fsign in - let v = - let ind,_ = dest_ind_family indf in - let ci = make_case_info env ind LetStyle in - Typing.check_allowed_sort env !evdref ind cj.uj_val p; - mkCase (ci, p, cj.uj_val,[|f|]) in - { uj_val = v; uj_type = substl (realargs@[cj.uj_val]) ccl } - - | None -> - let tycon = lift_tycon cs.cs_nargs tycon in - let fj = pretype tycon env_f evdref lvar d in - let f = it_mkLambda_or_LetIn fj.uj_val fsign in - let ccl = nf_evar !evdref fj.uj_type in - let ccl = - if noccur_between 1 cs.cs_nargs ccl then - lift (- cs.cs_nargs) ccl - else - error_cant_find_case_type_loc loc env !evdref - cj.uj_val in - let ccl = refresh_universes ccl in - let p = it_mkLambda_or_LetIn (lift (nar+1) ccl) psign in - let v = - let ind,_ = dest_ind_family indf in - let ci = make_case_info env ind LetStyle in - Typing.check_allowed_sort env !evdref ind cj.uj_val p; - mkCase (ci, p, cj.uj_val,[|f|]) - in { uj_val = v; uj_type = ccl }) - - | GIf (loc,c,(na,po),b1,b2) -> - let cj = pretype empty_tycon env evdref lvar c in - let (IndType (indf,realargs)) = - try find_rectype env !evdref cj.uj_type - with Not_found -> - let cloc = loc_of_glob_constr c in - error_case_not_inductive_loc cloc env !evdref cj in - let cstrs = get_constructors env indf in - if not (Int.equal (Array.length cstrs) 2) then - user_err_loc (loc,"", - str "If is only for inductive types with two constructors."); - + let cj = pretype empty_tycon env evdref lvar c in + let (IndType (indf,realargs)) = + try find_rectype env !evdref cj.uj_type + with Not_found -> + let cloc = loc_of_glob_constr c in + error_case_not_inductive_loc cloc env !evdref cj + in + let cstrs = get_constructors env indf in + if not (Int.equal (Array.length cstrs) 1) then + user_err_loc (loc,"",str "Destructing let is only for inductive types" ++ + str " with one constructor."); + let cs = cstrs.(0) in + if not (Int.equal (List.length nal) cs.cs_nargs) then + user_err_loc (loc,"", str "Destructing let on this type expects " ++ + int cs.cs_nargs ++ str " variables."); + let fsign = List.map2 (fun na (_,c,t) -> (na,c,t)) + (List.rev nal) cs.cs_args in + let env_f = push_rel_context fsign env in + (* Make dependencies from arity signature impossible *) let arsgn = let arsgn,_ = get_arity env indf in if not !allow_anonymous_refs then - (* Make dependencies from arity signature impossible *) List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn else arsgn in - let nar = List.length arsgn in let psign = (na,None,build_dependent_inductive env indf)::arsgn in - let pred,p = match po with + let nar = List.length arsgn in + (match po with | Some p -> - let env_p = push_rel_context psign env in - let pj = pretype_type empty_valcon env_p evdref lvar p in - let ccl = nf_evar !evdref pj.utj_val in - let pred = it_mkLambda_or_LetIn ccl psign in - let typ = lift (- nar) (beta_applist (pred,[cj.uj_val])) in - pred, typ + let env_p = push_rel_context psign env in + let pj = pretype_type empty_valcon env_p evdref lvar p in + let ccl = nf_evar !evdref pj.utj_val in + let psign = make_arity_signature env true indf in (* with names *) + let p = it_mkLambda_or_LetIn ccl psign in + let inst = + (Array.to_list cs.cs_concl_realargs) + @[build_dependent_constructor cs] in + let lp = lift cs.cs_nargs p in + let fty = hnf_lam_applist env !evdref lp inst in + let fj = pretype (mk_tycon fty) env_f evdref lvar d in + let f = it_mkLambda_or_LetIn fj.uj_val fsign in + let v = + let ind,_ = dest_ind_family indf in + let ci = make_case_info env (fst ind) LetStyle in + Typing.check_allowed_sort env !evdref ind cj.uj_val p; + mkCase (ci, p, cj.uj_val,[|f|]) in + { uj_val = v; uj_type = substl (realargs@[cj.uj_val]) ccl } + | None -> - let p = match tycon with - | Some ty -> ty - | None -> new_type_evar evdref env loc - in - it_mkLambda_or_LetIn (lift (nar+1) p) psign, p in - let pred = nf_evar !evdref pred in - let p = nf_evar !evdref p in - let f cs b = - let n = rel_context_length cs.cs_args in - let pi = lift n pred in (* liftn n 2 pred ? *) - let pi = beta_applist (pi, [build_dependent_constructor cs]) in - let csgn = - if not !allow_anonymous_refs then - List.map (fun (_,b,t) -> (Anonymous,b,t)) cs.cs_args - else - List.map - (fun (n, b, t) -> - match n with - Name _ -> (n, b, t) - | Anonymous -> (Name (Id.of_string "H"), b, t)) - cs.cs_args + let tycon = lift_tycon cs.cs_nargs tycon in + let fj = pretype tycon env_f evdref lvar d in + let f = it_mkLambda_or_LetIn fj.uj_val fsign in + let ccl = nf_evar !evdref fj.uj_type in + let ccl = + if noccur_between 1 cs.cs_nargs ccl then + lift (- cs.cs_nargs) ccl + else + error_cant_find_case_type_loc loc env !evdref + cj.uj_val in + (* let ccl = refresh_universes ccl in *) + let p = it_mkLambda_or_LetIn (lift (nar+1) ccl) psign in + let v = + let ind,_ = dest_ind_family indf in + let ci = make_case_info env (fst ind) LetStyle in + Typing.check_allowed_sort env !evdref ind cj.uj_val p; + mkCase (ci, p, cj.uj_val,[|f|]) + in { uj_val = v; uj_type = ccl }) + + | GIf (loc,c,(na,po),b1,b2) -> + let cj = pretype empty_tycon env evdref lvar c in + let (IndType (indf,realargs)) = + try find_rectype env !evdref cj.uj_type + with Not_found -> + let cloc = loc_of_glob_constr c in + error_case_not_inductive_loc cloc env !evdref cj in + let cstrs = get_constructors env indf in + if not (Int.equal (Array.length cstrs) 2) then + user_err_loc (loc,"", + str "If is only for inductive types with two constructors."); + + let arsgn = + let arsgn,_ = get_arity env indf in + if not !allow_anonymous_refs then + (* Make dependencies from arity signature impossible *) + List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn + else arsgn + in + let nar = List.length arsgn in + let psign = (na,None,build_dependent_inductive env indf)::arsgn in + let pred,p = match po with + | Some p -> + let env_p = push_rel_context psign env in + let pj = pretype_type empty_valcon env_p evdref lvar p in + let ccl = nf_evar !evdref pj.utj_val in + let pred = it_mkLambda_or_LetIn ccl psign in + let typ = lift (- nar) (beta_applist (pred,[cj.uj_val])) in + pred, typ + | None -> + let p = match tycon with + | Some ty -> ty + | None -> new_type_evar evdref env loc in - let env_c = push_rel_context csgn env in - let bj = pretype (mk_tycon pi) env_c evdref lvar b in - it_mkLambda_or_LetIn bj.uj_val cs.cs_args in - let b1 = f cstrs.(0) b1 in - let b2 = f cstrs.(1) b2 in - let v = - let ind,_ = dest_ind_family indf in - let ci = make_case_info env ind IfStyle in - let pred = nf_evar !evdref pred in - Typing.check_allowed_sort env !evdref ind cj.uj_val pred; - mkCase (ci, pred, cj.uj_val, [|b1;b2|]) + it_mkLambda_or_LetIn (lift (nar+1) p) psign, p in + let pred = nf_evar !evdref pred in + let p = nf_evar !evdref p in + let f cs b = + let n = rel_context_length cs.cs_args in + let pi = lift n pred in (* liftn n 2 pred ? *) + let pi = beta_applist (pi, [build_dependent_constructor cs]) in + let csgn = + if not !allow_anonymous_refs then + List.map (fun (_,b,t) -> (Anonymous,b,t)) cs.cs_args + else + List.map + (fun (n, b, t) -> + match n with + Name _ -> (n, b, t) + | Anonymous -> (Name (Id.of_string "H"), b, t)) + cs.cs_args in - { uj_val = v; uj_type = p } + let env_c = push_rel_context csgn env in + let bj = pretype (mk_tycon pi) env_c evdref lvar b in + it_mkLambda_or_LetIn bj.uj_val cs.cs_args in + let b1 = f cstrs.(0) b1 in + let b2 = f cstrs.(1) b2 in + let v = + let ind,_ = dest_ind_family indf in + let ci = make_case_info env (fst ind) IfStyle in + let pred = nf_evar !evdref pred in + Typing.check_allowed_sort env !evdref ind cj.uj_val pred; + mkCase (ci, pred, cj.uj_val, [|b1;b2|]) + in + { uj_val = v; uj_type = p } | GCases (loc,sty,po,tml,eqns) -> - Cases.compile_cases loc sty - ((fun vtyc env evdref -> pretype vtyc env evdref lvar),evdref) - tycon env (* loc *) (po,tml,eqns) + Cases.compile_cases loc sty + ((fun vtyc env evdref -> pretype vtyc env evdref lvar),evdref) + tycon env (* loc *) (po,tml,eqns) | GCast (loc,c,k) -> - let cj = - match k with - | CastCoerce -> - let cj = pretype empty_tycon env evdref lvar c in - evd_comb1 (Coercion.inh_coerce_to_base loc env) evdref cj - | CastConv t | CastVM t | CastNative t -> - let k = (match k with CastVM _ -> VMcast | CastNative _ -> NATIVEcast | _ -> DEFAULTcast) in - let tj = pretype_type empty_valcon env evdref lvar t in - let tval = nf_evar !evdref tj.utj_val in - let cj = match k with - | VMcast -> - let cj = pretype empty_tycon env evdref lvar c in - let cty = nf_evar !evdref cj.uj_type and tval = nf_evar !evdref tj.utj_val in - if not (occur_existential cty || occur_existential tval) then - begin - try - ignore (Reduction.vm_conv Reduction.CUMUL env cty tval); cj - with Reduction.NotConvertible -> - error_actual_type_loc loc env !evdref cj tval - (ConversionFailed (env,cty,tval)) - end - else user_err_loc (loc,"",str "Cannot check cast with vm: " ++ - str "unresolved arguments remain.") - | NATIVEcast -> - let cj = pretype empty_tycon env evdref lvar c in - let cty = nf_evar !evdref cj.uj_type and - tval = nf_evar !evdref tj.utj_val in - let evars = Nativenorm.evars_of_evar_map !evdref in - begin - try - ignore - (Nativeconv.native_conv Reduction.CUMUL evars env cty tval); - cj - with Reduction.NotConvertible -> - error_actual_type_loc loc env !evdref cj tval + let cj = + match k with + | CastCoerce -> + let cj = pretype empty_tycon env evdref lvar c in + evd_comb1 (Coercion.inh_coerce_to_base loc env) evdref cj + | CastConv t | CastVM t | CastNative t -> + let k = (match k with CastVM _ -> VMcast | CastNative _ -> NATIVEcast | _ -> DEFAULTcast) in + let tj = pretype_type empty_valcon env evdref lvar t in + let tval = nf_evar !evdref tj.utj_val in + let cj = match k with + | VMcast -> + let cj = pretype empty_tycon env evdref lvar c in + let cty = nf_evar !evdref cj.uj_type and tval = nf_evar !evdref tj.utj_val in + if not (occur_existential cty || occur_existential tval) then + begin + try + ignore (Reduction.vm_conv Reduction.CUMUL env cty tval); cj + with Reduction.NotConvertible -> + error_actual_type_loc loc env !evdref cj tval + (ConversionFailed (env,cty,tval)) + end + else user_err_loc (loc,"",str "Cannot check cast with vm: " ++ + str "unresolved arguments remain.") + | NATIVEcast -> + let cj = pretype empty_tycon env evdref lvar c in + let cty = nf_evar !evdref cj.uj_type and tval = nf_evar !evdref tj.utj_val in + let evars = Nativenorm.evars_of_evar_map !evdref in + begin + try + ignore (Nativeconv.native_conv Reduction.CUMUL evars env cty tval); cj + with Reduction.NotConvertible -> + error_actual_type_loc loc env !evdref cj tval (ConversionFailed (env,cty,tval)) - end - - | _ -> - pretype (mk_tycon tval) env evdref lvar c - in - let v = mkCast (cj.uj_val, k, tval) in - { uj_val = v; uj_type = tval } - in inh_conv_coerce_to_tycon loc env evdref cj tycon + end + | _ -> + pretype (mk_tycon tval) env evdref lvar c + in + let v = mkCast (cj.uj_val, k, tval) in + { uj_val = v; uj_type = tval } + in inh_conv_coerce_to_tycon loc env evdref cj tycon (* [pretype_type valcon env evdref lvar c] coerces [c] into a type *) and pretype_type resolve_tc valcon env evdref lvar = function @@ -751,7 +795,7 @@ and pretype_type resolve_tc valcon env evdref lvar = function { utj_val = v; utj_type = s } | None -> - let s = evd_comb0 new_sort_variable evdref in + let s = evd_comb0 (new_sort_variable univ_flexible_alg) evdref in { utj_val = e_new_evar evdref env ~src:(loc, knd) (mkSort s); utj_type = s}) | c -> @@ -778,11 +822,6 @@ let ise_pretype_gen flags sigma env lvar kind c = in process_inference_flags flags env sigma (!evdref,c') -(* TODO: comment faire remonter l'information si le typage a resolu des - variables du sigma original. il faudrait que la fonction de typage - retourne aussi le nouveau sigma... -*) - let default_inference_flags fail = { use_typeclasses = true; use_unif_heuristics = true; @@ -810,8 +849,10 @@ let on_judgment f j = let understand_judgment sigma env c = let evdref = ref sigma in let j = pretype true empty_tycon env evdref empty_lvar c in - on_judgment (fun c -> - snd (process_inference_flags all_and_fail_flags env sigma (!evdref,c))) j + let j = on_judgment (fun c -> + let evd, c = process_inference_flags all_and_fail_flags env sigma (!evdref,c) in + evdref := evd; c) j + in j, Evd.evar_universe_context !evdref let understand_judgment_tcc evdref env c = let j = pretype true empty_tycon env evdref empty_lvar c in @@ -819,13 +860,18 @@ let understand_judgment_tcc evdref env c = let (evd,c) = process_inference_flags all_no_fail_flags env Evd.empty (!evdref,c) in evdref := evd; c) j +let ise_pretype_gen_ctx flags sigma env lvar kind c = + let evd, c = ise_pretype_gen flags sigma env lvar kind c in + let evd, f = Evarutil.nf_evars_and_universes evd in + f c, Evd.get_universe_context_set evd + (** Entry points of the high-level type synthesis algorithm *) let understand ?(flags=all_and_fail_flags) ?(expected_type=WithoutTypeConstraint) sigma env c = - snd (ise_pretype_gen flags sigma env empty_lvar expected_type c) + ise_pretype_gen_ctx flags sigma env empty_lvar expected_type c let understand_tcc ?(flags=all_no_fail_flags) sigma env ?(expected_type=WithoutTypeConstraint) c = ise_pretype_gen flags sigma env empty_lvar expected_type c diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index ec8aae140..79b051845 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -81,14 +81,16 @@ val understand_ltac : inference_flags -> (** Standard call to get a constr from a glob_constr, resolving implicit args *) val understand : ?flags:inference_flags -> ?expected_type:typing_constraint -> - evar_map -> env -> glob_constr -> constr + evar_map -> env -> glob_constr -> constr Univ.in_universe_context_set (** Idem but returns the judgment of the understood term *) -val understand_judgment : evar_map -> env -> glob_constr -> unsafe_judgment +val understand_judgment : evar_map -> env -> + glob_constr -> unsafe_judgment Evd.in_evar_universe_context (** Idem but do not fail on unresolved evars *) -val understand_judgment_tcc : evar_map ref -> env -> glob_constr -> unsafe_judgment +val understand_judgment_tcc : evar_map ref -> env -> + glob_constr -> unsafe_judgment (** Trying to solve remaining evars and remaining conversion problems with type classes, heuristics, and possibly an external solver *) @@ -122,7 +124,7 @@ val ise_pretype_gen : val constr_in : constr -> Dyn.t val constr_out : Dyn.t -> constr -val interp_sort : glob_sort -> sorts +val interp_sort : evar_map -> glob_sort -> evar_map * sorts val interp_elimination_sort : glob_sort -> sorts_family val genarg_interp_hook : diff --git a/pretyping/program.ml b/pretyping/program.ml index 6d913060b..67bb3bd2a 100644 --- a/pretyping/program.ml +++ b/pretyping/program.ml @@ -21,7 +21,7 @@ let find_reference locstr dir s = anomaly ~label:locstr (Pp.str "cannot find" ++ spc () ++ Libnames.pr_path sp) let coq_reference locstr dir s = find_reference locstr ("Coq"::dir) s -let coq_constant locstr dir s = Globnames.constr_of_global (coq_reference locstr dir s) +let coq_constant locstr dir s = Universes.constr_of_global (coq_reference locstr dir s) let init_constant dir s () = coq_constant "Program" dir s let init_reference dir s () = coq_reference "Program" dir s diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index 9f8ba956a..967583a2b 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -63,12 +63,12 @@ let cache_structure o = load_structure 1 o let subst_structure (subst,((kn,i),id,kl,projs as obj)) = - let kn' = subst_ind subst kn in + let kn' = subst_mind subst kn in let projs' = (* invariant: struc.s_PROJ is an evaluable reference. Thus we can take *) (* the first component of subst_con. *) List.smartmap - (Option.smartmap (fun kn -> fst (subst_con subst kn))) + (Option.smartmap (fun kn -> fst (subst_con_kn subst kn))) projs in let id' = fst (subst_constructor subst id) in @@ -132,6 +132,7 @@ that maps the pair (Li,ci) to the following data type obj_typ = { o_DEF : constr; + o_CTX : Univ.ContextSet.t; o_INJ : int; (* position of trivial argument (negative= none) *) o_TABS : constr list; (* ordered *) o_TPARAMS : constr list; (* ordered *) @@ -189,9 +190,13 @@ let cs_pattern_of_constr t = (* Intended to always succeed *) let compute_canonical_projections (con,ind) = - let v = mkConst con in - let c = Environ.constant_value (Global.env()) con in - let lt,t = Reductionops.splay_lam (Global.env()) Evd.empty c in + let env = Global.env () in + let ctx = Environ.constant_context env con in + let u = Univ.UContext.instance ctx in + let v = (mkConstU (con,u)) in + let ctx = Univ.ContextSet.of_context ctx in + let c = Environ.constant_value_in env (con,u) in + let lt,t = Reductionops.splay_lam env Evd.empty c in let lt = List.rev_map snd lt in let args = snd (decompose_app t) in let { s_EXPECTEDPARAM = p; s_PROJ = lpj; s_PROJKIND = kl } = @@ -221,7 +226,7 @@ let compute_canonical_projections (con,ind) = [] lps in List.map (fun (refi,c,inj,argj) -> (refi,c), - {o_DEF=v; o_INJ=inj; o_TABS=lt; + {o_DEF=v; o_CTX=ctx; o_INJ=inj; o_TABS=lt; o_TPARAMS=params; o_NPARAMS=List.length params; o_TCOMPS=argj}) comp @@ -256,8 +261,8 @@ let cache_canonical_structure o = let subst_canonical_structure (subst,(cst,ind as obj)) = (* invariant: cst is an evaluable reference. Thus we can take *) (* the first component of subst_con. *) - let cst' = fst (subst_con subst cst) in - let ind' = Inductiveops.subst_inductive subst ind in + let cst' = subst_constant subst cst in + let ind' = subst_ind subst ind in if cst' == cst && ind' == ind then obj else (cst',ind') let discharge_canonical_structure (_,(cst,ind)) = @@ -282,7 +287,9 @@ 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 vc = match Environ.constant_opt_value env sp with + let ctx = Environ.constant_context env sp in + let u = Univ.UContext.instance ctx in + let vc = match Environ.constant_opt_value_in env (sp, u) with | Some vc -> vc | None -> error_not_structure ref in let body = snd (splay_lam (Global.env()) Evd.empty vc) in @@ -290,7 +297,7 @@ let check_and_decompose_canonical_structure ref = | App (f,args) -> f,args | _ -> error_not_structure ref in let indsp = match kind_of_term f with - | Construct (indsp,1) -> indsp + | Construct ((indsp,1),u) -> indsp | _ -> error_not_structure ref in let s = try lookup_structure indsp with Not_found -> error_not_structure ref in let ntrue_projs = List.length (List.filter (fun (_, x) -> x) s.s_PROJKIND) in @@ -304,6 +311,9 @@ let declare_canonical_structure ref = let lookup_canonical_conversion (proj,pat) = List.assoc_f eq_cs_pattern pat (Refmap.find proj !object_table) + (* let cst, u' = destConst cs.o_DEF in *) + (* { cs with o_DEF = mkConstU (cst, u) } *) + let is_open_canonical_projection env sigma (c,args) = try let n = find_projection_nparams (global_of_constr c) in diff --git a/pretyping/recordops.mli b/pretyping/recordops.mli index 42663c014..b1763a359 100644 --- a/pretyping/recordops.mli +++ b/pretyping/recordops.mli @@ -56,6 +56,7 @@ type cs_pattern = type obj_typ = { o_DEF : constr; + o_CTX : Univ.ContextSet.t; o_INJ : int; (** position of trivial argument *) o_TABS : constr list; (** ordered *) o_TPARAMS : constr list; (** ordered *) diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 0b6c3197d..676fc4f3a 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -61,7 +61,7 @@ module ReductionBehaviour = struct let discharge = function | _,(ReqGlobal (ConstRef c, req), (_, b)) -> let c' = pop_con c in - let vars = Lib.section_segment_of_constant c in + let vars, _ctx = Lib.section_segment_of_constant c in let extra = List.length vars in let nargs' = if b.b_nargs < 0 then b.b_nargs else b.b_nargs + extra in let recargs' = List.map ((+) extra) b.b_recargs in @@ -142,6 +142,7 @@ sig type 'a member = | App of 'a app_node | Case of case_info * 'a * 'a array * ('a * 'a list) option + | Proj of int * int * projection | Fix of fixpoint * 'a t * ('a * 'a list) option | Shift of int | Update of 'a @@ -186,6 +187,7 @@ struct type 'a member = | App of 'a app_node | Case of Term.case_info * 'a * 'a array * ('a * 'a list) option + | Proj of int * int * projection | Fix of fixpoint * 'a t * ('a * 'a list) option | Shift of int | Update of 'a @@ -200,6 +202,9 @@ struct str "ZCase(" ++ prvect_with_sep (pr_bar) pr_c br ++ str ")" + | Proj (n,m,p) -> + str "ZProj(" ++ int n ++ pr_comma () ++ int m ++ + pr_comma () ++ pr_con p ++ str ")" | Fix (f,args,cst) -> str "ZFix(" ++ Termops.pr_fix Termops.print_constr f ++ pr_comma () ++ pr pr_c args ++ str ")" @@ -261,6 +266,8 @@ struct | (_, App (i,_,j)::s2) -> compare_rec (bal - j - 1 + i) stk1 s2 | (Case(c1,_,_,_)::s1, Case(c2,_,_,_)::s2) -> Int.equal bal 0 (* && c1.ci_ind = c2.ci_ind *) && compare_rec 0 s1 s2 + | (Proj (n1,m1,p)::s1, Proj(n2,m2,p2)::s2) -> + Int.equal bal 0 && compare_rec 0 s1 s2 | (Fix(_,a1,_)::s1, Fix(_,a2,_)::s2) -> Int.equal bal 0 && compare_rec 0 a1 a2 && compare_rec 0 s1 s2 | (_,_) -> false in @@ -284,6 +291,9 @@ struct aux (fold_array (f o (Vars.lift lft1 t1) (Vars.lift lft2 t2)) a1 a2) lft1 q1 lft2 q2 + | Proj (n1,m1,p1) :: q1, Proj (n2,m2,p2) :: q2 -> + (* MS: FIXME: unsure *) + aux o lft1 q1 lft2 q2 | Fix ((_,(_,a1,b1)),s1,_) :: q1, Fix ((_,(_,a2,b2)),s2,_) :: q2 -> let (o',_,_) = aux (fold_array (fold_array o b1 b2) a1 a2) lft1 s1 lft2 s2 in @@ -323,7 +333,7 @@ struct in aux n [] s let not_purely_applicative args = - List.exists (function (Fix _ | Case _) -> true | _ -> false) args + List.exists (function (Fix _ | Case _ | Proj _) -> true | _ -> false) args let list_of_app_stack s = let rec aux = function | App (i,a,j) :: s -> @@ -379,6 +389,7 @@ struct | f, (Fix (fix,st,_)::s) -> zip ~refold (mkFix fix, st @ (append_app [|f|] s)) | f, (Shift n::s) -> zip ~refold (lift n f, s) + | f, (Proj (n,m,p)::s) -> zip ~refold (mkProj (p,f),s) | _ -> assert false end @@ -388,6 +399,7 @@ type state = constr * constr Stack.t type contextual_reduction_function = env -> evar_map -> constr -> constr type reduction_function = contextual_reduction_function type local_reduction_function = evar_map -> constr -> constr +type e_reduction_function = env -> evar_map -> constr -> evar_map * constr type contextual_stack_reduction_function = env -> evar_map -> constr -> constr * constr list @@ -527,9 +539,17 @@ let magicaly_constant_of_fixbody env bd = function try let cst = Nametab.locate_constant (Libnames.make_qualid DirPath.empty id) in - match constant_opt_value env cst with + let (cst, u), ctx = Universes.fresh_constant_instance env cst in + match constant_opt_value env (cst,u) with | None -> bd - | Some t -> if eq_constr t bd then mkConst cst else bd + | Some (t,cstrs) -> + let b, csts = eq_constr_universes t bd in + let subst = UniverseConstraints.fold (fun (l,d,r) acc -> + Univ.LMap.add (Option.get (Universe.level l)) (Option.get (Universe.level r)) acc) + csts Univ.LMap.empty + in + let inst = Instance.subst_fn (fun u -> Univ.LMap.find u subst) u in + if b then mkConstU (cst,inst) else bd with | Not_found -> bd @@ -550,7 +570,7 @@ let contract_cofix ?env (bodynum,(names,types,bodies as typedbodies)) cst = let reduce_mind_case mia = match kind_of_term mia.mconstr with - | Construct (ind_sp,i) -> + | Construct ((ind_sp,i),u) -> (* let ncargs = (fst mia.mci).(i-1) in*) let real_cargs = List.skipn mia.mci.ci_npar mia.mcargs in applist (mia.mlf.(i-1),real_cargs) @@ -585,6 +605,10 @@ let fix_recarg ((recindices,bodynum),_) stack = with Not_found -> None +type 'a reduced_state = + | NotReducible + | Reduced of constr + (** Generic reduction function with environment Here is where unfolded constant are stored in order to be @@ -625,15 +649,15 @@ let rec whd_state_gen ?csts tactic_mode flags env sigma = (match safe_meta_value sigma ev with | Some body -> whrec cst_l (body, stack) | None -> fold ()) - | Const const when Closure.RedFlags.red_set flags (Closure.RedFlags.fCONST const) -> - (match constant_opt_value env const with + | Const (c,u as const) when Closure.RedFlags.red_set flags (Closure.RedFlags.fCONST c) -> + (match constant_opt_value_in env const with | None -> fold () - | Some body -> + | Some body -> if not tactic_mode - then whrec (Cst_stack.add_cst (mkConst const) cst_l) (body, stack) + then whrec (Cst_stack.add_cst (mkConstU const) cst_l) (body, stack) else (* Looks for ReductionBehaviour *) - match ReductionBehaviour.get (Globnames.ConstRef const) with - | None -> whrec (Cst_stack.add_cst (mkConst const) cst_l) (body, stack) + match ReductionBehaviour.get (Globnames.ConstRef c) with + | None -> whrec (Cst_stack.add_cst (mkConstU const) cst_l) (body, stack) | Some (recargs, nargs, flags) -> if (List.mem `ReductionNeverUnfold flags || (nargs > 0 && Stack.args_size stack < nargs)) @@ -642,7 +666,7 @@ let rec whd_state_gen ?csts tactic_mode flags env sigma = if List.mem `ReductionDontExposeCase flags then let app_sk,sk = Stack.strip_app stack in let (tm',sk'),cst_l' = - whrec (Cst_stack.add_cst (mkConst const) cst_l) (body, app_sk) in + whrec (Cst_stack.add_cst (mkConstU const) cst_l) (body, app_sk) in let f_equal (x,lft1) (y,lft2) = Constr.equal (Vars.lift lft1 x) (Vars.lift lft2 y) in if (match Stack.equal f_equal @@ -660,6 +684,11 @@ let rec whd_state_gen ?csts tactic_mode flags env sigma = whrec cst_l (body, stack) |l -> failwith "TODO recargs in cbn" ) + | Proj (p, c) when Closure.RedFlags.red_set flags (Closure.RedFlags.fCONST p) -> + (match (lookup_constant p env).Declarations.const_proj with + | None -> assert false + | Some pb -> whrec cst_l (c, Stack.Proj (pb.Declarations.proj_npars, pb.Declarations.proj_arg, p) + :: stack)) | LetIn (_,b,_,c) when Closure.RedFlags.red_set flags Closure.RedFlags.fZETA -> apply_subst whrec [b] cst_l c stack | Cast (c,_,_) -> whrec cst_l (c, stack) @@ -698,11 +727,13 @@ let rec whd_state_gen ?csts tactic_mode flags env sigma = |Some (bef,arg,s') -> whrec noth (arg, Stack.Fix(f,bef,Cst_stack.best_cst cst_l)::s')) - | Construct (ind,c) -> + | Construct ((ind,c),u) -> if Closure.RedFlags.red_set flags Closure.RedFlags.fIOTA then match Stack.strip_app stack with |args, (Stack.Case(ci, _, lf,_)::s') -> whrec noth (lf.(c-1), (Stack.tail ci.ci_npar args) @ s') + |args, (Stack.Proj (n,m,p)::s') -> + whrec noth (Stack.nth args (n+m), s') |args, (Stack.Fix (f,s',cst)::s'') -> let x' = Stack.zip(x,args) in whrec noth ((if tactic_mode then contract_fix ~env f else contract_fix f) cst, @@ -720,7 +751,7 @@ let rec whd_state_gen ?csts tactic_mode flags env sigma = |_ -> fold () else fold () - | Rel _ | Var _ | Const _ | LetIn _ -> fold () + | Rel _ | Var _ | Const _ | LetIn _ | Proj _ -> fold () | Sort _ | Ind _ | Prod _ -> fold () in whrec (Option.default noth csts) @@ -752,6 +783,12 @@ let local_whd_state_gen flags sigma = else s | _ -> s) | _ -> s) + + | Proj (p,c) when Closure.RedFlags.red_set flags (Closure.RedFlags.fCONST p) -> + (match (lookup_constant p (Global.env ())).Declarations.const_proj with + | None -> assert false + | Some pb -> whrec (c, Stack.Proj (pb.Declarations.proj_npars, pb.Declarations.proj_arg, p) + :: stack)) | Case (ci,p,d,lf) -> whrec (d, Stack.Case (ci,p,lf,None) :: stack) @@ -771,14 +808,13 @@ let local_whd_state_gen flags sigma = Some c -> whrec (c,stack) | None -> s) - | Construct (ind,c) -> + | Construct ((ind,c),u) -> if Closure.RedFlags.red_set flags Closure.RedFlags.fIOTA then match Stack.strip_app stack with |args, (Stack.Case(ci, _, lf,_)::s') -> whrec (lf.(c-1), (Stack.tail ci.ci_npar args) @ s') - |args, (Stack.Fix (f,s',cst)::s'') -> - let x' = Stack.zip(x,args) in - whrec (contract_fix f cst, s' @ (Stack.append_app [|x'|] s'')) + |args, (Stack.Proj (n,m,p) :: s') -> + whrec (Stack.nth args (n+m), s') |_ -> s else s @@ -899,7 +935,18 @@ let rec whd_evar sigma c = (match safe_evar_value sigma ev with Some c -> whd_evar sigma c | None -> c) - | Sort s -> whd_sort_variable sigma c + | Sort (Type u) -> + let u' = Evd.normalize_universe sigma u in + if u' == u then c else mkSort (Type u') + | Const (c', u) when not (Univ.Instance.is_empty u) -> + let u' = Evd.normalize_universe_instance sigma u in + if u' == u then c else mkConstU (c', u') + | Ind (i, u) when not (Univ.Instance.is_empty u) -> + let u' = Evd.normalize_universe_instance sigma u in + if u' == u then c else mkIndU (i, u') + | Construct (co, u) when not (Univ.Instance.is_empty u) -> + let u' = Evd.normalize_universe_instance sigma u in + if u' == u then c else mkConstructU (co, u') | _ -> c let nf_evar = @@ -916,12 +963,13 @@ let clos_norm_flags flgs env sigma t = (Closure.inject t) with e when is_anomaly e -> error "Tried to normalize ill-typed term" -let nf_beta = clos_norm_flags Closure.beta empty_env -let nf_betaiota = clos_norm_flags Closure.betaiota empty_env -let nf_betaiotazeta = clos_norm_flags Closure.betaiotazeta empty_env +let nf_beta = clos_norm_flags Closure.beta (Global.env ()) +let nf_betaiota = clos_norm_flags Closure.betaiota (Global.env ()) +let nf_betaiotazeta = clos_norm_flags Closure.betaiotazeta (Global.env ()) let nf_betadeltaiota env sigma = clos_norm_flags Closure.betadeltaiota env sigma + (********************************************************************) (* Conversion *) (********************************************************************) @@ -948,32 +996,43 @@ let pb_equal = function | Reduction.CUMUL -> Reduction.CONV | Reduction.CONV -> Reduction.CONV -let sort_cmp = Reduction.sort_cmp +let sort_cmp cv_pb s1 s2 u = + ignore(Reduction.sort_cmp_universes cv_pb s1 s2 (u, None)) -let test_conversion (f: ?l2r:bool-> ?evars:'a->'b) env sigma x y = +let test_trans_conversion (f: ?l2r:bool-> ?evars:'a->'b) reds env sigma x y = try let evars ev = safe_evar_value sigma ev in - let _ = f ~evars env x y in + let _ = f ~evars reds env (Evd.universes sigma) x y in true with Reduction.NotConvertible -> false | e when is_anomaly e -> error "Conversion test raised an anomaly" -let is_conv env sigma = test_conversion Reduction.conv env sigma -let is_conv_leq env sigma = test_conversion Reduction.conv_leq env sigma +let is_trans_conv reds env sigma = test_trans_conversion Reduction.trans_conv_universes reds env sigma +let is_trans_conv_leq reds env sigma = test_trans_conversion Reduction.trans_conv_leq_universes reds env sigma +let is_trans_fconv = function Reduction.CONV -> is_trans_conv | Reduction.CUMUL -> is_trans_conv_leq + +let is_conv = is_trans_conv full_transparent_state +let is_conv_leq = is_trans_conv_leq full_transparent_state let is_fconv = function | Reduction.CONV -> is_conv | Reduction.CUMUL -> is_conv_leq -let test_trans_conversion (f: ?l2r:bool-> ?evars:'a->'b) reds env sigma x y = - try - let evars ev = safe_evar_value sigma ev in - let _ = f ~evars reds env x y in - true - with Reduction.NotConvertible -> false +let check_conv ?(pb=Reduction.CUMUL) ?(ts=full_transparent_state) env sigma x y = + let f = match pb with + | Reduction.CONV -> Reduction.trans_conv_universes + | Reduction.CUMUL -> Reduction.trans_conv_leq_universes in + try f ~evars:(safe_evar_value sigma) ts env (Evd.universes sigma) x y; true + with Reduction.NotConvertible -> false | e when is_anomaly e -> error "Conversion test raised an anomaly" -let is_trans_conv reds env sigma = test_trans_conversion Reduction.trans_conv reds env sigma -let is_trans_conv_leq reds env sigma = test_trans_conversion Reduction.trans_conv_leq reds env sigma -let is_trans_fconv = function | Reduction.CONV -> is_trans_conv | Reduction.CUMUL -> is_trans_conv_leq - +let infer_conv ?(pb=Reduction.CUMUL) ?(ts=full_transparent_state) env sigma x y = + let f = match pb with + | Reduction.CONV -> Reduction.infer_conv + | Reduction.CUMUL -> Reduction.infer_conv_leq in + try + let cstrs = f ~evars:(safe_evar_value sigma) ~ts env (Evd.universes sigma) x y in + Evd.add_constraints sigma cstrs, true + with Reduction.NotConvertible -> sigma, false + | e when is_anomaly e -> error "Conversion test raised an anomaly" + (********************************************************************) (* Special-Purpose Reduction *) (********************************************************************) @@ -1164,6 +1223,14 @@ let whd_betaiota_deltazeta_for_iota_state ts env sigma csts s = let (t_o,stack_o),csts_o = whd_state_gen ~csts:csts' false (Closure.RedFlags.red_add_transparent betadeltaiota ts) env sigma (t,args) in if isConstruct t_o then whrec csts_o (t_o, stack_o@stack') else s,csts' + |args, (Stack.Proj (n,m,p) :: stack'' as stack') -> + let (t_o,stack_o),csts_o = whd_state_gen ~csts:csts' false + (Closure.RedFlags.red_add_transparent betadeltaiota ts) env sigma (t,args) in + if isConstruct t_o then + if Closure.is_transparent_constant ts p then + whrec csts_o (Stack.nth stack_o (n+m), stack'') + else (* Won't unfold *) (whd_betaiota_state sigma (t_o, stack_o@stack'),csts') + else s,csts' |_ -> s,csts' in whrec csts s @@ -1245,6 +1312,17 @@ let meta_reducible_instance evd b = let is_coerce = match s with CoerceToType -> true | _ -> false in if not is_coerce then irec g else u with Not_found -> u) + | Proj (p,c) when isMeta c || isCast c && isMeta (pi1 (destCast c)) -> + let m = try destMeta c with _ -> destMeta (pi1 (destCast c)) in + (match + try + let g, s = Metamap.find m metas in + let is_coerce = match s with CoerceToType -> true | _ -> false in + if isConstruct g || not is_coerce then Some g else None + with Not_found -> None + with + | Some g -> irec (mkProj (p,g)) + | None -> mkProj (p,c)) | _ -> map_constr irec u in if Metaset.is_empty fm then (* nf_betaiota? *) b.rebus @@ -1252,12 +1330,12 @@ let meta_reducible_instance evd b = let head_unfold_under_prod ts env _ c = - let unfold cst = + let unfold (cst,u as cstu) = if Cpred.mem cst (snd ts) then - match constant_opt_value env cst with + match constant_opt_value_in env cstu with | Some c -> c - | None -> mkConst cst - else mkConst cst in + | None -> mkConstU cstu + else mkConstU cstu in let rec aux c = match kind_of_term c with | Prod (n,t,c) -> mkProd (n,aux t, aux c) diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index 5ba0d74ec..29d7a6b2f 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -17,7 +17,7 @@ open Environ exception Elimconst -(** Machinery to custom the behavior of the reduction *) +(** Machinery to customize the behavior of the reduction *) module ReductionBehaviour : sig type flag = [ `ReductionDontExposeCase | `ReductionNeverUnfold ] @@ -37,6 +37,7 @@ module Stack : sig type 'a member = | App of 'a app_node | Case of case_info * 'a * 'a array * ('a * 'a list) option + | Proj of int * int * projection | Fix of fixpoint * 'a t * ('a * 'a list) option | Shift of int | Update of 'a @@ -82,6 +83,8 @@ type contextual_reduction_function = env -> evar_map -> constr -> constr type reduction_function = contextual_reduction_function type local_reduction_function = evar_map -> constr -> constr +type e_reduction_function = env -> evar_map -> constr -> evar_map * constr + type contextual_stack_reduction_function = env -> evar_map -> constr -> constr * constr list type stack_reduction_function = contextual_stack_reduction_function @@ -203,6 +206,7 @@ val splay_prod_n : env -> evar_map -> int -> constr -> rel_context * constr val splay_lam_n : env -> evar_map -> int -> constr -> rel_context * constr val splay_prod_assum : env -> evar_map -> constr -> rel_context * constr +val is_sort : env -> evar_map -> types -> bool type 'a miota_args = { mP : constr; (** the result type *) @@ -223,7 +227,7 @@ val contract_fix : ?env:Environ.env -> fixpoint -> val fix_recarg : fixpoint -> constr Stack.t -> (int * constr) option (** {6 Querying the kernel conversion oracle: opaque/transparent constants } *) -val is_transparent : Environ.env -> 'a tableKey -> bool +val is_transparent : Environ.env -> constant tableKey -> bool (** {6 Conversion Functions (uses closures, lazy strategy) } *) @@ -232,7 +236,7 @@ type conversion_test = constraints -> constraints val pb_is_equal : conv_pb -> bool val pb_equal : conv_pb -> conv_pb -val sort_cmp : conv_pb -> sorts -> sorts -> conversion_test +val sort_cmp : conv_pb -> sorts -> sorts -> universes -> unit val is_conv : env -> evar_map -> constr -> constr -> bool val is_conv_leq : env -> evar_map -> constr -> constr -> bool @@ -242,6 +246,17 @@ val is_trans_conv : transparent_state -> env -> evar_map -> constr -> constr -> val is_trans_conv_leq : transparent_state -> env -> evar_map -> constr -> constr -> bool val is_trans_fconv : conv_pb -> transparent_state -> env -> evar_map -> constr -> constr -> bool +(** [check_conv} Checks universe constraints only. + pb defaults to CUMUL and ts to a full transparent state. + *) +val check_conv : ?pb:conv_pb -> ?ts:transparent_state -> env -> evar_map -> constr -> constr -> bool + +(** [infer_fconv] Adds necessary universe constraints to the evar map. + pb defaults to CUMUL and ts to a full transparent state. + *) +val infer_conv : ?pb:conv_pb -> ?ts:transparent_state -> env -> evar_map -> constr -> constr -> + evar_map * bool + (** {6 Special-Purpose Reduction Functions } *) val whd_meta : evar_map -> constr -> constr diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index c66ca7ac1..31487125a 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -85,9 +85,10 @@ let type_of_var env id = try let (_,_,ty) = lookup_named id env in ty with Not_found -> retype_error (BadVariable id) -let is_impredicative_set env = match Environ.engagement env with -| Some ImpredicativeSet -> true -| _ -> false +let decomp_sort env sigma t = + match kind_of_term (whd_betadeltaiota env sigma t) with + | Sort s -> s + | _ -> retype_error NotASort let retype ?(polyprop=true) sigma = let rec type_of env cstr= @@ -99,7 +100,7 @@ let retype ?(polyprop=true) sigma = let (_,_,ty) = lookup_rel n env in lift n ty | Var id -> type_of_var env id - | Const cst -> Typeops.type_of_constant env cst + | Const cst -> Typeops.type_of_constant_in env cst | Evar ev -> Evd.existential_type sigma ev | Ind ind -> type_of_inductive env ind | Construct cstr -> type_of_constructor env cstr @@ -129,6 +130,13 @@ let retype ?(polyprop=true) sigma = | App(f,args) -> strip_outer_cast (subst_type env sigma (type_of env f) (Array.to_list args)) + | Proj (p,c) -> + let Inductiveops.IndType(pars,realargs) = + try Inductiveops.find_rectype env sigma (type_of env c) + with Not_found -> anomaly ~label:"type_of" (str "Bad recursive type") + in + let (_,u), pars = dest_ind_family pars in + substl (c :: List.rev pars) (Typeops.type_of_projection env (p,u)) | Cast (c,_, t) -> t | Sort _ | Prod _ -> mkSort (sort_of env cstr) @@ -142,15 +150,13 @@ let retype ?(polyprop=true) sigma = | _, (Prop Null as s) -> s | Prop _, (Prop Pos as s) -> s | Type _, (Prop Pos as s) when is_impredicative_set env -> s - | (Type _, _) | (_, Type _) -> new_Type_sort () -(* | Type u1, Prop Pos -> Type (Univ.sup u1 Univ.type0_univ) | Prop Pos, (Type u2) -> Type (Univ.sup Univ.type0_univ u2) | Prop Null, (Type _ as s) -> s - | Type u1, Type u2 -> Type (Univ.sup u1 u2)*)) - | App(f,args) when isGlobalRef f -> - let t = type_of_global_reference_knowing_parameters env f args in - sort_of_atomic_type env sigma t args + | Type u1, Type u2 -> Type (Univ.sup u1 u2)) + (* | App(f,args) when isGlobalRef f -> *) + (* let t = type_of_global_reference_knowing_parameters env f args in *) + (* sort_of_atomic_type env sigma t args *) | App(f,args) -> sort_of_atomic_type env sigma (type_of env f) args | Lambda _ | Fix _ | Construct _ -> retype_error NotAType | _ -> decomp_sort env sigma (type_of env t) @@ -178,12 +184,12 @@ let retype ?(polyprop=true) sigma = Array.map (fun c -> lazy (nf_evar sigma (type_of env c))) args in match kind_of_term c with | Ind ind -> - let (_,mip) = lookup_mind_specif env ind in + let mip = lookup_mind_specif env (fst ind) in (try Inductive.type_of_inductive_knowing_parameters - ~polyprop env mip argtyps + ~polyprop env (mip,snd ind) argtyps with Reduction.NotArity -> retype_error NotAnArity) | Const cst -> - let t = constant_type env cst in + let t = constant_type_in env cst in (try Typeops.type_of_constant_knowing_parameters env t argtyps with Reduction.NotArity -> retype_error NotAnArity) | Var id -> type_of_var env id @@ -203,24 +209,31 @@ let type_of_global_reference_knowing_parameters env sigma c args = let type_of_global_reference_knowing_conclusion env sigma c conclty = let conclty = nf_evar sigma conclty in match kind_of_term c with - | Ind ind -> - let (_,mip) = Inductive.lookup_mind_specif env ind in - type_of_inductive_knowing_conclusion env mip conclty + | Ind (ind,u) -> + let spec = Inductive.lookup_mind_specif env ind in + type_of_inductive_knowing_conclusion env (spec,u) conclty | Const cst -> - let t = constant_type env cst in + let t = constant_type_in env cst in (* TODO *) Typeops.type_of_constant_knowing_parameters env t [||] | Var id -> type_of_var env id | Construct cstr -> type_of_constructor env cstr | _ -> assert false -(* We are outside the kernel: we take fresh universes *) -(* to avoid tactics and co to refresh universes themselves *) -let get_type_of ?(polyprop=true) ?(refresh=true) ?(lax=false) env sigma c = +(* Profiling *) +(* let get_type_of polyprop lax env sigma c = *) +(* let f,_,_,_ = retype ~polyprop sigma in *) +(* if lax then f env c else anomaly_on_error (f env) c *) + +(* let get_type_of_key = Profile.declare_profile "get_type_of" *) +(* let get_type_of = Profile.profile5 get_type_of_key get_type_of *) + +(* let get_type_of ?(polyprop=true) ?(lax=false) env sigma c = *) +(* get_type_of polyprop lax env sigma c *) + +let get_type_of ?(polyprop=true) ?(lax=false) env sigma c = let f,_,_,_ = retype ~polyprop sigma in - let t = if lax then f env c else anomaly_on_error (f env) c in - if refresh then refresh_universes t else t + if lax then f env c else anomaly_on_error (f env) c (* Makes an unsafe judgment from a constr *) let get_judgment_of env evc c = { uj_val = c; uj_type = get_type_of env evc c } - diff --git a/pretyping/retyping.mli b/pretyping/retyping.mli index c2a08f4b9..fc1dd3564 100644 --- a/pretyping/retyping.mli +++ b/pretyping/retyping.mli @@ -26,8 +26,7 @@ type retype_error exception RetypeError of retype_error val get_type_of : - ?polyprop:bool -> ?refresh:bool -> ?lax:bool -> - env -> evar_map -> constr -> types + ?polyprop:bool -> ?lax:bool -> env -> evar_map -> constr -> types val get_sort_of : ?polyprop:bool -> env -> evar_map -> types -> sorts diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index dd7542fc7..da4595254 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -41,7 +41,8 @@ let error_not_evaluable r = spc () ++ str "to an evaluable reference.") let is_evaluable_const env cst = - is_transparent env (ConstKey cst) && evaluable_constant cst env + is_transparent env (ConstKey cst) && + (evaluable_constant cst env || is_projection cst env) let is_evaluable_var env id = is_transparent env (VarKey id) && evaluable_named id env @@ -50,12 +51,17 @@ let is_evaluable env = function | EvalConstRef cst -> is_evaluable_const env cst | EvalVarRef id -> is_evaluable_var env id -let value_of_evaluable_ref env = function - | EvalConstRef con -> constant_value env con +let value_of_evaluable_ref env evref u = + match evref with + | EvalConstRef con -> + (try constant_value_in env (con,u) + with NotEvaluableConst IsProj -> + raise (Invalid_argument "value_of_evaluable_ref")) | EvalVarRef id -> Option.get (pi2 (lookup_named id env)) -let constr_of_evaluable_ref = function - | EvalConstRef con -> mkConst con +let constr_of_evaluable_ref evref u = + match evref with + | EvalConstRef con -> mkConstU (con,u) | EvalVarRef id -> mkVar id let evaluable_of_global_reference env = function @@ -81,27 +87,43 @@ let evaluable_reference_eq r1 r2 = match r1, r2 with Evar.equal e1 e2 && Array.equal eq_constr ctx1 ctx2 | _ -> false -let mkEvalRef = function - | EvalConst cst -> mkConst cst +let mkEvalRef ref u = + match ref with + | EvalConst cst -> mkConstU (cst,u) | EvalVar id -> mkVar id | EvalRel n -> mkRel n | EvalEvar ev -> mkEvar ev let isEvalRef env c = match kind_of_term c with - | Const sp -> is_evaluable env (EvalConstRef sp) + | Const (sp,_) -> is_evaluable env (EvalConstRef sp) | Var id -> is_evaluable env (EvalVarRef id) | Rel _ | Evar _ -> true | _ -> false -let destEvalRef c = match kind_of_term c with - | Const cst -> EvalConst cst - | Var id -> EvalVar id - | Rel n -> EvalRel n - | Evar ev -> EvalEvar ev +let destEvalRefU c = match kind_of_term c with + | Const (cst,u) -> EvalConst cst, u + | Var id -> (EvalVar id, Univ.Instance.empty) + | Rel n -> (EvalRel n, Univ.Instance.empty) + | Evar ev -> (EvalEvar ev, Univ.Instance.empty) | _ -> anomaly (Pp.str "Not an unfoldable reference") -let reference_opt_value sigma env = function - | EvalConst cst -> constant_opt_value env cst +let unsafe_reference_opt_value sigma env eval = + match eval with + | EvalConst cst -> + (match (lookup_constant cst env).Declarations.const_body with + | Declarations.Def c -> Some (Mod_subst.force_constr c) + | _ -> None) + | EvalVar id -> + let (_,v,_) = lookup_named id env in + v + | EvalRel n -> + let (_,v,_) = lookup_rel n env in + Option.map (lift n) v + | EvalEvar ev -> Evd.existential_opt_value sigma ev + +let reference_opt_value sigma env eval u = + match eval with + | EvalConst cst -> constant_opt_value_in env (cst,u) | EvalVar id -> let (_,v,_) = lookup_named id env in v @@ -111,8 +133,8 @@ let reference_opt_value sigma env = function | EvalEvar ev -> Evd.existential_opt_value sigma ev exception NotEvaluable -let reference_value sigma env c = - match reference_opt_value sigma env c with +let reference_value sigma env c u = + match reference_opt_value sigma env c u with | None -> raise NotEvaluable | Some d -> d @@ -127,6 +149,7 @@ type constant_evaluation = ((int*evaluable_reference) option array * (int * (int * constr) list * int)) | EliminationCases of int + | EliminationProj of int | NotAnElimination (* We use a cache registered as a global table *) @@ -215,7 +238,7 @@ let invert_name labs l na0 env sigma ref = function match refi with | None -> None | Some ref -> - try match reference_opt_value sigma env ref with + try match unsafe_reference_opt_value sigma env ref with | None -> None | Some c -> let labs',ccl = decompose_lam c in @@ -243,9 +266,10 @@ let compute_consteval_direct sigma env ref = (try check_fix_reversibility labs l fix with Elimconst -> NotAnElimination) | Case (_,_,d,_) when isRel d -> EliminationCases n + | Proj (p, d) when isRel d -> EliminationProj n | _ -> NotAnElimination in - match reference_opt_value sigma env ref with + match unsafe_reference_opt_value sigma env ref with | None -> NotAnElimination | Some c -> srec env 0 [] c @@ -270,13 +294,13 @@ let compute_consteval_mutual_fix sigma env ref = | _ -> assert false) | _ when isEvalRef env c' -> (* Forget all \'s and args and do as if we had started with c' *) - let ref = destEvalRef c' in - (match reference_opt_value sigma env ref with + let ref,_ = destEvalRefU c' in + (match unsafe_reference_opt_value sigma env ref with | None -> anomaly (Pp.str "Should have been trapped by compute_direct") | Some c -> srec env (minarg-nargs) [] ref c) | _ -> (* Should not occur *) NotAnElimination in - match reference_opt_value sigma env ref with + match unsafe_reference_opt_value sigma env ref with | None -> (* Should not occur *) NotAnElimination | Some c -> srec env 0 [] ref c @@ -320,7 +344,7 @@ let reference_eval sigma env = function let x = Name (Id.of_string "x") -let make_elim_fun (names,(nbfix,lv,n)) largs = +let make_elim_fun (names,(nbfix,lv,n)) u largs = let lu = List.firstn n largs in let p = List.length lv in let lyi = List.map fst lv in @@ -335,7 +359,7 @@ let make_elim_fun (names,(nbfix,lv,n)) largs = match names.(i) with | None -> None | Some (minargs,ref) -> - let body = applistc (mkEvalRef ref) la in + let body = applistc (mkEvalRef ref u) la in let g = List.fold_left_i (fun q (* j = n+1-q *) c (ij,tij) -> let subst = List.map (lift (-q)) (List.firstn (n-ij) la) in @@ -392,8 +416,9 @@ let solve_arity_problem env sigma fxminargs c = else raise Partial; List.iter (check strict) rcargs | (Var _|Const _) when isEvalRef env h -> - (match reference_opt_value sigma env (destEvalRef h) with - Some h' -> + (let ev, u = destEvalRefU h in + match reference_opt_value sigma env ev u with + | Some h' -> let bak = !evm in (try List.iter (check false) rcargs with Partial -> @@ -465,7 +490,7 @@ let contract_cofix_use_function env sigma f let reduce_mind_case_use_function func env sigma mia = match kind_of_term mia.mconstr with - | Construct(ind_sp,i) -> + | Construct ((ind_sp,i),u) -> let real_cargs = List.skipn mia.mci.ci_npar mia.mcargs in applist (mia.mlf.(i-1), real_cargs) | CoFix (bodynum,(names,_,_) as cofix) -> @@ -481,12 +506,13 @@ let reduce_mind_case_use_function func env sigma mia = mutual inductive, try to reuse the global name if the block was indeed initially built as a global definition *) - let kn = con_with_label (destConst func) (Label.of_id id) + let kn = map_puniverses (fun x -> con_with_label x (Label.of_id id)) + (destConst func) in - try match constant_opt_value env kn with + try match constant_opt_value_in env kn with | None -> None (* TODO: check kn is correct *) - | Some _ -> Some (minargs,mkConst kn) + | Some _ -> Some (minargs,mkConstU kn) with Not_found -> None else fun _ -> None in @@ -495,21 +521,42 @@ let reduce_mind_case_use_function func env sigma mia = mkCase (mia.mci, mia.mP, applist(cofix_def,mia.mcargs), mia.mlf) | _ -> assert false + +let match_eval_ref env constr = + match kind_of_term constr with + | Const (sp, u) when is_evaluable env (EvalConstRef sp) -> + Some (EvalConst sp, u) + | Var id when is_evaluable env (EvalVarRef id) -> Some (EvalVar id, Univ.Instance.empty) + | Rel i -> Some (EvalRel i, Univ.Instance.empty) + | Evar ev -> Some (EvalEvar ev, Univ.Instance.empty) + | _ -> None + +let match_eval_ref_value sigma env constr = + match kind_of_term constr with + | Const (sp, u) when is_evaluable env (EvalConstRef sp) -> + Some (constant_value_in env (sp, u)) + | Var id when is_evaluable env (EvalVarRef id) -> + let (_,v,_) = lookup_named id env in v + | Rel n -> let (_,v,_) = lookup_rel n env in + Option.map (lift n) v + | Evar ev -> Evd.existential_opt_value sigma ev + | _ -> None + let special_red_case env sigma whfun (ci, p, c, lf) = let rec redrec s = let (constr, cargs) = whfun s in - if isEvalRef env constr then - let ref = destEvalRef constr in - match reference_opt_value sigma env ref with - | None -> raise Redelimination - | Some gvalue -> - if reducible_mind_case gvalue then - reduce_mind_case_use_function constr env sigma - {mP=p; mconstr=gvalue; mcargs=cargs; - mci=ci; mlf=lf} - else - redrec (applist(gvalue, cargs)) - else + match match_eval_ref env constr with + | Some (ref, u) -> + (match reference_opt_value sigma env ref u with + | None -> raise Redelimination + | Some gvalue -> + if reducible_mind_case gvalue then + reduce_mind_case_use_function constr env sigma + {mP=p; mconstr=gvalue; mcargs=cargs; + mci=ci; mlf=lf} + else + redrec (applist(gvalue, cargs))) + | None -> if reducible_mind_case constr then reduce_mind_case {mP=p; mconstr=constr; mcargs=cargs; @@ -524,6 +571,34 @@ let recargs = function | EvalConst c -> Option.map (fun (x,y,_) -> (x,y)) (ReductionBehaviour.get (ConstRef c)) +let reduce_projection env sigma proj (recarg'hd,stack') stack = + (match kind_of_term recarg'hd with + | Construct _ -> + let proj_narg = + let pb = Option.get ((lookup_constant proj env).Declarations.const_proj) in + pb.Declarations.proj_npars + pb.Declarations.proj_arg + in Reduced (List.nth stack' proj_narg, stack) + | _ -> NotReducible) + +let reduce_proj env sigma whfun c = + (* Pp.msgnl (str" reduce_proj: " ++ print_constr c); *) + let rec redrec s = + match kind_of_term s with + | Proj (proj, c) -> + let c' = try redrec c with Redelimination -> c in + let constr, cargs = whfun c' in + (* Pp.msgnl (str" reduce_proj: constructor: " ++ print_constr constr); *) + (match kind_of_term constr with + | Construct _ -> + let proj_narg = + let pb = Option.get ((lookup_constant proj env).Declarations.const_proj) in + pb.Declarations.proj_npars + pb.Declarations.proj_arg + in List.nth cargs proj_narg + | _ -> raise Redelimination) + | _ -> raise Redelimination + in redrec c + + let dont_expose_case = function | EvalVar _ | EvalRel _ | EvalEvar _ -> false | EvalConst c -> @@ -547,8 +622,8 @@ let whd_nothing_for_iota env sigma s = | Meta ev -> (try whrec (Evd.meta_value sigma ev, stack) with Not_found -> s) - | Const const when is_transparent_constant full_transparent_state const -> - (match constant_opt_value env const with + | Const const when is_transparent_constant full_transparent_state (fst const) -> + (match constant_opt_value_in env const with | Some body -> whrec (body, stack) | None -> s) | LetIn (_,b,_,c) -> stacklam whrec [b] c stack @@ -567,7 +642,7 @@ let whd_nothing_for_iota env sigma s = constants by keeping the name of the constants in the recursive calls; it fails if no redex is around *) -let rec red_elim_const env sigma ref largs = +let rec red_elim_const env sigma ref u largs = let nargs = List.length largs in let largs, unfold_anyway, unfold_nonelim = match recargs ref with @@ -586,39 +661,44 @@ let rec red_elim_const env sigma ref largs = n >= 0 && not is_empty && nargs >= n in try match reference_eval sigma env ref with | EliminationCases n when nargs >= n -> - let c = reference_value sigma env ref in + let c = reference_value sigma env ref u in let c', lrest = whd_nothing_for_iota env sigma (applist(c,largs)) in let whfun = whd_simpl_stack env sigma in (special_red_case env sigma whfun (destCase c'), lrest) + | EliminationProj n when nargs >= n -> + let c = reference_value sigma env ref u in + let c', lrest = whd_nothing_for_iota env sigma (applist(c,largs)) in + let whfun = whd_construct_stack env sigma in + (reduce_proj env sigma whfun c', lrest) | EliminationFix (min,minfxargs,infos) when nargs >= min -> - let c = reference_value sigma env ref in + let c = reference_value sigma env ref u in let d, lrest = whd_nothing_for_iota env sigma (applist(c,largs)) in - let f = make_elim_fun ([|Some (minfxargs,ref)|],infos) largs in + let f = make_elim_fun ([|Some (minfxargs,ref)|],infos) u largs in let whfun = whd_construct_stack env sigma in (match reduce_fix_use_function env sigma f whfun (destFix d) lrest with | NotReducible -> raise Redelimination | Reduced (c,rest) -> (nf_beta sigma c, rest)) | EliminationMutualFix (min,refgoal,refinfos) when nargs >= min -> - let rec descend ref args = - let c = reference_value sigma env ref in + let rec descend (ref,u) args = + let c = reference_value sigma env ref u in if evaluable_reference_eq ref refgoal then (c,args) else let c', lrest = whd_betalet_stack sigma (applist(c,args)) in - descend (destEvalRef c') lrest in - let (_, midargs as s) = descend ref largs in + descend (destEvalRefU c') lrest in + let (_, midargs as s) = descend (ref,u) largs in let d, lrest = whd_nothing_for_iota env sigma (applist s) in - let f = make_elim_fun refinfos midargs in + let f = make_elim_fun refinfos u midargs in let whfun = whd_construct_stack env sigma in (match reduce_fix_use_function env sigma f whfun (destFix d) lrest with | NotReducible -> raise Redelimination | Reduced (c,rest) -> (nf_beta sigma c, rest)) | NotAnElimination when unfold_nonelim -> - let c = reference_value sigma env ref in + let c = reference_value sigma env ref u in whd_betaiotazeta sigma (applist (c, largs)), [] | _ -> raise Redelimination with Redelimination when unfold_anyway -> - let c = reference_value sigma env ref in + let c = reference_value sigma env ref u in whd_betaiotazeta sigma (applist (c, largs)), [] (* reduce to whd normal form or to an applied constant that does not hide @@ -645,20 +725,31 @@ and whd_simpl_stack env sigma = | Reduced s' -> redrec (applist s') | NotReducible -> s' with Redelimination -> s') - | _ when isEvalRef env x -> - let ref = destEvalRef x in + + | Proj (p, c) -> + (try + (match recargs (EvalConst p) with + | Some (_, n) when n > 1 -> (* simpl never *) s' + | _ -> + match reduce_projection env sigma p (whd_construct_stack env sigma c) stack with + | Reduced s' -> redrec (applist s') + | NotReducible -> s') + with Redelimination -> s') + + | _ -> + match match_eval_ref env x with + | Some (ref, u) -> (try - let hd, _ as s'' = redrec (applist(red_elim_const env sigma ref stack)) in - let rec is_case x = match kind_of_term x with - | Lambda (_,_, x) | LetIn (_,_,_, x) | Cast (x, _,_) -> is_case x - | App (hd, _) -> is_case hd - | Case _ -> true - | _ -> false in - if dont_expose_case ref && is_case hd then raise Redelimination - else s'' - with Redelimination -> - s') - | _ -> s' + let hd, _ as s'' = redrec (applist(red_elim_const env sigma ref u stack)) in + let rec is_case x = match kind_of_term x with + | Lambda (_,_, x) | LetIn (_,_,_, x) | Cast (x, _,_) -> is_case x + | App (hd, _) -> is_case hd + | Case _ -> true + | _ -> false in + if dont_expose_case ref && is_case hd then raise Redelimination + else s'' + with Redelimination -> s') + | None -> s' in redrec @@ -667,13 +758,12 @@ and whd_simpl_stack env sigma = and whd_construct_stack env sigma s = let (constr, cargs as s') = whd_simpl_stack env sigma s in if reducible_mind_case constr then s' - else if isEvalRef env constr then - let ref = destEvalRef constr in - match reference_opt_value sigma env ref with - | None -> raise Redelimination - | Some gvalue -> whd_construct_stack env sigma (applist(gvalue, cargs)) - else - raise Redelimination + else match match_eval_ref env constr with + | Some (ref, u) -> + (match reference_opt_value sigma env ref u with + | None -> raise Redelimination + | Some gvalue -> whd_construct_stack env sigma (applist(gvalue, cargs))) + | _ -> raise Redelimination (************************************************************************) (* Special Purpose Reduction Strategies *) @@ -703,14 +793,24 @@ let try_red_product env sigma c = | Prod (x,a,b) -> mkProd (x, a, redrec (push_rel (x,None,a) env) b) | LetIn (x,a,b,t) -> redrec env (subst1 a t) | Case (ci,p,d,lf) -> simpfun (mkCase (ci,p,redrec env d,lf)) - | _ when isEvalRef env x -> + | Proj (p, c) -> + let c' = + match kind_of_term c with + | Construct _ -> c + | _ -> redrec env c + in + (match reduce_projection env sigma p (whd_betaiotazeta_stack sigma c') [] with + | Reduced s -> simpfun (applist s) + | NotReducible -> raise Redelimination) + | _ -> + (match match_eval_ref env x with + | Some (ref, u) -> (* TO DO: re-fold fixpoints after expansion *) (* to get true one-step reductions *) - let ref = destEvalRef x in - (match reference_opt_value sigma env ref with + (match reference_opt_value sigma env ref u with | None -> raise Redelimination | Some c -> c) - | _ -> raise Redelimination + | _ -> raise Redelimination) in redrec env c let red_product env sigma c = @@ -778,14 +878,13 @@ let whd_simpl_orelse_delta_but_fix_old env sigma c = let whd_simpl_orelse_delta_but_fix env sigma c = let rec redrec s = let (constr, stack as s') = whd_simpl_stack env sigma s in - if isEvalRef env constr then - match reference_opt_value sigma env (destEvalRef constr) with - | Some c -> - (match kind_of_term (strip_lam c) with - | CoFix _ | Fix _ -> s' - | _ -> redrec (applist(c, stack))) - | None -> s' - else s' in + match match_eval_ref_value sigma env constr with + | Some c -> + (match kind_of_term (strip_lam c) with + | CoFix _ | Fix _ -> s' + | _ -> redrec (applist(c, stack))) + | None -> s' + in let simpfun = clos_norm_flags betaiota env sigma in simpfun (applist (redrec c)) @@ -803,12 +902,14 @@ let simpl env sigma c = strong whd_simpl env sigma c let matches_head c t = match kind_of_term t with | App (f,_) -> ConstrMatching.matches c f + | Proj (p, _) -> ConstrMatching.matches c (mkConst p) | _ -> raise ConstrMatching.PatternMatchingFailure -let contextually byhead (occs,c) f env sigma t = +let e_contextually byhead (occs,c) f env sigma t = let (nowhere_except_in,locs) = Locusops.convert_occs occs in let maxocc = List.fold_right max locs 0 in let pos = ref 1 in + let evd = ref sigma in let rec traverse (env,c as envc) t = if nowhere_except_in && (!pos > maxocc) then t else @@ -821,11 +922,15 @@ let contextually byhead (occs,c) f env sigma t = incr pos; if ok then let subst' = Id.Map.map (traverse envc) subst in - f subst' env sigma t + let evm, t = f subst' env !evd t in + (evd := evm; t) else if byhead then (* find other occurrences of c in t; TODO: ensure left-to-right *) - let (f,l) = destApp t in - mkApp (f, Array.map_left (traverse envc) l) + (match kind_of_term t with + | App (f,l) -> + mkApp (f, Array.map_left (traverse envc) l) + | Proj (p,c) -> mkProj (p,traverse envc c) + | _ -> assert false) else t with ConstrMatching.PatternMatchingFailure -> @@ -835,30 +940,45 @@ let contextually byhead (occs,c) f env sigma t = in let t' = traverse (env,c) t in if List.exists (fun o -> o >= !pos) locs then error_invalid_occurrence locs; - t' + !evd, t' + +let contextually byhead occs f env sigma t = + let f' subst env sigma t = sigma, f subst env sigma t in + snd (e_contextually byhead occs f' env sigma t) (* linear bindings (following pretty-printer) of the value of name in c. * n is the number of the next occurence of name. * ol is the occurence list to find. *) -let substlin env evalref n (nowhere_except_in,locs) c = +let match_constr_evaluable_ref sigma c evref = + match kind_of_term c, evref with + | Const (c,u), EvalConstRef c' when eq_constant c c' -> Some u + | Proj (p,c), EvalConstRef p' when eq_constant p p' -> Some Univ.Instance.empty + | Var id, EvalVarRef id' when id_eq id id' -> Some Univ.Instance.empty + | _, _ -> None + +let substlin env sigma evalref n (nowhere_except_in,locs) c = let maxocc = List.fold_right max locs 0 in let pos = ref n in assert (List.for_all (fun x -> x >= 0) locs); - let value = value_of_evaluable_ref env evalref in - let term = constr_of_evaluable_ref evalref in + let value u = + value_of_evaluable_ref env evalref u + (* Some (whd_betaiotazeta sigma c) *) + in let rec substrec () c = if nowhere_except_in && !pos > maxocc then c - else if eq_constr c term then - let ok = - if nowhere_except_in then Int.List.mem !pos locs - else not (Int.List.mem !pos locs) in - incr pos; - if ok then value else c - else - map_constr_with_binders_left_to_right - (fun _ () -> ()) - substrec () c + else + match match_constr_evaluable_ref sigma c evalref with + | Some u -> + let ok = + if nowhere_except_in then Int.List.mem !pos locs + else not (Int.List.mem !pos locs) in + incr pos; + if ok then value u else c + | None -> + map_constr_with_binders_left_to_right + (fun _ () -> ()) + substrec () c in let t' = substrec () c in (!pos, t') @@ -881,7 +1001,7 @@ let unfold env sigma name = * Performs a betaiota reduction after unfolding. *) let unfoldoccs env sigma (occs,name) c = let unfo nowhere_except_in locs = - let (nbocc,uc) = substlin env name 1 (nowhere_except_in,locs) c in + let (nbocc,uc) = substlin env sigma name 1 (nowhere_except_in,locs) c in if Int.equal nbocc 1 then error ((string_of_evaluable_ref env name)^" does not occur."); let rest = List.filter (fun o -> o >= nbocc) locs in @@ -934,6 +1054,22 @@ let compute = cbv_betadeltaiota (* Pattern *) +let make_eq_univs_test evd c = + { match_fun = (fun evd c' -> + let b, cst = eq_constr_universes c c' in + if b then + try Evd.add_universe_constraints evd cst + with Evd.UniversesDiffer -> raise NotUnifiable + else raise NotUnifiable); + merge_fun = (fun evd _ -> evd); + testing_state = evd; + last_found = None +} +let subst_closed_term_univs_occ evd occs c t = + let test = make_eq_univs_test evd c in + let t' = subst_closed_term_occ_modulo occs test None t in + t', test.testing_state + (* gives [na:ta]c' such that c converts to ([na:ta]c' a), abstracting only * the specified occurrences. *) @@ -944,7 +1080,8 @@ let abstract_scheme env sigma (locc,a) c = if occur_meta a then mkLambda (na,ta,c) else - mkLambda (na,ta,subst_closed_term_occ locc a c) + let c', sigma' = subst_closed_term_univs_occ sigma locc a c in + mkLambda (na,ta,c') let pattern_occs loccs_trm env sigma c = let abstr_trm = List.fold_right (abstract_scheme env sigma) loccs_trm c in @@ -1011,11 +1148,11 @@ let one_step_reduce env sigma c = | Reduced s' -> s' | NotReducible -> raise NotStepReducible) | _ when isEvalRef env x -> - let ref = destEvalRef x in + let ref,u = destEvalRefU x in (try - red_elim_const env sigma ref stack + red_elim_const env sigma ref u stack with Redelimination -> - match reference_opt_value sigma env ref with + match reference_opt_value sigma env ref u with | Some d -> (d, stack) | None -> raise NotStepReducible) @@ -1027,7 +1164,7 @@ let isIndRef = function IndRef _ -> true | _ -> false let reduce_to_ref_gen allow_product env sigma ref t = if isIndRef ref then - let (mind,t) = reduce_to_ind_gen allow_product env sigma t in + let ((mind,u),t) = reduce_to_ind_gen allow_product env sigma t in begin match ref with | IndRef mind' when eq_ind mind mind' -> t | _ -> diff --git a/pretyping/tacred.mli b/pretyping/tacred.mli index 34aca3e33..5146cd345 100644 --- a/pretyping/tacred.mli +++ b/pretyping/tacred.mli @@ -59,8 +59,17 @@ val unfoldn : (** Fold *) val fold_commands : constr list -> reduction_function +val make_eq_univs_test : evar_map -> constr -> evar_map Termops.testing_function + +(** [subst_closed_term_occ occl c d] replaces occurrences of closed [c] at + positions [occl] by [Rel 1] in [d] (see also Note OCC), unifying universes + which results in a set of constraints. *) +val subst_closed_term_univs_occ : evar_map -> occurrences -> constr -> constr -> + constr * evar_map + (** Pattern *) -val pattern_occs : (occurrences * constr) list -> reduction_function +val pattern_occs : (occurrences * constr) list -> env -> evar_map -> constr -> + constr (** Rem: Lazy strategies are defined in Reduction *) @@ -74,12 +83,12 @@ val cbv_norm_flags : Closure.RedFlags.reds -> reduction_function (** [reduce_to_atomic_ind env sigma t] puts [t] in the form [t'=(I args)] with [I] an inductive definition; returns [I] and [t'] or fails with a user error *) -val reduce_to_atomic_ind : env -> evar_map -> types -> inductive * types +val reduce_to_atomic_ind : env -> evar_map -> types -> pinductive * types (** [reduce_to_quantified_ind env sigma t] puts [t] in the form [t'=(x1:A1)..(xn:An)(I args)] with [I] an inductive definition; returns [I] and [t'] or fails with a user error *) -val reduce_to_quantified_ind : env -> evar_map -> types -> inductive * types +val reduce_to_quantified_ind : env -> evar_map -> types -> pinductive * types (** [reduce_to_quantified_ref env sigma ref t] try to put [t] in the form [t'=(x1:A1)..(xn:An)(ref args)] and fails with user error if not possible *) @@ -90,7 +99,10 @@ val reduce_to_atomic_ref : env -> evar_map -> global_reference -> types -> types val find_hnf_rectype : - env -> evar_map -> types -> inductive * constr list + env -> evar_map -> types -> pinductive * constr list val contextually : bool -> occurrences * constr_pattern -> (patvar_map -> reduction_function) -> reduction_function + +val e_contextually : bool -> occurrences * constr_pattern -> + (patvar_map -> e_reduction_function) -> e_reduction_function diff --git a/pretyping/term_dnet.ml b/pretyping/term_dnet.ml index 10ec651fa..e05f4bcfe 100644 --- a/pretyping/term_dnet.ml +++ b/pretyping/term_dnet.ml @@ -261,9 +261,9 @@ struct | Rel _ -> Term DRel | Sort _ -> Term DSort | Var i -> Term (DRef (VarRef i)) - | Const c -> Term (DRef (ConstRef c)) - | Ind i -> Term (DRef (IndRef i)) - | Construct c -> Term (DRef (ConstructRef c)) + | Const (c,u) -> Term (DRef (ConstRef c)) + | Ind (i,u) -> Term (DRef (IndRef i)) + | Construct (c,u)-> Term (DRef (ConstructRef c)) | Term.Meta _ -> assert false | Evar (i,_) -> let meta = @@ -287,6 +287,8 @@ struct | App (f,ca) -> Array.fold_left (fun c a -> Term (DApp (c,a))) (pat_of_constr f) (Array.map pat_of_constr ca) + | Proj (p,c) -> + Term (DApp (Term (DRef (ConstRef p)), pat_of_constr c)) and ctx_of_constr ctx c = match kind_of_term c with | Prod (_,t,c) -> ctx_of_constr (Term(DCons((pat_of_constr t,None),ctx))) c diff --git a/pretyping/termops.ml b/pretyping/termops.ml index 741601167..b3fa53eee 100644 --- a/pretyping/termops.ml +++ b/pretyping/termops.ml @@ -22,7 +22,7 @@ open Locus let print_sort = function | Prop Pos -> (str "Set") | Prop Null -> (str "Prop") - | Type u -> (str "Type(" ++ Univ.pr_uni u ++ str ")") + | Type u -> (str "Type(" ++ Univ.Universe.pr u ++ str ")") let pr_sort_family = function | InSet -> (str "Set") @@ -44,6 +44,10 @@ let pr_fix pr_constr ((t,i),(lna,tl,bl)) = cut() ++ str":=" ++ pr_constr bd) (Array.to_list fixl)) ++ str"}") +let pr_puniverses p u = + if Univ.Instance.is_empty u then p + else p ++ str"(*" ++ Univ.Instance.pr u ++ str"*)" + let rec pr_constr c = match kind_of_term c with | Rel n -> str "#"++int n | Meta n -> str "Meta(" ++ int n ++ str ")" @@ -71,10 +75,11 @@ let rec pr_constr c = match kind_of_term c with | Evar (e,l) -> hov 1 (str"Evar#" ++ int (Evar.repr e) ++ str"{" ++ prlist_with_sep spc pr_constr (Array.to_list l) ++str"}") - | Const c -> str"Cst(" ++ pr_con c ++ str")" - | Ind (sp,i) -> str"Ind(" ++ pr_mind sp ++ str"," ++ int i ++ str")" - | Construct ((sp,i),j) -> - str"Constr(" ++ pr_mind sp ++ str"," ++ int i ++ str"," ++ int j ++ str")" + | Const (c,u) -> str"Cst(" ++ pr_puniverses (pr_con c) u ++ str")" + | Ind ((sp,i),u) -> str"Ind(" ++ pr_puniverses (pr_mind sp ++ str"," ++ int i) u ++ str")" + | Construct (((sp,i),j),u) -> + str"Constr(" ++ pr_puniverses (pr_mind sp ++ str"," ++ int i ++ str"," ++ int j) u ++ str")" + | Proj (p,c) -> str"Proj(" ++ pr_con p ++ str"," ++ pr_constr c ++ str")" | Case (ci,p,c,bl) -> v 0 (hv 0 (str"<"++pr_constr p++str">"++ cut() ++ str"Case " ++ pr_constr c ++ str"of") ++ cut() ++ @@ -145,41 +150,6 @@ let print_env env = in (sign_env ++ db_env) -(*let current_module = ref DirPath.empty - -let set_module m = current_module := m*) - -let new_univ_level, set_remote_new_univ_level = - RemoteCounter.new_counter ~name:"univ_level" 0 ~incr:((+) 1) - ~build:(fun n -> Univ.UniverseLevel.make (Lib.library_dp()) n) - -let new_univ () = Univ.Universe.make (new_univ_level ()) -let new_Type () = mkType (new_univ ()) -let new_Type_sort () = Type (new_univ ()) - -(* This refreshes universes in types; works only for inferred types (i.e. for - types of the form (x1:A1)...(xn:An)B with B a sort or an atom in - head normal form) *) -let refresh_universes_gen strict t = - let modified = ref false in - let rec refresh t = match kind_of_term t with - | Sort (Type u) when strict || not (Univ.is_type0m_univ u) -> - modified := true; new_Type () - | Prod (na,u,v) -> mkProd (na,u,refresh v) - | _ -> t in - let t' = refresh t in - if !modified then t' else t - -let refresh_universes = refresh_universes_gen false -let refresh_universes_strict = refresh_universes_gen true - -let new_sort_in_family = function - | InProp -> prop_sort - | InSet -> set_sort - | InType -> Type (new_univ ()) - - - (* [Rel (n+m);...;Rel(n+1)] *) let rel_vect n m = Array.init m (fun i -> mkRel(n+m-i)) @@ -319,6 +289,7 @@ let map_constr_with_named_binders g f l c = match kind_of_term c with | Lambda (na,t,c) -> mkLambda (na, f l t, f (g na l) c) | LetIn (na,b,t,c) -> mkLetIn (na, f l b, f l t, f (g na l) c) | App (c,al) -> mkApp (f l c, Array.map (f l) al) + | Proj (p,c) -> mkProj (p, f l c) | Evar (e,al) -> mkEvar (e, Array.map (f l) al) | Case (ci,p,c,bl) -> mkCase (ci, f l p, f l c, Array.map (f l) bl) | Fix (ln,(lna,tl,bl)) -> @@ -375,6 +346,8 @@ let map_constr_with_binders_left_to_right g f l c = match kind_of_term c with let a = al.(Array.length al - 1) in let hd = f l (mkApp (c, Array.sub al 0 (Array.length al - 1))) in mkApp (hd, [| f l a |]) + | Proj (p,c) -> + mkProj (p, f l c) | Evar (e,al) -> mkEvar (e, Array.map_left (f l) al) | Case (ci,p,c,bl) -> (* In v8 concrete syntax, predicate is after the term to match! *) @@ -415,6 +388,9 @@ let map_constr_with_full_binders g f l cstr = match kind_of_term cstr with let c' = f l c in let al' = Array.map (f l) al in if c==c' && Array.for_all2 (==) al al' then cstr else mkApp (c', al') + | Proj (p,c) -> + let c' = f l c in + if c' == c then cstr else mkProj (p, c') | Evar (e,al) -> let al' = Array.map (f l) al in if Array.for_all2 (==) al al' then cstr else mkEvar (e, al') @@ -456,6 +432,7 @@ let fold_constr_with_binders g f n acc c = match kind_of_term c with | Lambda (_,t,c) -> f (g n) (f n acc t) c | LetIn (_,b,t,c) -> f (g n) (f n (f n acc b) t) c | App (c,l) -> Array.fold_left (f n) (f n acc c) l + | Proj (p,c) -> f n acc c | Evar (_,l) -> Array.fold_left (f n) acc l | Case (_,p,c,bl) -> Array.fold_left (f n) (f n (f n acc p) c) bl | Fix (_,(lna,tl,bl)) -> @@ -480,6 +457,7 @@ let iter_constr_with_full_binders g f l c = match kind_of_term c with | Lambda (na,t,c) -> f l t; f (g (na,None,t) l) c | LetIn (na,b,t,c) -> f l b; f l t; f (g (na,Some b,t) l) c | App (c,args) -> f l c; Array.iter (f l) args + | Proj (p,c) -> f l c | Evar (_,args) -> Array.iter (f l) args | Case (_,p,c,bl) -> f l p; f l c; Array.iter (f l) bl | Fix (_,(lna,tl,bl)) -> @@ -516,6 +494,13 @@ let occur_meta_or_existential c = | _ -> iter_constr occrec c in try occrec c; false with Occur -> true +let occur_const s c = + let rec occur_rec c = match kind_of_term c with + | Const (sp,_) when sp=s -> raise Occur + | _ -> iter_constr occur_rec c + in + try occur_rec c; false with Occur -> true + let occur_evar n c = let rec occur_rec c = match kind_of_term c with | Evar (sp,_) when Evar.equal sp n -> raise Occur @@ -573,9 +558,10 @@ let collect_vars c = (* Tests whether [m] is a subterm of [t]: [m] is appropriately lifted through abstractions of [t] *) -let dependent_main noevar m t = +let dependent_main noevar univs m t = + let eqc x y = if univs then fst (eq_constr_universes x y) else eq_constr_nounivs x y in let rec deprec m t = - if eq_constr m t then + if eqc m t then raise Occur else match kind_of_term m, kind_of_term t with @@ -590,8 +576,11 @@ let dependent_main noevar m t = in try deprec m t; false with Occur -> true -let dependent = dependent_main false -let dependent_no_evar = dependent_main true +let dependent = dependent_main false false +let dependent_no_evar = dependent_main true false + +let dependent_univs = dependent_main false true +let dependent_univs_no_evar = dependent_main true true let count_occurrences m t = let n = ref 0 in @@ -725,7 +714,7 @@ let error_cannot_unify_occurrences nested (cl2,pos2,t2) (cl1,pos1,t1) = exception NotUnifiable type 'a testing_function = { - match_fun : constr -> 'a; + match_fun : 'a -> constr -> 'a; merge_fun : 'a -> 'a -> 'a; mutable testing_state : 'a; mutable last_found : ((Id.t * hyp_location_flag) option * int * constr) option @@ -746,7 +735,7 @@ let subst_closed_term_occ_gen_modulo occs test cl occ t = let rec substrec k t = if nowhere_except_in && !pos > maxocc then t else try - let subst = test.match_fun t in + let subst = test.match_fun test.testing_state t in if Locusops.is_selected !pos occs then (add_subst t subst; incr pos; (* Check nested matching subterms *) @@ -781,7 +770,7 @@ let proceed_with_occurrences f occs x = x let make_eq_test c = { - match_fun = (fun c' -> if eq_constr c c' then () else raise NotUnifiable); + match_fun = (fun () c' -> if eq_constr c c' then () else raise NotUnifiable); merge_fun = (fun () () -> ()); testing_state = (); last_found = None @@ -879,10 +868,7 @@ let isGlobalRef c = | Const _ | Ind _ | Construct _ | Var _ -> true | _ -> false -let has_polymorphic_type c = - match (Global.lookup_constant c).Declarations.const_type with - | Declarations.PolymorphicArity _ -> true - | _ -> false +let has_polymorphic_type c = (Global.lookup_constant c).Declarations.const_polymorphic let base_sort_cmp pb s0 s1 = match (s0,s1) with @@ -1117,9 +1103,11 @@ let coq_unit_judge = let na2 = Name (Id.of_string "H") in fun () -> match !impossible_default_case with - | Some (id,type_of_id) -> - make_judge id type_of_id + | Some fn -> + let (id,type_of_id), ctx = fn () in + make_judge id type_of_id, ctx | None -> (* In case the constants id/ID are not defined *) make_judge (mkLambda (na1,mkProp,mkLambda(na2,mkRel 1,mkRel 1))) - (mkProd (na1,mkProp,mkArrow (mkRel 1) (mkRel 2))) + (mkProd (na1,mkProp,mkArrow (mkRel 1) (mkRel 2))), + Univ.ContextSet.empty diff --git a/pretyping/termops.mli b/pretyping/termops.mli index d0d3fd767..eec4a9b9d 100644 --- a/pretyping/termops.mli +++ b/pretyping/termops.mli @@ -13,18 +13,6 @@ open Context open Environ open Locus -(** TODO: merge this with Term *) - -(** Universes *) -val new_univ_level : unit -> Univ.universe_level -val set_remote_new_univ_level : Univ.universe_level RemoteCounter.installer -val new_univ : unit -> Univ.universe -val new_sort_in_family : sorts_family -> sorts -val new_Type : unit -> types -val new_Type_sort : unit -> sorts -val refresh_universes : types -> types -val refresh_universes_strict : types -> types - (** printers *) val print_sort : sorts -> std_ppcmds val pr_sort_family : sorts_family -> std_ppcmds @@ -120,6 +108,8 @@ val free_rels : constr -> Int.Set.t (** [dependent m t] tests whether [m] is a subterm of [t] *) val dependent : constr -> constr -> bool val dependent_no_evar : constr -> constr -> bool +val dependent_univs : constr -> constr -> bool +val dependent_univs_no_evar : constr -> constr -> bool val count_occurrences : constr -> constr -> int val collect_metas : constr -> int list val collect_vars : constr -> Id.Set.t (** for visible vars only *) @@ -168,7 +158,7 @@ val subst_closed_term_occ_gen : required too *) type 'a testing_function = { - match_fun : constr -> 'a; + match_fun : 'a -> constr -> 'a; merge_fun : 'a -> 'a -> 'a; mutable testing_state : 'a; mutable last_found : ((Id.t * hyp_location_flag) option * int * constr) option @@ -290,5 +280,5 @@ val on_judgment_value : (types -> types) -> unsafe_judgment -> unsafe_judgment val on_judgment_type : (types -> types) -> unsafe_judgment -> unsafe_judgment (** {6 Functions to deal with impossible cases } *) -val set_impossible_default_clause : constr * types -> unit -val coq_unit_judge : unit -> unsafe_judgment +val set_impossible_default_clause : (unit -> (constr * types) Univ.in_universe_context_set) -> unit +val coq_unit_judge : unit -> unsafe_judgment Univ.in_universe_context_set diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index b5735bc64..fac73670b 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -20,7 +20,6 @@ open Typeclasses_errors open Libobject (*i*) - let (add_instance_hint, add_instance_hint_hook) = Hook.make () let add_instance_hint id = Hook.get add_instance_hint id @@ -64,6 +63,7 @@ type instance = { -1 for discard, 0 for none, mutable to avoid redeclarations when multiple rebuild_object happen. *) is_global: int; + is_poly: bool; is_impl: global_reference; } @@ -73,7 +73,7 @@ let instance_impl is = is.is_impl let instance_priority is = is.is_pri -let new_instance cl pri glob impl = +let new_instance cl pri glob poly impl = let global = if glob then Lib.sections_depth () else -1 @@ -81,6 +81,7 @@ let new_instance cl pri glob impl = { is_class = cl.cl_impl; is_pri = pri ; is_global = global ; + is_poly = poly; is_impl = impl } (* @@ -90,12 +91,35 @@ let new_instance cl pri glob impl = let classes : typeclasses ref = Summary.ref Refmap.empty ~name:"classes" let instances : instances ref = Summary.ref Refmap.empty ~name:"instances" +open Declarations + +let typeclass_univ_instance (cl,u') = + let subst = + let u = + match cl.cl_impl with + | ConstRef c -> + let cb = Global.lookup_constant c in + if cb.const_polymorphic then Univ.UContext.instance (Future.force cb.const_universes) + else Univ.Instance.empty + | IndRef c -> + let mib,oib = Global.lookup_inductive c in + if mib.mind_polymorphic then Univ.UContext.instance mib.mind_universes + else Univ.Instance.empty + | _ -> Univ.Instance.empty + in Array.fold_left2 (fun subst u u' -> Univ.LMap.add u u' subst) + Univ.LMap.empty (Univ.Instance.to_array u) (Univ.Instance.to_array u') + in + let subst_ctx = Context.map_rel_context (subst_univs_level_constr subst) in + { cl with cl_context = fst cl.cl_context, subst_ctx (snd cl.cl_context); + cl_props = subst_ctx cl.cl_props}, u' + let class_info c = try Refmap.find c !classes - with Not_found -> not_a_class (Global.env()) (constr_of_global c) + with Not_found -> not_a_class (Global.env()) (printable_constr_of_global c) let global_class_of_constr env c = - try class_info (global_of_constr c) + try let gr, u = Universes.global_of_constr c in + class_info gr, u with Not_found -> not_a_class env c let dest_class_app env c = @@ -110,16 +134,19 @@ let class_of_constr c = try Some (dest_class_arity (Global.env ()) c) with e when Errors.noncritical e -> None -let rec is_class_type evd c = - match kind_of_term c with - | Prod (_, _, t) -> is_class_type evd t - | Evar (e, _) when is_defined evd e -> is_class_type evd (Evarutil.nf_evar evd c) - | _ -> - begin match class_of_constr c with - | Some _ -> true - | None -> false - end +let is_class_constr c = + try let gr, u = Universes.global_of_constr c in + Refmap.mem gr !classes + with Not_found -> false +let rec is_class_type evd c = + let c, args = decompose_app c in + match kind_of_term c with + | Prod (_, _, t) -> is_class_type evd t + | Evar (e, _) when Evd.is_defined evd e -> + is_class_type evd (Evarutil.whd_head_evar evd c) + | _ -> is_class_constr c + let is_class_evar evd evi = is_class_type evd evi.Evd.evar_concl @@ -133,7 +160,7 @@ let load_class (_, cl) = let cache_class = load_class let subst_class (subst,cl) = - let do_subst_con c = fst (Mod_subst.subst_con subst c) + let do_subst_con c = Mod_subst.subst_constant subst c and do_subst c = Mod_subst.subst_mps subst c and do_subst_gr gr = fst (subst_global subst gr) in let do_subst_ctx ctx = List.smartmap @@ -142,7 +169,8 @@ let subst_class (subst,cl) = let do_subst_context (grs,ctx) = List.smartmap (Option.smartmap (fun (gr,b) -> do_subst_gr gr, b)) grs, do_subst_ctx ctx in - let do_subst_projs projs = List.smartmap (fun (x, y, z) -> (x, y, Option.smartmap do_subst_con z)) projs in + let do_subst_projs projs = List.smartmap (fun (x, y, z) -> + (x, y, Option.smartmap do_subst_con z)) projs in { cl_impl = do_subst_gr cl.cl_impl; cl_context = do_subst_context cl.cl_context; cl_props = do_subst_ctx cl.cl_props; @@ -174,7 +202,7 @@ let discharge_class (_,cl) = let newgrs = List.map (fun (_, _, t) -> match class_of_constr t with | None -> None - | Some (_, (tc, _)) -> Some (tc.cl_impl, true)) + | Some (_, ((tc,_), _)) -> Some (tc.cl_impl, true)) ctx' in List.smartmap (Option.smartmap (fun (gr, b) -> Lib.discharge_global gr, b)) grs @@ -182,7 +210,7 @@ let discharge_class (_,cl) = in grs', discharge_rel_context subst 1 ctx @ ctx' in let cl_impl' = Lib.discharge_global cl.cl_impl in if cl_impl' == cl.cl_impl then cl else - let ctx = abs_context cl in + let ctx, uctx = abs_context cl in let ctx, subst = rel_of_variable_context ctx in let context = discharge_context ctx subst cl.cl_context in let props = discharge_rel_context subst (succ (List.length (fst cl.cl_context))) cl.cl_props in @@ -217,7 +245,7 @@ let check_instance env sigma c = try let (evd, c) = resolve_one_typeclass env sigma (Retyping.get_type_of env sigma c) in - Evd.has_undefined evd + not (Evd.has_undefined evd) with e when Errors.noncritical e -> false let build_subclasses ~check env sigma glob pri = @@ -231,7 +259,7 @@ let build_subclasses ~check env sigma glob pri = let ty = Evarutil.nf_evar sigma (Retyping.get_type_of env sigma c) in match class_of_constr ty with | None -> [] - | Some (rels, (tc, args)) -> + | Some (rels, ((tc,u), args)) -> let instapp = Reductionops.whd_beta sigma (appvectc c (Termops.extended_rel_vect 0 rels)) in @@ -243,7 +271,7 @@ let build_subclasses ~check env sigma glob pri = | Some (Backward, _) -> None | Some (Forward, pri') -> let proj = Option.get proj in - let body = it_mkLambda_or_LetIn (mkApp (mkConst proj, projargs)) rels in + let body = it_mkLambda_or_LetIn (mkApp (mkConstU (proj,u), projargs)) rels in if check && check_instance env sigma body then None else let pri = @@ -259,7 +287,7 @@ let build_subclasses ~check env sigma glob pri = let rest = aux pri body path' in hints @ (path', pri, body) :: rest in List.fold_left declare_proj [] projs - in aux pri (constr_of_global glob) [glob] + in aux pri (Universes.constr_of_global glob) [glob] (* * instances persistent object @@ -305,9 +333,11 @@ let discharge_instance (_, (action, inst)) = let is_local i = Int.equal i.is_global (-1) let add_instance check inst = - add_instance_hint (IsGlobal inst.is_impl) [inst.is_impl] (is_local inst) inst.is_pri; + let poly = Global.is_polymorphic inst.is_impl in + add_instance_hint (IsGlobal inst.is_impl) [inst.is_impl] (is_local inst) + inst.is_pri poly; List.iter (fun (path, pri, c) -> add_instance_hint (IsConstr c) path - (is_local inst) pri) + (is_local inst) pri poly) (build_subclasses ~check:(check && not (isVarRef inst.is_impl)) (Global.env ()) Evd.empty inst.is_impl inst.is_pri) @@ -342,11 +372,10 @@ let remove_instance i = remove_instance_hint i.is_impl let declare_instance pri local glob = - let c = constr_of_global glob in - let ty = Retyping.get_type_of (Global.env ()) Evd.empty c in + let ty = Global.type_of_global_unsafe (*FIXME*) glob in match class_of_constr ty with - | Some (rels, (tc, args) as _cl) -> - add_instance (new_instance tc pri (not local) glob) + | Some (rels, ((tc,_), args) as _cl) -> + add_instance (new_instance tc pri (not local) (Flags.use_polymorphic_flag ()) glob) (* let path, hints = build_subclasses (not local) (Global.env ()) Evd.empty glob in *) (* let entries = List.map (fun (path, pri, c) -> (pri, local, path, c)) hints in *) (* Auto.add_hints local [typeclasses_db] (Auto.HintsResolveEntry entries); *) @@ -367,9 +396,9 @@ let add_class cl = open Declarations - +(* FIXME: deal with universe instances *) let add_constant_class cst = - let ty = Typeops.type_of_constant (Global.env ()) cst in + let ty = Typeops.type_of_constant_in (Global.env ()) (cst,Univ.Instance.empty) in let ctx, arity = decompose_prod_assum ty in let tc = { cl_impl = ConstRef cst; @@ -386,7 +415,8 @@ let add_inductive_class ind = let ctx = oneind.mind_arity_ctxt in let ty = Inductive.type_of_inductive_knowing_parameters (push_rel_context ctx (Global.env ())) - oneind (Array.map (fun x -> lazy x) (Termops.extended_rel_vect 0 ctx)) + ((mind,oneind),Univ.Instance.empty) + (Array.map (fun x -> lazy x) (Termops.extended_rel_vect 0 ctx)) in { cl_impl = IndRef ind; cl_context = List.map (const None) ctx, ctx; @@ -398,7 +428,7 @@ let add_inductive_class ind = * interface functions *) -let instance_constructor cl args = +let instance_constructor (cl,u) args = let filter (_, b, _) = match b with | None -> true | Some _ -> false @@ -406,14 +436,17 @@ let instance_constructor cl args = let lenpars = List.length (List.filter filter (snd cl.cl_context)) in let pars = fst (List.chop lenpars args) in match cl.cl_impl with - | IndRef ind -> Some (applistc (mkConstruct (ind, 1)) args), - applistc (mkInd ind) pars + | IndRef ind -> + let ind = ind, u in + (Some (applistc (mkConstructUi (ind, 1)) args), + applistc (mkIndU ind) pars) | ConstRef cst -> + let cst = cst, u in let term = match args with - | [] -> None - | _ -> Some (List.last args) + | [] -> None + | _ -> Some (List.last args) in - term, applistc (mkConst cst) pars + (term, applistc (mkConstU cst) pars) | _ -> assert false let typeclasses () = Refmap.fold (fun _ l c -> l :: c) !classes [] @@ -504,12 +537,19 @@ let mark_resolvables sigma = mark_resolvability all_evars true sigma let has_typeclasses filter evd = let check ev evi = - filter ev (snd evi.evar_source) && is_class_evar evd evi && is_resolvable evi + filter ev (snd evi.evar_source) && is_resolvable evi && is_class_evar evd evi in Evar.Map.exists check (Evd.undefined_map evd) let solve_instanciations_problem = ref (fun _ _ _ _ _ -> assert false) +let solve_problem env evd filter split fail = + !solve_instanciations_problem env evd filter split fail + +(** Profiling resolution of typeclasses *) +(* let solve_classeskey = Profile.declare_profile "solve_typeclasses" *) +(* let solve_problem = Profile.profile5 solve_classeskey solve_problem *) + let resolve_typeclasses ?(filter=no_goals) ?(split=true) ?(fail=true) env evd = if not (has_typeclasses filter evd) then evd - else !solve_instanciations_problem env evd filter split fail + else solve_problem env evd filter split fail diff --git a/pretyping/typeclasses.mli b/pretyping/typeclasses.mli index c36293525..a8ce9ca7c 100644 --- a/pretyping/typeclasses.mli +++ b/pretyping/typeclasses.mli @@ -48,18 +48,24 @@ val add_constant_class : constant -> unit val add_inductive_class : inductive -> unit -val new_instance : typeclass -> int option -> bool -> global_reference -> instance +val new_instance : typeclass -> int option -> bool -> Decl_kinds.polymorphic -> + global_reference -> instance val add_instance : instance -> unit val remove_instance : instance -> unit val class_info : global_reference -> typeclass (** raises a UserError if not a class *) -(** These raise a UserError if not a class. *) -val dest_class_app : env -> constr -> typeclass * constr list +(** These raise a UserError if not a class. + Caution: the typeclass structures is not instantiated w.r.t. the universe instance. + This is done separately by typeclass_univ_instance. *) +val dest_class_app : env -> constr -> typeclass puniverses * constr list + +(** Get the instantiated typeclass structure for a given universe instance. *) +val typeclass_univ_instance : typeclass puniverses -> typeclass puniverses (** Just return None if not a class *) -val class_of_constr : constr -> (rel_context * (typeclass * constr list)) option +val class_of_constr : constr -> (rel_context * (typeclass puniverses * constr list)) option val instance_impl : instance -> global_reference @@ -73,7 +79,8 @@ val is_implicit_arg : Evar_kinds.t -> bool (** Returns the term and type for the given instance of the parameters and fields of the type class. *) -val instance_constructor : typeclass -> constr list -> constr option * types +val instance_constructor : typeclass puniverses -> constr list -> + constr option * types (** Filter which evars to consider for resolution. *) type evar_filter = existential_key -> Evar_kinds.t -> bool @@ -104,10 +111,10 @@ val classes_transparent_state : unit -> transparent_state val add_instance_hint_hook : (global_reference_or_constr -> global_reference list -> - bool (* local? *) -> int option -> unit) Hook.t + bool (* local? *) -> int option -> Decl_kinds.polymorphic -> unit) Hook.t val remove_instance_hint_hook : (global_reference -> unit) Hook.t val add_instance_hint : global_reference_or_constr -> global_reference list -> - bool -> int option -> unit + bool -> int option -> Decl_kinds.polymorphic -> unit val remove_instance_hint : global_reference -> unit val solve_instanciations_problem : (env -> evar_map -> evar_filter -> bool -> bool -> evar_map) ref diff --git a/pretyping/typing.ml b/pretyping/typing.ml index 0cd9099e3..bd559ddd5 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -27,12 +27,12 @@ let meta_type evd mv = let constant_type_knowing_parameters env cst jl = let paramstyp = Array.map (fun j -> lazy j.uj_type) jl in - type_of_constant_knowing_parameters env (constant_type env cst) paramstyp + type_of_constant_knowing_parameters env (constant_type_in env cst) paramstyp -let inductive_type_knowing_parameters env ind jl = - let (mib,mip) = lookup_mind_specif env ind in +let inductive_type_knowing_parameters env (ind,u) jl = + let mspec = lookup_mind_specif env ind in let paramstyp = Array.map (fun j -> lazy j.uj_type) jl in - Inductive.type_of_inductive_knowing_parameters env mip paramstyp + Inductive.type_of_inductive_knowing_parameters env (mspec,u) paramstyp let e_type_judgment env evdref j = match kind_of_term (whd_betadeltaiota env !evdref j.uj_type) with @@ -69,12 +69,12 @@ let e_judge_of_apply env evdref funj argjv = in apply_rec 1 funj.uj_type (Array.to_list argjv) -let e_check_branch_types env evdref ind cj (lfj,explft) = +let e_check_branch_types env evdref (ind,u) cj (lfj,explft) = if not (Int.equal (Array.length lfj) (Array.length explft)) then error_number_branches env cj (Array.length explft); for i = 0 to Array.length explft - 1 do if not (Evarconv.e_cumul env evdref lfj.(i).uj_type explft.(i)) then - error_ill_formed_branch env cj.uj_val (ind,i+1) lfj.(i).uj_type explft.(i) + error_ill_formed_branch env cj.uj_val ((ind,i+1),u) lfj.(i).uj_type explft.(i) done let max_sort l = @@ -95,8 +95,8 @@ let e_is_correct_arity env evdref c pj ind specif params = if not (Sorts.List.mem (Sorts.family s) allowed_sorts) then error () | Evar (ev,_), [] -> - let s = Termops.new_sort_in_family (max_sort allowed_sorts) in - evdref := Evd.define ev (mkSort s) !evdref + let evd, s = Evd.fresh_sort_in_family env !evdref (max_sort allowed_sorts) in + evdref := Evd.define ev (mkSort s) evd | _, (_,Some _,_ as d)::ar' -> srec (push_rel d env) (lift 1 pt') ar' | _ -> @@ -105,7 +105,7 @@ let e_is_correct_arity env evdref c pj ind specif params = srec env pj.uj_type (List.rev arsign) let e_type_case_branches env evdref (ind,largs) pj c = - let specif = lookup_mind_specif env ind in + let specif = lookup_mind_specif env (fst ind) in let nparams = inductive_params specif in let (params,realargs) = List.chop nparams largs in let p = pj.uj_val in @@ -126,10 +126,11 @@ let e_judge_of_case env evdref ci pj cj lfj = { uj_val = mkCase (ci, pj.uj_val, cj.uj_val, Array.map j_val lfj); uj_type = rslty } +(* FIXME: might depend on the level of actual parameters!*) let check_allowed_sort env sigma ind c p = let pj = Retyping.get_judgment_of env sigma p in let ksort = family_of_sort (sort_of_arity env sigma pj.uj_type) in - let specif = Global.lookup_inductive ind in + let specif = Global.lookup_inductive (fst ind) in let sorts = elim_sorts specif in if not (List.exists ((==) ksort) sorts) then let s = inductive_sort_family (snd specif) in @@ -196,7 +197,11 @@ let rec execute env evdref cstr = judge_of_prop_contents c | Sort (Type u) -> - judge_of_type u + judge_of_type u + + | Proj (p, c) -> + let cj = execute env evdref c in + judge_of_projection env p (Evarutil.j_nf_evar !evdref cj) | App (f,args) -> let jl = execute_array env evdref args in @@ -236,7 +241,7 @@ let rec execute env evdref cstr = let j1 = execute env evdref c1 in let j2 = execute env evdref c2 in let j2 = e_type_judgment env evdref j2 in - let _ = judge_of_cast env j1 DEFAULTcast j2 in + let _ = e_judge_of_cast env evdref j1 DEFAULTcast j2 in let env1 = push_rel (name,Some j1.uj_val,j2.utj_val) env in let j3 = execute env1 evdref c3 in judge_of_letin env name j1 j2 j3 @@ -268,9 +273,7 @@ let check env evd c t = let type_of env evd c = let j = execute env (ref evd) c in - (* We are outside the kernel: we take fresh universes *) - (* to avoid tactics and co to refresh universes themselves *) - Termops.refresh_universes j.uj_type + j.uj_type (* Sort of a type *) @@ -286,7 +289,7 @@ let e_type_of env evd c = let evdref = ref evd in let j = execute env evdref c in (* side-effect on evdref *) - !evdref, Termops.refresh_universes j.uj_type + !evdref, j.uj_type let solve_evars env evdref c = let c = (execute env evdref c).uj_val in diff --git a/pretyping/typing.mli b/pretyping/typing.mli index 084bdbc4f..8b194a9c9 100644 --- a/pretyping/typing.mli +++ b/pretyping/typing.mli @@ -34,5 +34,5 @@ val solve_evars : env -> evar_map ref -> constr -> constr (** Raise an error message if incorrect elimination for this inductive *) (** (first constr is term to match, second is return predicate) *) -val check_allowed_sort : env -> evar_map -> inductive -> constr -> constr -> +val check_allowed_sort : env -> evar_map -> pinductive -> constr -> constr -> unit diff --git a/pretyping/unification.ml b/pretyping/unification.ml index bfcc469c5..f7379b4a0 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -33,7 +33,9 @@ let occur_meta_or_undefined_evar evd c = | Evar_defined c -> occrec c; Array.iter occrec args | Evar_empty -> raise Occur) - | Sort s when is_sort_variable evd s -> raise Occur + (* | Sort (Type _) (\* FIXME could be finer *\) -> raise Occur *) + | Const (_, i) (* | Ind (_, i) | Construct (_, i) *) + when not (Univ.Instance.is_empty i) -> raise Occur | _ -> iter_constr occrec c in try occrec c; false with Occur | Not_found -> true @@ -49,16 +51,19 @@ let occur_meta_evd sigma mv c = (* if lname_typ is [xn,An;..;x1,A1] and l is a list of terms, gives [x1:A1]..[xn:An]c' such that c converts to ([x1:A1]..[xn:An]c' l) *) -let abstract_scheme env c l lname_typ = +let abstract_scheme env evd c l lname_typ = List.fold_left2 - (fun t (locc,a) (na,_,ta) -> + (fun (t,evd) (locc,a) (na,_,ta) -> let na = match kind_of_term a with Var id -> Name id | _ -> na in (* [occur_meta ta] test removed for support of eelim/ecase but consequences are unclear... if occur_meta ta then error "cannot find a type for the generalisation" - else *) if occur_meta a then mkLambda_name env (na,ta,t) - else mkLambda_name env (na,ta,subst_closed_term_occ locc a t)) - c + else *) + if occur_meta a then mkLambda_name env (na,ta,t), evd + else + let t', evd' = Tacred.subst_closed_term_univs_occ evd locc a t in + mkLambda_name env (na,ta,t'), evd') + (c,evd) (List.rev l) lname_typ @@ -67,15 +72,15 @@ let abstract_scheme env c l lname_typ = let abstract_list_all env evd typ c l = let ctxt,_ = splay_prod_n env evd (List.length l) typ in let l_with_all_occs = List.map (function a -> (AllOccurrences,a)) l in - let p = abstract_scheme env c l_with_all_occs ctxt in - let typp = - try Typing.type_of env evd p + let p,evd = abstract_scheme env evd c l_with_all_occs ctxt in + let evd,typp = + try Typing.e_type_of env evd p with | UserError _ -> error_cannot_find_well_typed_abstraction env evd p l None | Type_errors.TypeError (env',x) -> error_cannot_find_well_typed_abstraction env evd p l (Some (env',x)) in - (p,typp) + evd,(p,typp) let set_occurrences_of_last_arg args = Some AllOccurrences :: List.tl (Array.map_to_list (fun _ -> None) args) @@ -88,7 +93,7 @@ let abstract_list_all_with_dependencies env evd typ c l = Evarconv.second_order_matching empty_transparent_state env evd ev' argoccs c in let p = nf_evar evd (existential_value evd (destEvar ev)) in - if b then p else error_cannot_find_well_typed_abstraction env evd p l None + if b then evd, p else error_cannot_find_well_typed_abstraction env evd p l None (**) @@ -251,11 +256,12 @@ type unify_flags = { (* Default flag for unifying a type against a type (e.g. apply) *) (* We set all conversion flags (no flag should be modified anymore) *) -let default_unify_flags = { - modulo_conv_on_closed_terms = Some full_transparent_state; +let default_unify_flags () = + let ts = Names.full_transparent_state in + { modulo_conv_on_closed_terms = Some ts; use_metas_eagerly_in_conv_on_closed_terms = true; - modulo_delta = full_transparent_state; - modulo_delta_types = full_transparent_state; + modulo_delta = ts; + modulo_delta_types = ts; modulo_delta_in_merge = None; check_applied_meta_types = true; resolve_evars = false; @@ -279,7 +285,7 @@ let set_merge_flags flags = (* type against a type (e.g. apply) *) (* We set only the flags available at the time the new "apply" extends *) (* out of "simple apply" *) -let default_no_delta_unify_flags = { default_unify_flags with +let default_no_delta_unify_flags () = { (default_unify_flags ()) with modulo_delta = empty_transparent_state; check_applied_meta_types = false; use_pattern_unification = false; @@ -292,13 +298,13 @@ let default_no_delta_unify_flags = { default_unify_flags with (* allow_K) because only closed terms are involved in *) (* induction/destruct/case/elim and w_unify_to_subterm_list does not *) (* call w_unify for induction/destruct/case/elim (13/6/2011) *) -let elim_flags = { default_unify_flags with +let elim_flags () = { (default_unify_flags ()) with restrict_conv_on_strict_subterms = false; (* ? *) modulo_betaiota = false; allow_K_in_toplevel_higher_order_unification = true } -let elim_no_delta_flags = { elim_flags with +let elim_no_delta_flags () = { (elim_flags ()) with modulo_delta = empty_transparent_state; check_applied_meta_types = false; use_pattern_unification = false; @@ -314,10 +320,28 @@ let use_metas_pattern_unification flags nb l = flags.use_meta_bound_pattern_unification) && Array.for_all (fun c -> isRel c && destRel c <= nb) l -let expand_key env = function - | Some (ConstKey cst) -> constant_opt_value env cst - | Some (VarKey id) -> (try named_body id env with Not_found -> None) - | Some (RelKey _) -> None +type key = + | IsKey of Closure.table_key + | IsProj of constant * constr + +let expand_table_key env = function + | ConstKey cst -> constant_opt_value_in env cst + | VarKey id -> (try named_body id env with Not_found -> None) + | RelKey _ -> None + +let unfold_projection env p stk = + (match try Some (lookup_projection p env) with Not_found -> None with + | Some pb -> + let s = Stack.Proj (pb.Declarations.proj_npars, pb.Declarations.proj_arg, p) in + s :: stk + | None -> assert false) + +let expand_key ts env sigma = function + | Some (IsKey k) -> expand_table_key env k + | Some (IsProj (p, c)) -> + let red = Stack.zip (fst (whd_betaiota_deltazeta_for_iota_state ts env sigma + Cst_stack.empty (c, unfold_projection env p []))) + in if eq_constr (mkProj (p, c)) red then None else Some red | None -> None let subterm_restriction is_subterm flags = @@ -326,14 +350,24 @@ let subterm_restriction is_subterm flags = let key_of env b flags f = if subterm_restriction b flags then None else match kind_of_term f with - | Const cst when is_transparent env (ConstKey cst) && - Cpred.mem cst (snd flags.modulo_delta) -> - Some (ConstKey cst) - | Var id when is_transparent env (VarKey id) && - Id.Pred.mem id (fst flags.modulo_delta) -> - Some (VarKey id) + | Const (cst, u) when Cpred.mem cst (snd flags.modulo_delta) -> + Some (IsKey (ConstKey (cst, u))) + | Var id when Id.Pred.mem id (fst flags.modulo_delta) -> + Some (IsKey (VarKey id)) + | Proj (p, c) when Cpred.mem p (snd flags.modulo_delta) -> + Some (IsProj (p, c)) | _ -> None + +let translate_key = function + | ConstKey (cst,u) -> ConstKey cst + | VarKey id -> VarKey id + | RelKey n -> RelKey n + +let translate_key = function + | IsKey k -> translate_key k + | IsProj (c, _) -> ConstKey c + let oracle_order env cf1 cf2 = match cf1 with | None -> @@ -344,8 +378,36 @@ let oracle_order env cf1 cf2 = match cf2 with | None -> Some true | Some k2 -> - Some (Conv_oracle.oracle_order (Environ.oracle env) false k1 k2) + Some (Conv_oracle.oracle_order (Environ.oracle env) false (translate_key k1) (translate_key k2)) + +let is_rigid_head flags t = + match kind_of_term t with + | Const (cst,u) -> not (Cpred.mem cst (snd flags.modulo_delta)) + | Ind (i,u) -> true + | _ -> false +let force_eqs c = + Univ.UniverseConstraints.fold + (fun ((l,d,r) as c) acc -> + let c' = if d == Univ.ULub then (l,Univ.UEq,r) else c in + Univ.UniverseConstraints.add c' acc) + c Univ.UniverseConstraints.empty + +let constr_cmp pb sigma flags t u = + let b, cstrs = + if pb == Reduction.CONV then eq_constr_universes t u + else leq_constr_universes t u + in + if b then + try Evd.add_universe_constraints sigma cstrs, b + with Univ.UniverseInconsistency _ -> sigma, false + | Evd.UniversesDiffer -> + if is_rigid_head flags t then + try Evd.add_universe_constraints sigma (force_eqs cstrs), b + with Univ.UniverseInconsistency _ -> sigma, false + else sigma, false + else sigma, b + let do_reduce ts (env, nb) sigma c = Stack.zip (fst (whd_betaiota_deltazeta_for_iota_state ts env sigma Cst_stack.empty (c, Stack.empty))) @@ -356,14 +418,14 @@ let isAllowedEvar flags c = match kind_of_term c with | Evar (evk,_) -> not (Evar.Set.mem evk flags.frozen_evars) | _ -> false -let check_compatibility env (sigma,metasubst,evarsubst) tyM tyN = +let check_compatibility env flags (sigma,metasubst,evarsubst) tyM tyN = match subst_defined_metas metasubst tyM with | None -> () | Some m -> match subst_defined_metas metasubst tyN with | None -> () | Some n -> - if not (is_trans_fconv CONV full_transparent_state env sigma m n) + if not (is_trans_fconv CONV flags.modulo_delta env sigma m n) && is_ground_term sigma m && is_ground_term sigma n then error_cannot_unify env sigma (m,n) @@ -379,7 +441,7 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag if wt && flags.check_applied_meta_types then (let tyM = Typing.meta_type sigma k1 in let tyN = Typing.meta_type sigma k2 in - check_compatibility curenv substn tyM tyN); + check_compatibility curenv flags substn tyM tyN); if k2 < k1 then sigma,(k1,cN,stN)::metasubst,evarsubst else sigma,(k2,cM,stM)::metasubst,evarsubst | Meta k, _ @@ -388,7 +450,7 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag (try let tyM = Typing.meta_type sigma k in let tyN = get_type_of curenv ~lax:true sigma cN in - check_compatibility curenv substn tyM tyN + check_compatibility curenv flags substn tyM tyN with RetypeError _ -> (* Renounce, maybe metas/evars prevents typing *) ()); (* Here we check that [cN] does not contain any local variables *) @@ -405,7 +467,7 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag (try let tyM = get_type_of curenv ~lax:true sigma cM in let tyN = Typing.meta_type sigma k in - check_compatibility curenv substn tyM tyN + check_compatibility curenv flags substn tyM tyN with RetypeError _ -> (* Renounce, maybe metas/evars prevents typing *) ()); (* Here we check that [cM] does not contain any local variables *) @@ -431,7 +493,7 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag | Sort s1, Sort s2 -> (try let sigma' = - if cv_pb == CUMUL + if pb == CUMUL then Evd.set_leq_sort sigma s1 s2 else Evd.set_eq_sort sigma s1 s2 in (sigma', metasubst, evarsubst) @@ -455,6 +517,8 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag unirec_rec (push (na,t2) curenvnb) CONV true wt substn (mkApp (lift 1 cM,[|mkRel 1|])) c2 + (* TODO: eta for records *) + | Case (_,p1,c1,cl1), Case (_,p2,c2,cl2) -> (try Array.fold_left2 (unirec_rec curenvnb CONV true wt) @@ -493,6 +557,22 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag | App (f1,l1), App (f2,l2) -> unify_app curenvnb pb b substn cM f1 l1 cN f2 l2 + | Proj (p1,c1), Proj (p2,c2) -> + if eq_constant p1 p2 then + try + let c1, c2, substn = + if isCast c1 && isCast c2 then + let (c1,_,tc1) = destCast c1 in + let (c2,_,tc2) = destCast c2 in + c1, c2, unirec_rec curenvnb CONV true false substn tc1 tc2 + else c1, c2, substn + in + unirec_rec curenvnb CONV true wt substn c1 c2 + with ex when precatchable_exception ex -> + unify_not_same_head curenvnb pb b wt substn cM cN + else + unify_not_same_head curenvnb pb b wt substn cM cN + | _ -> unify_not_same_head curenvnb pb b wt substn cM cN @@ -508,20 +588,22 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag with ex when precatchable_exception ex -> expand curenvnb pb b false substn cM f1 l1 cN f2 l2 - and unify_not_same_head curenvnb pb b wt substn cM cN = + and unify_not_same_head curenvnb pb b wt (sigma, metas, evars as substn) cM cN = try canonical_projections curenvnb pb b cM cN substn with ex when precatchable_exception ex -> - if constr_cmp cv_pb cM cN then substn else - try reduce curenvnb pb b wt substn cM cN - with ex when precatchable_exception ex -> - let (f1,l1) = - match kind_of_term cM with App (f,l) -> (f,l) | _ -> (cM,[||]) in - let (f2,l2) = - match kind_of_term cN with App (f,l) -> (f,l) | _ -> (cN,[||]) in - expand curenvnb pb b wt substn cM f1 l1 cN f2 l2 + let sigma', b = constr_cmp cv_pb sigma flags cM cN in + if b then (sigma', metas, evars) + else + try reduce curenvnb pb b wt substn cM cN + with ex when precatchable_exception ex -> + let (f1,l1) = + match kind_of_term cM with App (f,l) -> (f,l) | _ -> (cM,[||]) in + let (f2,l2) = + match kind_of_term cN with App (f,l) -> (f,l) | _ -> (cN,[||]) in + expand curenvnb pb b wt substn cM f1 l1 cN f2 l2 and reduce curenvnb pb b wt (sigma, metas, evars as substn) cM cN = - if use_full_betaiota flags && not (subterm_restriction b flags) then + if not (subterm_restriction b flags) && use_full_betaiota flags then let cM' = do_reduce flags.modulo_delta curenvnb sigma cM in if not (eq_constr cM cM') then unirec_rec curenvnb pb b wt substn cM' cN @@ -530,12 +612,10 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag if not (eq_constr cN cN') then unirec_rec curenvnb pb b wt substn cM cN' else error_cannot_unify (fst curenvnb) sigma (cM,cN) - else - error_cannot_unify (fst curenvnb) sigma (cM,cN) + else error_cannot_unify (fst curenvnb) sigma (cM,cN) - and expand (curenv,_ as curenvnb) pb b wt (sigma,metasubst,_ as substn) cM f1 l1 cN f2 l2 = - - if + and expand (curenv,_ as curenvnb) pb b wt (sigma,metasubst,evarsubst as substn) cM f1 l1 cN f2 l2 = + let res = (* Try full conversion on meta-free terms. *) (* Back to 1995 (later on called trivial_unify in 2002), the heuristic was to apply conversion on meta-free (but not @@ -548,48 +628,50 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag (it is used by apply and rewrite); it might now be redundant with the support for delta-expansion (which is used essentially for apply)... *) - not (subterm_restriction b flags) && + if subterm_restriction b flags then None else match flags.modulo_conv_on_closed_terms with - | None -> false + | None -> None | Some convflags -> let subst = if flags.use_metas_eagerly_in_conv_on_closed_terms then metasubst else ms in match subst_defined_metas subst cM with - | None -> (* some undefined Metas in cM *) false + | None -> (* some undefined Metas in cM *) None | Some m1 -> match subst_defined_metas subst cN with - | None -> (* some undefined Metas in cN *) false + | None -> (* some undefined Metas in cN *) None | Some n1 -> (* No subterm restriction there, too much incompatibilities *) - if is_trans_fconv pb convflags env sigma m1 n1 - then true else - if is_ground_term sigma m1 && is_ground_term sigma n1 then - error_cannot_unify curenv sigma (cM,cN) - else false - then - substn - else + let b = check_conv ~pb ~ts:convflags env sigma m1 n1 in + if b then Some (sigma, metasubst, evarsubst) + else + if is_ground_term sigma m1 && is_ground_term sigma n1 then + error_cannot_unify curenv sigma (cM,cN) + else None + in + match res with + | Some substn -> substn + | None -> let cf1 = key_of env b flags f1 and cf2 = key_of env b flags f2 in match oracle_order curenv cf1 cf2 with | None -> error_cannot_unify curenv sigma (cM,cN) | Some true -> - (match expand_key curenv cf1 with + (match expand_key flags.modulo_delta curenv sigma cf1 with | Some c -> unirec_rec curenvnb pb b wt substn (whd_betaiotazeta sigma (mkApp(c,l1))) cN | None -> - (match expand_key curenv cf2 with + (match expand_key flags.modulo_delta curenv sigma cf2 with | Some c -> unirec_rec curenvnb pb b wt substn cM (whd_betaiotazeta sigma (mkApp(c,l2))) | None -> error_cannot_unify curenv sigma (cM,cN))) | Some false -> - (match expand_key curenv cf2 with + (match expand_key flags.modulo_delta curenv sigma cf2 with | Some c -> unirec_rec curenvnb pb b wt substn cM (whd_betaiotazeta sigma (mkApp(c,l2))) | None -> - (match expand_key curenv cf1 with + (match expand_key flags.modulo_delta curenv sigma cf1 with | Some c -> unirec_rec curenvnb pb b wt substn (whd_betaiotazeta sigma (mkApp(c,l1))) cN @@ -623,11 +705,12 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag else error_cannot_unify (fst curenvnb) sigma (cM,cN) and solve_canonical_projection curenvnb pb b cM f1l1 cN f2l2 (sigma,ms,es) = - let (c,bs,(params,params1),(us,us2),(ts,ts1),c1,(n,t2)) = + let (ctx,c,bs,(params,params1),(us,us2),(ts,ts1),c1,(n,t2)) = try Evarconv.check_conv_record f1l1 f2l2 with Not_found -> error_cannot_unify (fst curenvnb) sigma (cM,cN) in if Reductionops.Stack.compare_shape ts ts1 then + let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx in let (evd,ks,_) = List.fold_left (fun (evd,ks,m) b -> @@ -652,19 +735,24 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag else error_cannot_unify (fst curenvnb) sigma (cM,cN) in let evd = sigma in - if (if occur_meta_or_undefined_evar evd m || occur_meta_or_undefined_evar evd n - || subterm_restriction conv_at_top flags then false - else if (match flags.modulo_conv_on_closed_terms with - | Some convflags -> is_trans_fconv cv_pb convflags env sigma m n - | _ -> constr_cmp cv_pb m n) then true - else if (match flags.modulo_conv_on_closed_terms, flags.modulo_delta with + let res = + if occur_meta_or_undefined_evar evd m || occur_meta_or_undefined_evar evd n + || subterm_restriction conv_at_top flags then None + else + let sigma, b = match flags.modulo_conv_on_closed_terms with + | Some convflags -> infer_conv ~pb:cv_pb ~ts:convflags env sigma m n + | _ -> constr_cmp cv_pb sigma flags m n in + if b then Some sigma + else if (match flags.modulo_conv_on_closed_terms, flags.modulo_delta with | Some (cv_id, cv_k), (dl_id, dl_k) -> Id.Pred.subset dl_id cv_id && Cpred.subset dl_k cv_k | None,(dl_id, dl_k) -> Id.Pred.is_empty dl_id && Cpred.is_empty dl_k) - then error_cannot_unify env sigma (m, n) else false) - then subst - else unirec_rec (env,0) cv_pb conv_at_top false subst m n + then error_cannot_unify env sigma (m, n) else None + in + match res with + | Some sigma -> sigma, ms, es + | None -> unirec_rec (env,0) cv_pb conv_at_top false subst m n let unify_0 env sigma = unify_0_with_initial_metas (sigma,[],[]) true env @@ -792,7 +880,7 @@ let applyHead env evd n c = let is_mimick_head ts f = match kind_of_term f with - | Const c -> not (Closure.is_transparent_constant ts c) + | Const (c,u) -> not (Closure.is_transparent_constant ts c) | Var id -> not (Closure.is_transparent_variable ts id) | (Rel _|Construct _|Ind _) -> true | _ -> false @@ -820,7 +908,7 @@ let w_coerce env evd mv c = w_coerce_to_type env evd c cty mvty let unify_to_type env sigma flags c status u = - let c = refresh_universes c in + let sigma, c = refresh_universes false sigma c in let t = get_type_of env sigma (nf_meta sigma c) in let t = nf_betaiota sigma (nf_meta sigma t) in unify_0 env sigma CUMUL flags t u @@ -957,7 +1045,7 @@ let w_merge env with_types flags (evd,metas,evars) = (* merge constraints *) w_merge_rec evd (order_metas metas) (List.rev evars) [] -let w_unify_meta_types env ?(flags=default_unify_flags) evd = +let w_unify_meta_types env ?(flags=default_unify_flags ()) evd = let metas,evd = retract_coercible_metas evd in w_merge env true flags (evd,metas,[]) @@ -1032,7 +1120,7 @@ let iter_fail f a = (* Tries to find an instance of term [cl] in term [op]. Unifies [cl] to every subterm of [op] until it finds a match. Fails if no match is found *) -let w_unify_to_subterm env evd ?(flags=default_unify_flags) (op,cl) = +let w_unify_to_subterm env evd ?(flags=default_unify_flags ()) (op,cl) = let rec matchrec cl = let cl = strip_outer_cast cl in (try @@ -1061,6 +1149,8 @@ let w_unify_to_subterm env evd ?(flags=default_unify_flags) (op,cl) = with ex when precatchable_exception ex -> matchrec c2) + | Proj (p,c) -> matchrec c + | Fix(_,(_,types,terms)) -> (try iter_fail matchrec types @@ -1092,7 +1182,7 @@ let w_unify_to_subterm env evd ?(flags=default_unify_flags) (op,cl) = (* Tries to find all instances of term [cl] in term [op]. Unifies [cl] to every subterm of [op] and return all the matches. Fails if no match is found *) -let w_unify_to_subterm_all env evd ?(flags=default_unify_flags) (op,cl) = +let w_unify_to_subterm_all env evd ?(flags=default_unify_flags ()) (op,cl) = let return a b = let (evd,c as a) = a () in if List.exists (fun (evd',c') -> eq_constr c c') b then b else a :: b @@ -1130,6 +1220,8 @@ let w_unify_to_subterm_all env evd ?(flags=default_unify_flags) (op,cl) = | Case(_,_,c,lf) -> (* does not search in the predicate *) bind (matchrec c) (bind_iter matchrec lf) + | Proj (p,c) -> matchrec c + | LetIn(_,c1,_,c2) -> bind (matchrec c1) (matchrec c2) @@ -1173,7 +1265,8 @@ let w_unify_to_subterm_list env evd flags hdmeta oplist t = List.exists (fun op -> eq_constr op cl) l then error_non_linear_unification env evd hdmeta cl else (evd',cl::l) - else if flags.allow_K_in_toplevel_higher_order_unification || dependent op t + else if flags.allow_K_in_toplevel_higher_order_unification + || dependent_univs op t then (evd,op::l) else @@ -1187,15 +1280,24 @@ let secondOrderAbstraction env evd flags typ (p, oplist) = let flags = { flags with modulo_delta = (fst flags.modulo_delta, Cpred.empty) } in let (evd',cllist) = w_unify_to_subterm_list env evd flags p oplist typ in let typp = Typing.meta_type evd' p in - let pred,predtyp = abstract_list_all env evd' typp typ cllist in - if not (is_conv_leq env evd predtyp typp) then - error_wrong_abstraction_type env evd - (Evd.meta_name evd p) pred typp predtyp; - w_merge env false flags (evd',[p,pred,(Conv,TypeProcessed)],[]) + let evd',(pred,predtyp) = abstract_list_all env evd' typp typ cllist in + let evd', b = infer_conv ~pb:CUMUL env evd' predtyp typp in + if not b then + error_wrong_abstraction_type env evd' + (Evd.meta_name evd p) pred typp predtyp; + w_merge env false flags (evd',[p,pred,(Conv,TypeProcessed)],[]) + + (* let evd',metas,evars = *) + (* try unify_0 env evd' CUMUL flags predtyp typp *) + (* with NotConvertible -> *) + (* error_wrong_abstraction_type env evd *) + (* (Evd.meta_name evd p) pred typp predtyp *) + (* in *) + (* w_merge env false flags (evd',(p,pred,(Conv,TypeProcessed))::metas,evars) *) let secondOrderDependentAbstraction env evd flags typ (p, oplist) = let typp = Typing.meta_type evd p in - let pred = abstract_list_all_with_dependencies env evd typp typ oplist in + let evd, pred = abstract_list_all_with_dependencies env evd typp typ oplist in w_merge env false flags (evd,[p,pred,(Conv,TypeProcessed)],[]) let secondOrderAbstractionAlgo dep = @@ -1233,7 +1335,7 @@ let w_unify2 env evd flags dep cv_pb ty1 ty2 = Before, second-order was used if the type of Meta(1) and [x:A]t was convertible and first-order otherwise. But if failed if e.g. the type of Meta(1) had meta-variables in it. *) -let w_unify env evd cv_pb ?(flags=default_unify_flags) ty1 ty2 = +let w_unify env evd cv_pb ?(flags=default_unify_flags ()) ty1 ty2 = let hd1,l1 = decompose_appvect (whd_nored evd ty1) in let hd2,l2 = decompose_appvect (whd_nored evd ty2) in let is_empty1 = Array.is_empty l1 in @@ -1267,3 +1369,14 @@ let w_unify env evd cv_pb ?(flags=default_unify_flags) ty1 ty2 = (* General case: try first order *) | _ -> w_typed_unify env evd cv_pb flags ty1 ty2 + +(* Profiling *) +(* let wunifkey = Profile.declare_profile "w_unify";; *) + +(* let w_unify env evd cv_pb flags ty1 ty2 = *) +(* w_unify env evd cv_pb ~flags:flags ty1 ty2 *) + +(* let w_unify = Profile.profile6 wunifkey w_unify *) + +(* let w_unify env evd cv_pb ?(flags=default_unify_flags ()) ty1 ty2 = *) +(* w_unify env evd cv_pb flags ty1 ty2 *) diff --git a/pretyping/unification.mli b/pretyping/unification.mli index 04e65b862..3f93d817d 100644 --- a/pretyping/unification.mli +++ b/pretyping/unification.mli @@ -27,11 +27,11 @@ type unify_flags = { allow_K_in_toplevel_higher_order_unification : bool } -val default_unify_flags : unify_flags -val default_no_delta_unify_flags : unify_flags +val default_unify_flags : unit -> unify_flags +val default_no_delta_unify_flags : unit -> unify_flags -val elim_flags : unify_flags -val elim_no_delta_flags : unify_flags +val elim_flags : unit -> unify_flags +val elim_no_delta_flags : unit -> unify_flags (** The "unique" unification fonction *) val w_unify : @@ -59,8 +59,7 @@ val w_coerce_to_type : env -> evar_map -> constr -> types -> types -> abstracts the terms in l over c to get a term of type t (exported for inv.ml) *) val abstract_list_all : - env -> evar_map -> constr -> constr -> constr list -> constr * types - + env -> evar_map -> constr -> constr -> constr list -> evar_map * (constr * types) (* For tracing *) @@ -77,3 +76,15 @@ val unify_0 : Environ.env -> Evd.evar_map * Evd.metabinding list * (Environ.env * Term.types Term.pexistential * Term.constr) list +val unify_0_with_initial_metas : + Evd.evar_map * Evd.metabinding list * + (Environ.env * Term.types Term.pexistential * Term.constr) list -> + bool -> + Environ.env -> + Evd.conv_pb -> + unify_flags -> + Term.types -> + Term.types -> + Evd.evar_map * Evd.metabinding list * + (Environ.env * Term.types Term.pexistential * Term.constr) list + diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index b2fa631cd..16eeaa293 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -55,9 +55,11 @@ let find_rectype_a env c = (* Instantiate inductives and parameters in constructor type *) -let type_constructor mind mib typ params = - let s = ind_subst mind mib in +let type_constructor mind mib u typ params = + let s = ind_subst mind mib u in let ctyp = substl s typ in + let usubst = make_inductive_subst mib u in + let ctyp = subst_univs_constr usubst ctyp in let nparams = Array.length params in if Int.equal nparams 0 then ctyp else @@ -67,11 +69,11 @@ let type_constructor mind mib typ params = let construct_of_constr const env tag typ = - let (mind,_ as ind), allargs = find_rectype_a env typ in + let ((mind,_ as ind), u) as indu, allargs = find_rectype_a env typ in (* spiwack : here be a branch for specific decompilation handled by retroknowledge *) try if const then - ((retroknowledge Retroknowledge.get_vm_decompile_constant_info env (mkInd ind) tag), + ((retroknowledge Retroknowledge.get_vm_decompile_constant_info env (mkIndU indu) tag), typ) (*spiwack: this may need to be changed in case there are parameters in the type which may cause a constant value to have an arity. (type_constructor seems to be all about parameters actually) @@ -84,18 +86,19 @@ let construct_of_constr const env tag typ = let nparams = mib.mind_nparams in let i = invert_tag const tag mip.mind_reloc_tbl in let params = Array.sub allargs 0 nparams in - let ctyp = type_constructor mind mib (mip.mind_nf_lc.(i-1)) params in - (mkApp(mkConstruct(ind,i), params), ctyp) + let ctyp = type_constructor mind mib u (mip.mind_nf_lc.(i-1)) params in + (mkApp(mkConstructUi(indu,i), params), ctyp) let construct_of_constr_const env tag typ = fst (construct_of_constr true env tag typ) let construct_of_constr_block = construct_of_constr false +(* FIXME: treatment of universes *) let constr_type_of_idkey env idkey = match idkey with | ConstKey cst -> - mkConst cst, Typeops.type_of_constant env cst + mkConst cst, (Environ.lookup_constant cst env).const_type | VarKey id -> let (_,_,ty) = lookup_named id env in mkVar id, ty @@ -104,17 +107,17 @@ let constr_type_of_idkey env idkey = let (_,_,ty) = lookup_rel n env in mkRel n, lift n ty -let type_of_ind env ind = - type_of_inductive env (Inductive.lookup_mind_specif env ind) +let type_of_ind env ind u = + type_of_inductive env (Inductive.lookup_mind_specif env ind, u) -let build_branches_type env (mind,_ as _ind) mib mip params dep p = +let build_branches_type env (mind,_ as _ind) mib mip u params dep p = let rtbl = mip.mind_reloc_tbl in (* [build_one_branch i cty] construit le type de la ieme branche (commence a 0) et les lambda correspondant aux realargs *) let build_one_branch i cty = - let typi = type_constructor mind mib cty params in + let typi = type_constructor mind mib u cty params in let decl,indapp = decompose_prod_assum typi in - let ind,cargs = find_rectype_a env indapp in + let ((ind,u),cargs) = find_rectype_a env indapp in let nparams = Array.length params in let carity = snd (rtbl.(i)) in let crealargs = Array.sub cargs nparams (Array.length cargs - nparams) in @@ -123,7 +126,7 @@ let build_branches_type env (mind,_ as _ind) mib mip params dep p = if dep then let cstr = ith_constructor_of_inductive ind (i+1) in let relargs = Array.init carity (fun i -> mkRel (carity-i)) in - let dep_cstr = mkApp(mkApp(mkConstruct cstr,params),relargs) in + let dep_cstr = mkApp(mkApp(mkConstructU (cstr,u),params),relargs) in mkApp(papp,[|dep_cstr|]) else papp in @@ -170,7 +173,7 @@ and nf_whd env whd typ = | Vatom_stk(Aiddef(idkey,v), stk) -> nf_whd env (whd_stack v stk) typ | Vatom_stk(Aind ind, stk) -> - nf_stk env (mkInd ind) (type_of_ind env ind) stk + nf_stk env (mkInd ind) (type_of_ind env ind Univ.Instance.empty (*FIXME*)) stk and nf_stk env c t stk = match stk with @@ -183,16 +186,16 @@ and nf_stk env c t stk = let _,_,codom = try decompose_prod env typ with DestKO -> exit 120 in nf_stk env (mkApp(fa,[|c|])) (subst1 c codom) stk | Zswitch sw :: stk -> - let (mind,_ as ind),allargs = find_rectype_a env t in + let ((mind,_ as ind), u), allargs = find_rectype_a env t in let (mib,mip) = Inductive.lookup_mind_specif env ind in let nparams = mib.mind_nparams in let params,realargs = Util.Array.chop nparams allargs in let pT = - hnf_prod_applist env (type_of_ind env ind) (Array.to_list params) in + hnf_prod_applist env (type_of_ind env ind u) (Array.to_list params) in let pT = whd_betadeltaiota env pT in let dep, p = nf_predicate env ind mip params (type_of_switch sw) pT in (* Calcul du type des branches *) - let btypes = build_branches_type env ind mib mip params dep p in + let btypes = build_branches_type env ind mib mip u params dep p in (* calcul des branches *) let bsw = branch_of_switch (nb_rel env) sw in let mkbranch i (n,v) = diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index 92b4bf496..950594397 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -118,6 +118,12 @@ let pr_name = pr_name let pr_qualid = pr_qualid let pr_patvar = pr_id +let pr_universe_instance l = + pr_opt (pr_in_comment Univ.Instance.pr) l + +let pr_cref ref us = + pr_reference ref ++ pr_universe_instance us + let pr_expl_args pr (a,expl) = match expl with | None -> pr (lapp,L) a @@ -397,9 +403,10 @@ let pr_simple_return_type pr na po = let pr_proj pr pr_app a f l = hov 0 (pr (lproj,E) a ++ cut() ++ str ".(" ++ pr_app pr f l ++ str ")") -let pr_appexpl pr f l = +let pr_appexpl pr (f,us) l = hov 2 ( str "@" ++ pr_reference f ++ + pr_universe_instance us ++ prlist (pr_sep_com spc (pr (lapp,L))) l) let pr_app pr a l = @@ -421,7 +428,7 @@ let pr_dangling_with_for sep pr inherited a = let pr pr sep inherited a = let (strm,prec) = match a with - | CRef r -> pr_reference r, latom + | CRef (r,us) -> pr_cref r us, latom | CFix (_,id,fix) -> hov 0 (str"fix " ++ pr_recursive @@ -458,19 +465,19 @@ let pr pr sep inherited a = pr spc ltop a ++ str " in") ++ pr spc ltop b), lletin - | CAppExpl (_,(Some i,f),l) -> + | CAppExpl (_,(Some i,f,us),l) -> let l1,l2 = List.chop i l in let c,l1 = List.sep_last l1 in - let p = pr_proj (pr mt) pr_appexpl c f l1 in + let p = pr_proj (pr mt) pr_appexpl c (f,us) l1 in if not (List.is_empty l2) then p ++ prlist (pr spc (lapp,L)) l2, lapp else p, lproj - | CAppExpl (_,(None,Ident (_,var)),[t]) - | CApp (_,(_,CRef(Ident(_,var))),[t,None]) + | CAppExpl (_,(None,Ident (_,var),us),[t]) + | CApp (_,(_,CRef(Ident(_,var),us)),[t,None]) when Id.equal var Notation_ops.ldots_var -> hov 0 (str ".." ++ pr spc (latom,E) t ++ spc () ++ str ".."), larg - | CAppExpl (_,(None,f),l) -> pr_appexpl (pr mt) f l, lapp + | CAppExpl (_,(None,f,us),l) -> pr_appexpl (pr mt) (f,us) l, lapp | CApp (_,(Some i,f),l) -> let l1,l2 = List.chop i l in let c,l1 = List.sep_last l1 in @@ -567,7 +574,7 @@ let rec fix rf x =rf (fix rf) x let pr = fix modular_constr_pr mt let pr_simpleconstr = function - | CAppExpl (_,(None,f),[]) -> str "@" ++ pr_reference f + | CAppExpl (_,(None,f,us),[]) -> str "@" ++ pr_cref f us | c -> pr lsimpleconstr c let default_term_pr = { diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml index ecc80c2cf..e2d237815 100644 --- a/printing/ppvernac.ml +++ b/printing/ppvernac.ml @@ -176,7 +176,8 @@ let pr_hints db h pr_c pr_pat = match pri with Some x -> spc () ++ str"(" ++ int x ++ str")" | None -> mt ()) l | HintsImmediate l -> - str"Immediate" ++ spc() ++ prlist_with_sep sep (pr_reference_or_constr pr_c) l + str"Immediate" ++ spc() ++ + prlist_with_sep sep (fun c -> pr_reference_or_constr pr_c c) l | HintsUnfold l -> str "Unfold " ++ prlist_with_sep sep pr_reference l | HintsTransparency (l, b) -> @@ -374,6 +375,11 @@ let pr_priority = function | None -> mt () | Some i -> spc () ++ str "|" ++ spc () ++ int i +let pr_poly p = + if Flags.is_universe_polymorphism () then + if not p then str"Monomorphic " else mt () + else if p then str"Polymorphic " else mt () + (**************************************) (* Pretty printer for vernac commands *) (**************************************) @@ -466,6 +472,9 @@ in let pr_using e = str (Proof_using.to_string e) in let rec pr_vernac = function + | VernacPolymorphic (poly, v) -> + let s = if poly then str"Polymorphic" else str"Monomorphic" in + s ++ pr_vernac v | VernacProgram v -> str"Program" ++ spc() ++ pr_vernac v | VernacLocal (local, v) -> pr_locality local ++ spc() ++ pr_vernac v @@ -579,7 +588,7 @@ let rec pr_vernac = function | VernacDefinition (d,id,b) -> (* A verifier... *) let pr_def_token (l,dk) = let l = match l with Some x -> x | None -> Decl_kinds.Global in - str (Kindops.string_of_definition_kind (l,dk)) in + str (Kindops.string_of_definition_kind (l,false,dk)) in let pr_reduce = function | None -> mt() | Some r -> @@ -619,7 +628,6 @@ let rec pr_vernac = function (pr_assumption_token (n > 1) stre ++ spc() ++ pr_ne_params_list pr_lconstr_expr l) | VernacInductive (f,i,l) -> - let pr_constructor (coe,(id,c)) = hov 2 (pr_lident id ++ str" " ++ (if coe then str":>" else str":") ++ diff --git a/printing/prettyp.ml b/printing/prettyp.ml index 89808ef4d..e885f5978 100644 --- a/printing/prettyp.ml +++ b/printing/prettyp.ml @@ -66,7 +66,7 @@ let int_or_no n = if Int.equal n 0 then str "no" else int n let print_basename sp = pr_global (ConstRef sp) let print_ref reduce ref = - let typ = Global.type_of_global ref in + let typ = Global.type_of_global_unsafe ref in let typ = if reduce then let ctx,ccl = Reductionops.splay_prod_assum (Global.env()) Evd.empty typ @@ -122,7 +122,7 @@ let print_renames_list prefix l = hv 2 (prlist_with_sep pr_comma (fun x -> x) (List.map pr_name l))] let need_expansion impl ref = - let typ = Global.type_of_global ref in + let typ = Global.type_of_global_unsafe ref in let ctx = prod_assum typ in let nprods = List.length (List.filter (fun (_,b,_) -> Option.is_empty b) ctx) in not (List.is_empty impl) && List.length impl >= nprods && @@ -371,25 +371,23 @@ let print_body = function let print_typed_body (val_0,typ) = (print_body val_0 ++ fnl () ++ str " : " ++ pr_ltype typ) -let ungeneralized_type_of_constant_type = function - | PolymorphicArity (ctx,a) -> mkArity (ctx, Type a.poly_level) - | NonPolymorphicType t -> t +let ungeneralized_type_of_constant_type t = t let print_constant with_values sep sp = let cb = Global.lookup_constant sp in let val_0 = Declareops.body_of_constant cb in let typ = ungeneralized_type_of_constant_type cb.const_type in - hov 0 ( + hov 0 (pr_polymorphic cb.const_polymorphic ++ match val_0 with | None -> str"*** [ " ++ print_basename sp ++ str " : " ++ cut () ++ pr_ltype typ ++ str" ]" ++ - Printer.pr_univ_cstr (Declareops.constraints_of_constant cb) + Printer.pr_universe_ctx (Future.force cb.const_universes) | _ -> print_basename sp ++ str sep ++ cut () ++ (if with_values then print_typed_body (val_0,typ) else pr_ltype typ)++ - Printer.pr_univ_cstr (Declareops.constraints_of_constant cb)) + Printer.pr_universe_ctx (Future.force cb.const_universes)) let gallina_print_constant_with_infos sp = print_constant true " = " sp ++ @@ -626,7 +624,7 @@ let print_opaque_name qid = | IndRef (sp,_) -> print_inductive sp | ConstructRef cstr -> - let ty = Inductiveops.type_of_constructor env cstr in + let ty = Inductiveops.type_of_constructor env (cstr,Univ.Instance.empty) in print_typed_value (mkConstruct cstr, ty) | VarRef id -> let (_,c,ty) = lookup_named id env in diff --git a/printing/printer.ml b/printing/printer.ml index 935153bff..91156e21f 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -119,12 +119,11 @@ let _ = Termops.set_print_constr pr_lconstr_env let pr_in_comment pr x = str "(* " ++ pr x ++ str " *)" let pr_univ_cstr (c:Univ.constraints) = - if !Detyping.print_universes && not (Univ.is_empty_constraint c) then + if !Detyping.print_universes && not (Univ.Constraint.is_empty c) then fnl()++pr_in_comment (fun c -> v 0 (Univ.pr_constraints c)) c else mt() - (** Term printers resilient to [Nametab] errors *) (** When the nametab isn't up-to-date, the term printers above @@ -179,6 +178,11 @@ let safe_pr_constr_env = safe_gen pr_constr_env let safe_pr_lconstr t = safe_pr_lconstr_env (Global.env()) t let safe_pr_constr t = safe_pr_constr_env (Global.env()) t +let pr_universe_ctx c = + if !Detyping.print_universes && not (Univ.UContext.is_empty c) then + fnl()++pr_in_comment (fun c -> v 0 (Univ.pr_universe_context c)) c + else + mt() (**********************************************************************) (* Global references *) @@ -186,12 +190,22 @@ let safe_pr_constr t = safe_pr_constr_env (Global.env()) t let pr_global_env = pr_global_env let pr_global = pr_global_env Id.Set.empty +let pr_puniverses f env (c,u) = + f env c ++ + (if !Constrextern.print_universes then + str"(*" ++ Univ.Instance.pr u ++ str"*)" + else mt ()) + let pr_constant env cst = pr_global_env (Termops.vars_of_env env) (ConstRef cst) let pr_existential_key evk = str (string_of_existential evk) let pr_existential env ev = pr_lconstr_env env (mkEvar ev) let pr_inductive env ind = pr_lconstr_env env (mkInd ind) let pr_constructor env cstr = pr_lconstr_env env (mkConstruct cstr) +let pr_pconstant = pr_puniverses pr_constant +let pr_pinductive = pr_puniverses pr_inductive +let pr_pconstructor = pr_puniverses pr_constructor + let pr_evaluable_reference ref = pr_global (Tacred.global_of_evaluable_reference ref) @@ -713,6 +727,17 @@ let pr_assumptionset env s = ] in prlist_with_sep fnl (fun x -> x) (Option.List.flatten assums) +open Typeclasses + +let xor a b = + (a && not b) || (not a && b) + +let pr_polymorphic b = + let print = xor (Flags.is_universe_polymorphism ()) b in + if print then + if b then str"Polymorphic " else str"Monomorphic " + else mt () + (** Inductive declarations *) open Termops @@ -730,17 +755,17 @@ let print_constructors envpar names types = hv 0 (str " " ++ pc) let build_ind_type env mip = - match mip.mind_arity with - | Monomorphic ar -> ar.mind_user_arity - | Polymorphic ar -> - it_mkProd_or_LetIn (mkSort (Type ar.poly_level)) mip.mind_arity_ctxt + mip.mind_arity.mind_user_arity let print_one_inductive env mib ((_,i) as ind) = let mip = mib.mind_packets.(i) in let params = mib.mind_params_ctxt in let args = extended_rel_list 0 params in let arity = hnf_prod_applist env (build_ind_type env mip) args in - let cstrtypes = Inductive.type_of_constructors ind (mib,mip) in + let u = if mib.mind_polymorphic then + Univ.UContext.instance mib.mind_universes + else Univ.Instance.empty in + let cstrtypes = Inductive.type_of_constructors (ind,u) (mib,mip) in let cstrtypes = Array.map (fun c -> hnf_prod_applist env c args) cstrtypes in let envpar = push_rel_context params env in hov 0 ( @@ -751,11 +776,11 @@ let print_one_inductive env mib ((_,i) as ind) = let print_mutual_inductive env mind mib = let inds = List.init (Array.length mib.mind_packets) (fun x -> (mind, x)) in - hov 0 ( + hov 0 (pr_polymorphic mib.mind_polymorphic ++ str (if mib.mind_finite then "Inductive " else "CoInductive ") ++ prlist_with_sep (fun () -> fnl () ++ str" with ") (print_one_inductive env mib) inds ++ - pr_univ_cstr mib.mind_constraints) + pr_universe_ctx mib.mind_universes) let get_fields = let rec prodec_rec l subst c = @@ -774,13 +799,17 @@ let print_record env mind mib = let mip = mib.mind_packets.(0) in let params = mib.mind_params_ctxt in let args = extended_rel_list 0 params in + let u = if mib.mind_polymorphic then + Univ.UContext.instance mib.mind_universes + else Univ.Instance.empty in let arity = hnf_prod_applist env (build_ind_type env mip) args in - let cstrtypes = Inductive.type_of_constructors (mind,0) (mib,mip) in + let cstrtypes = Inductive.type_of_constructors ((mind,0),u) (mib,mip) in let cstrtype = hnf_prod_applist env cstrtypes.(0) args in let fields = get_fields cstrtype in let envpar = push_rel_context params env in hov 0 ( hov 0 ( + pr_polymorphic mib.mind_polymorphic ++ str "Record " ++ pr_id mip.mind_typename ++ brk(1,4) ++ print_params env params ++ str ": " ++ pr_lconstr_env envpar arity ++ brk(1,2) ++ @@ -791,10 +820,10 @@ let print_record env mind mib = (fun (id,b,c) -> pr_id id ++ str (if b then " : " else " := ") ++ pr_lconstr_env envpar c) fields) ++ str" }" ++ - pr_univ_cstr mib.mind_constraints) + pr_universe_ctx mib.mind_universes) let pr_mutual_inductive_body env mind mib = - if mib.mind_record && not !Flags.raw_print then + if mib.mind_record <> None && not !Flags.raw_print then print_record env mind mib else print_mutual_inductive env mind mib diff --git a/printing/printer.mli b/printing/printer.mli index 6ca55b16b..eb181d426 100644 --- a/printing/printer.mli +++ b/printing/printer.mli @@ -80,7 +80,9 @@ val pr_sort : sorts -> std_ppcmds (** Universe constraints *) +val pr_polymorphic : bool -> std_ppcmds val pr_univ_cstr : Univ.constraints -> std_ppcmds +val pr_universe_ctx : Univ.universe_context -> std_ppcmds (** Printing global references using names as short as possible *) @@ -94,6 +96,11 @@ val pr_constructor : env -> constructor -> std_ppcmds val pr_inductive : env -> inductive -> std_ppcmds val pr_evaluable_reference : evaluable_global_reference -> std_ppcmds +val pr_pconstant : env -> pconstant -> std_ppcmds +val pr_pinductive : env -> pinductive -> std_ppcmds +val pr_pconstructor : env -> pconstructor -> std_ppcmds + + (** Contexts *) val pr_ne_context_of : std_ppcmds -> env -> std_ppcmds diff --git a/printing/printmod.ml b/printing/printmod.ml index 112abeec9..da5546bac 100644 --- a/printing/printmod.ml +++ b/printing/printmod.ml @@ -146,8 +146,7 @@ let print_body is_impl env mp (l,body) = | None -> mt () | Some env -> str " :" ++ spc () ++ - hov 0 (Printer.pr_ltype_env env - (Typeops.type_of_constant_type env cb.const_type)) ++ + hov 0 (Printer.pr_ltype_env env cb.const_type) ++ (match cb.const_body with | Def l when is_impl -> spc () ++ diff --git a/proofs/clenv.ml b/proofs/clenv.ml index 64a9f0024..afc8d3b70 100644 --- a/proofs/clenv.ml +++ b/proofs/clenv.ml @@ -42,12 +42,27 @@ type clausenv = { let cl_env ce = ce.env let cl_sigma ce = ce.evd +let map_clenv sub clenv = + { templval = map_fl sub clenv.templval; + templtyp = map_fl sub clenv.templtyp; + evd = cmap sub clenv.evd; + env = clenv.env } + let clenv_nf_meta clenv c = nf_meta clenv.evd c let clenv_term clenv c = meta_instance clenv.evd c let clenv_meta_type clenv mv = Typing.meta_type clenv.evd mv let clenv_value clenv = meta_instance clenv.evd clenv.templval let clenv_type clenv = meta_instance clenv.evd clenv.templtyp +let refresh_undefined_univs clenv = + match kind_of_term clenv.templval.rebus with + | Var _ -> clenv, Univ.empty_level_subst + | App (f, args) when isVar f -> clenv, Univ.empty_level_subst + | _ -> + let evd', subst = Evd.refresh_undefined_universes clenv.evd in + let map_freelisted f = { f with rebus = subst_univs_level_constr subst f.rebus } in + { clenv with evd = evd'; templval = map_freelisted clenv.templval; + templtyp = map_freelisted clenv.templtyp }, subst let clenv_hnf_constr ce t = hnf_constr (cl_env ce) (cl_sigma ce) t @@ -239,14 +254,14 @@ let clenv_dependent ce = clenv_dependent_gen false ce (******************************************************************) -let clenv_unify ?(flags=default_unify_flags) cv_pb t1 t2 clenv = +let clenv_unify ?(flags=default_unify_flags ()) cv_pb t1 t2 clenv = { clenv with evd = w_unify ~flags clenv.env clenv.evd cv_pb t1 t2 } -let clenv_unify_meta_types ?(flags=default_unify_flags) clenv = +let clenv_unify_meta_types ?(flags=default_unify_flags ()) clenv = { clenv with evd = w_unify_meta_types ~flags:flags clenv.env clenv.evd } -let clenv_unique_resolver ?(flags=default_unify_flags) clenv gl = +let clenv_unique_resolver ?(flags=default_unify_flags ()) clenv gl = let concl = Goal.V82.concl clenv.evd (sig_it gl) in if isMeta (fst (decompose_appvect (whd_nored clenv.evd clenv.templtyp.rebus))) then clenv_unify CUMUL ~flags (clenv_type clenv) concl @@ -305,6 +320,9 @@ let connect_clenv gls clenv = evd = evd ; env = Goal.V82.env evd (sig_it gls) } +(* let connect_clenv_key = Profile.declare_profile "connect_clenv";; *) +(* let connect_clenv = Profile.profile2 connect_clenv_key connect_clenv *) + (* [clenv_fchain mv clenv clenv'] * * Resolves the value of "mv" (which must be undefined) in clenv to be @@ -329,11 +347,11 @@ let connect_clenv gls clenv = In particular, it assumes that [env'] and [sigma'] extend [env] and [sigma]. *) -let fchain_flags = - { default_unify_flags with +let fchain_flags () = + { (default_unify_flags ()) with allow_K_in_toplevel_higher_order_unification = true } -let clenv_fchain ?(flags=fchain_flags) mv clenv nextclenv = +let clenv_fchain ?(flags=fchain_flags ()) mv clenv nextclenv = (* Add the metavars of [nextclenv] to [clenv], with their name-environment *) let clenv' = { templval = clenv.templval; diff --git a/proofs/clenv.mli b/proofs/clenv.mli index ab4f3af79..35bed8f40 100644 --- a/proofs/clenv.mli +++ b/proofs/clenv.mli @@ -23,6 +23,9 @@ type clausenv = { out *) templtyp : constr freelisted (** its type *)} + +val map_clenv : (constr -> constr) -> clausenv -> clausenv + (** subject of clenv (instantiated) *) val clenv_value : clausenv -> constr @@ -41,6 +44,9 @@ val mk_clenv_from_n : val mk_clenv_type_of : Goal.goal sigma -> constr -> clausenv val mk_clenv_from_env : env -> evar_map -> int option -> constr * types -> clausenv +(** Refresh the universes in a clenv *) +val refresh_undefined_univs : clausenv -> clausenv * Univ.universe_level_subst + (** {6 linking of clenvs } *) val connect_clenv : Goal.goal sigma -> clausenv -> clausenv diff --git a/proofs/clenvtac.ml b/proofs/clenvtac.ml index 7a1a14bde..112402bca 100644 --- a/proofs/clenvtac.ml +++ b/proofs/clenvtac.ml @@ -29,6 +29,7 @@ let clenv_cast_meta clenv = match kind_of_term u with | App _ | Case _ -> crec_hd u | Cast (c,_,_) when isMeta c -> u + | Proj (p, c) -> mkProj (p, crec_hd c) | _ -> map_constr crec u and crec_hd u = @@ -43,6 +44,7 @@ let clenv_cast_meta clenv = | App(f,args) -> mkApp (crec_hd f, Array.map crec args) | Case(ci,p,c,br) -> mkCase (ci, crec_hd p, crec_hd c, Array.map crec br) + | Proj (p, c) -> mkProj (p, crec_hd c) | _ -> u in crec @@ -68,15 +70,15 @@ let clenv_refine with_evars ?(with_classes=true) clenv gls = in let clenv = { clenv with evd = evd' } in tclTHEN - (tclEVARS evd') - (refine (clenv_cast_meta clenv (clenv_value clenv))) + (tclEVARS (Evd.clear_metas evd')) + (refine_no_check (clenv_cast_meta clenv (clenv_value clenv))) gls open Unification let dft = default_unify_flags -let res_pf clenv ?(with_evars=false) ?(flags=dft) gls = +let res_pf clenv ?(with_evars=false) ?(flags=dft ()) gls = clenv_refine with_evars (clenv_unique_resolver ~flags clenv gls) gls (* [unifyTerms] et [unify] ne semble pas gérer les Meta, en diff --git a/proofs/logic.ml b/proofs/logic.ml index 054e6db6c..02f3a16d8 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -324,6 +324,7 @@ let collect_meta_variables c = | Meta mv -> if deep then error_unsupported_deep_meta () else mv::acc | Cast(c,_,_) -> collrec deep acc c | (App _| Case _) -> fold_constr (collrec deep) acc c + | Proj (_, c) -> collrec deep acc c | _ -> fold_constr (collrec true) acc c in List.rev (collrec false [] c) @@ -333,12 +334,15 @@ let check_meta_variables c = raise (RefinerError (NonLinearProof c)) let check_conv_leq_goal env sigma arg ty conclty = - if !check && not (is_conv_leq env sigma ty conclty) then - raise (RefinerError (BadType (arg,ty,conclty))) + if !check then + let evm, b = Reductionops.infer_conv env sigma ty conclty in + if b then evm + else raise (RefinerError (BadType (arg,ty,conclty))) + else sigma let goal_type_of env sigma c = if !check then type_of env sigma c - else Retyping.get_type_of ~refresh:true env sigma c + else Retyping.get_type_of env sigma c let rec mk_refgoals sigma goal goalacc conclty trm = let env = Goal.V82.env sigma goal in @@ -346,17 +350,22 @@ let rec mk_refgoals sigma goal goalacc conclty trm = let mk_goal hyps concl = Goal.V82.mk_goal sigma hyps concl (Goal.V82.extra sigma goal) in - match kind_of_term trm with - | Meta _ -> + if (not !check) && not (occur_meta trm) then + let t'ty = Retyping.get_type_of env sigma trm in + let sigma = check_conv_leq_goal env sigma trm t'ty conclty in + (goalacc,t'ty,sigma,trm) + else + match kind_of_term trm with + | Meta _ -> let conclty = nf_betaiota sigma conclty in if !check && occur_meta conclty then raise (RefinerError (MetaInType conclty)); let (gl,ev,sigma) = mk_goal hyps conclty in gl::goalacc, conclty, sigma, ev - | Cast (t,k, ty) -> + | Cast (t,k, ty) -> check_typability env sigma ty; - check_conv_leq_goal env sigma trm ty conclty; + let sigma = check_conv_leq_goal env sigma trm ty conclty in let res = mk_refgoals sigma goal goalacc ty t in (** we keep the casts (in particular VMcast and NATIVEcast) except when they are annotating metas *) @@ -368,11 +377,11 @@ let rec mk_refgoals sigma goal goalacc conclty trm = let ans = if ans == t then trm else mkCast(ans,k,ty) in (gls,cty,sigma,ans) - | App (f,l) -> + | App (f,l) -> let (acc',hdty,sigma,applicand) = match kind_of_term f with | Ind _ | Const _ - when (isInd f || has_polymorphic_type (destConst f)) -> + when (isInd f || has_polymorphic_type (fst (destConst f))) -> (* Sort-polymorphism of definition and inductive types *) goalacc, type_of_global_reference_knowing_conclusion env sigma f conclty, @@ -381,13 +390,19 @@ let rec mk_refgoals sigma goal goalacc conclty trm = mk_hdgoals sigma goal goalacc f in let ((acc'',conclty',sigma), args) = mk_arggoals sigma goal acc' hdty l in - check_conv_leq_goal env sigma trm conclty' conclty; + let sigma = check_conv_leq_goal env sigma trm conclty' conclty in let ans = if applicand == f && args == l then trm else Term.mkApp (applicand, args) in (acc'',conclty',sigma, ans) - | Case (ci,p,c,lf) -> + | Proj (p,c) -> + let (acc',cty,sigma,c') = mk_hdgoals sigma goal goalacc c in + let c = mkProj (p, c') in + let ty = get_type_of env sigma c in + (acc',ty,sigma,c) + + | Case (ci,p,c,lf) -> let (acc',lbrty,conclty',sigma,p',c') = mk_casegoals sigma goal goalacc p c in - check_conv_leq_goal env sigma trm conclty' conclty; + let sigma = check_conv_leq_goal env sigma trm conclty' conclty in let (acc'',sigma, rbranches) = Array.fold_left2 (fun (lacc,sigma,bacc) ty fi -> @@ -401,13 +416,12 @@ let rec mk_refgoals sigma goal goalacc conclty trm = in (acc'',conclty',sigma, ans) - | _ -> + | _ -> if occur_meta trm then anomaly (Pp.str "refiner called with a meta in non app/case subterm"); - - let t'ty = goal_type_of env sigma trm in - check_conv_leq_goal env sigma trm t'ty conclty; - (goalacc,t'ty,sigma, trm) + let t'ty = goal_type_of env sigma trm in + let sigma = check_conv_leq_goal env sigma trm t'ty conclty in + (goalacc,t'ty,sigma, trm) (* Same as mkREFGOALS but without knowing the type of the term. Therefore, * Metas should be casted. *) @@ -454,6 +468,12 @@ and mk_hdgoals sigma goal goalacc trm = in (acc'',conclty',sigma, ans) + | Proj (p,c) -> + let (acc',cty,sigma,c') = mk_hdgoals sigma goal goalacc c in + let c = mkProj (p, c') in + let ty = get_type_of env sigma c in + (acc',ty,sigma,c) + | _ -> if !check && occur_meta trm then anomaly (Pp.str "refine called with a dependent meta"); @@ -569,12 +589,12 @@ let prim_refiner r sigma goal = check_ind (push_rel (na,None,c1) env) (k-1) b | _ -> error "Not enough products." in - let (sp,_) = check_ind env n cl in + let ((sp,_),u) = check_ind env n cl in let firsts,lasts = List.chop j rest in let all = firsts@(f,n,cl)::lasts in let rec mk_sign sign = function | (f,n,ar)::oth -> - let (sp',_) = check_ind env n ar in + let ((sp',_),u') = check_ind env n ar in if not (eq_mind sp sp') then error ("Fixpoints should be on the same " ^ "mutual inductive declaration."); @@ -652,13 +672,11 @@ let prim_refiner r sigma goal = (* Conversion rules *) | Convert_concl (cl',k) -> check_typability env sigma cl'; - if (not !check) || is_conv_leq env sigma cl' cl then - let (sg,ev,sigma) = mk_goal sign cl' in - let ev = if k != DEFAULTcast then mkCast(ev,k,cl) else ev in - let sigma = Goal.V82.partial_solution sigma goal ev in + let (sg,ev,sigma) = mk_goal sign cl' in + let sigma = check_conv_leq_goal env sigma cl' cl' cl in + let ev = if k != DEFAULTcast then mkCast(ev,k,cl) else ev in + let sigma = Goal.V82.partial_solution sigma goal ev in ([sg], sigma) - else - error "convert-concl rule passed non-converting term" | Convert_hyp (id,copt,ty) -> let (gl,ev,sigma) = mk_goal (convert_hyp sign sigma (id,copt,ty)) cl in diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index f45eb2a3a..3fc01c0bc 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -118,26 +118,28 @@ open Decl_kinds let next = let n = ref 0 in fun () -> incr n; !n -let build_constant_by_tactic id sign ?(goal_kind = Global,Proof Theorem) typ tac = +let build_constant_by_tactic id sign ?(goal_kind = Global, false, Proof Theorem) typ tac = + let substref = ref Univ.LMap.empty in (** FIXME: Something wrong here with subst *) start_proof id goal_kind sign typ (fun _ -> ()); try let status = by tac in let _,(const,_) = cook_proof () in delete_current_proof (); - const, status + const, status, !substref with reraise -> let reraise = Errors.push reraise in delete_current_proof (); raise reraise -let build_by_tactic env typ tac = +let build_by_tactic env ?(poly=false) typ tac = let id = Id.of_string ("temporary_proof"^string_of_int (next())) in let sign = val_of_named_context (named_context env) in - let ce,status = build_constant_by_tactic id sign typ tac in + let gk = Global, poly, Proof Theorem in + let ce, status, subst = build_constant_by_tactic id sign ~goal_kind:gk typ tac in let ce = Term_typing.handle_side_effects env ce in let cb, se = Future.force ce.const_entry_body in - assert(Declareops.side_effects_is_empty (Declareops.no_seff)); - cb,status + assert(Declareops.side_effects_is_empty se); + cb, status, subst (**********************************************************************) (* Support for resolution of evars in tactic interpretation, including @@ -156,6 +158,9 @@ let solve_by_implicit_tactic env sigma evk = when Context.named_context_equal (Environ.named_context_of_val evi.evar_hyps) (Environ.named_context env) -> - (try fst (build_by_tactic env evi.evar_concl (Proofview.tclTHEN tac (Proofview.tclEXTEND [] (Proofview.tclZERO (Errors.UserError ("",Pp.str"Proof is not complete."))) []))) + let tac = Proofview.tclTHEN tac (Proofview.tclEXTEND [] (Proofview.tclZERO (Errors.UserError ("",Pp.str"Proof is not complete."))) []) in + (try + let (ans, _, _) = build_by_tactic env (evi.evar_concl, Evd.get_universe_context_set sigma) tac in + ans with e when Logic.catchable_exception e -> raise Exit) | _ -> raise Exit diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli index fea1b701e..877b7c858 100644 --- a/proofs/pfedit.mli +++ b/proofs/pfedit.mli @@ -56,7 +56,7 @@ val delete_all_proofs : unit -> unit type lemma_possible_guards = Proof_global.lemma_possible_guards val start_proof : - Id.t -> goal_kind -> named_context_val -> constr -> + Id.t -> goal_kind -> named_context_val -> constr Univ.in_universe_context_set -> ?init_tac:unit Proofview.tactic -> Proof_global.proof_terminator -> unit @@ -149,8 +149,10 @@ val instantiate_nth_evar_com : int -> Constrexpr.constr_expr -> unit val build_constant_by_tactic : Id.t -> named_context_val -> ?goal_kind:goal_kind -> - types -> unit Proofview.tactic -> Entries.definition_entry * bool -val build_by_tactic : env -> types -> unit Proofview.tactic -> constr * bool + types Univ.in_universe_context_set -> unit Proofview.tactic -> Entries.definition_entry * bool * Universes.universe_opt_subst +val build_by_tactic : env -> ?poly:polymorphic -> + types Univ.in_universe_context_set -> unit Proofview.tactic -> + constr * bool * Universes.universe_opt_subst (** Declare the default tactic to fill implicit arguments *) @@ -161,10 +163,3 @@ val clear_implicit_tactic : unit -> unit (* Raise Exit if cannot solve *) val solve_by_implicit_tactic : env -> Evd.evar_map -> Evd.evar -> constr - - - - - - - diff --git a/proofs/proof.mli b/proofs/proof.mli index ac922ac50..30b65d0ce 100644 --- a/proofs/proof.mli +++ b/proofs/proof.mli @@ -51,9 +51,8 @@ val proof : proof -> (*** General proof functions ***) -val start : Evd.evar_map -> (Environ.env * Term.types) list -> proof +val start : Evd.evar_map -> (Environ.env * Term.types Univ.in_universe_context_set) list -> proof val dependent_start : Evd.evar_map -> Proofview.telescope -> proof - val initial_goals : proof -> (Term.constr * Term.types) list (* Returns [true] if the considered proof is completed, that is if no goal remain diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index 3cdecb633..7434979f8 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -68,6 +68,7 @@ type proof_object = { id : Names.Id.t; entries : Entries.definition_entry list; persistence : Decl_kinds.goal_kind; + opt_subst : Universes.universe_opt_subst; } type proof_ending = @@ -78,6 +79,10 @@ type proof_ending = type proof_terminator = proof_ending -> unit type closed_proof = proof_object * proof_terminator +type 'a proof_decl_hook = + Universes.universe_opt_subst Univ.in_universe_context -> + Decl_kinds.locality -> Globnames.global_reference -> 'a + type pstate = { pid : Id.t; terminator : proof_terminator Ephemeron.key; @@ -264,18 +269,29 @@ let get_open_goals () = let close_proof ?feedback_id ~now fpl = let { pid; section_vars; strength; proof; terminator } = cur_pstate () in let initial_goals = Proof.initial_goals proof in - let entries = - Future.map2 (fun p (c, t) -> { Entries. - const_entry_body = p; - const_entry_secctx = section_vars; - const_entry_feedback = feedback_id; - const_entry_type = Some t; - const_entry_inline_code = false; - const_entry_opaque = true }) - fpl initial_goals in + let evdref = ref (Proof.return proof) in + let nf,subst = Evarutil.e_nf_evars_and_universes evdref in + let initial_goals = List.map (fun (c,t) -> (nf c, nf t)) initial_goals in + let ctx = Evd.universe_context !evdref in + let entries = Future.map2 (fun p (c, t) -> + let univs = + Univ.LSet.union (Universes.universes_of_constr c) + (Universes.universes_of_constr t) + in + let ctx = Universes.restrict_universe_context (Univ.ContextSet.of_context ctx) univs in + { Entries. + const_entry_body = p; + const_entry_secctx = section_vars; + const_entry_type = Some t; + const_entry_feedback = feedback_id; + const_entry_inline_code = false; + const_entry_opaque = true; + const_entry_universes = Univ.ContextSet.to_context ctx; + const_entry_polymorphic = pi2 strength; + const_entry_proj = None}) fpl initial_goals in if now then - List.iter (fun x ->ignore(Future.force x.Entries.const_entry_body)) entries; - { id = pid; entries = entries; persistence = strength }, + List.iter (fun x -> ignore(Future.force x.Entries.const_entry_body)) entries; + { id = pid; entries = entries; persistence = strength; opt_subst = subst }, Ephemeron.get terminator let return_proof () = @@ -312,6 +328,9 @@ let set_terminator hook = | [] -> raise NoCurrentProof | p :: ps -> pstates := { p with terminator = Ephemeron.create hook } :: ps + + + (**********************************************************) (* *) (* Bullets *) diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli index 47d63e2eb..e651bdfae 100644 --- a/proofs/proof_global.mli +++ b/proofs/proof_global.mli @@ -46,6 +46,10 @@ exception NoCurrentProof val give_me_the_proof : unit -> Proof.proof (** @raise NoCurrentProof when outside proof mode. *) +type 'a proof_decl_hook = + Universes.universe_opt_subst Univ.in_universe_context -> + Decl_kinds.locality -> Globnames.global_reference -> 'a + (** When a proof is closed, it is reified into a [proof_object], where [id] is the name of the proof, [entries] the list of the proof terms (in a form suitable for definitions). Together with the [terminator] @@ -57,6 +61,7 @@ type proof_object = { id : Names.Id.t; entries : Entries.definition_entry list; persistence : Decl_kinds.goal_kind; + opt_subst : Universes.universe_opt_subst; } type proof_ending = @@ -74,7 +79,7 @@ type closed_proof = proof_object * proof_terminator closing commands and the xml plugin); [terminator] is used at the end of the proof to close the proof. *) val start_proof : - Names.Id.t -> Decl_kinds.goal_kind -> (Environ.env * Term.types) list -> + Names.Id.t -> Decl_kinds.goal_kind -> (Environ.env * Term.types Univ.in_universe_context_set) list -> proof_terminator -> unit (** Like [start_proof] except that there may be dependencies between diff --git a/proofs/proofview.ml b/proofs/proofview.ml index 22d908e94..d0a477431 100644 --- a/proofs/proofview.ml +++ b/proofs/proofview.ml @@ -36,10 +36,11 @@ let proofview p = let init sigma = let rec aux = function | [] -> [], { solution = sigma; comb = []; } - | (env, typ) :: l -> + | (env, (typ,ctx)) :: l -> let ret, { solution = sol; comb = comb } = aux l in let (new_defs , econstr) = Evarutil.new_evar sol env typ in let (e, _) = Term.destEvar econstr in + let new_defs = Evd.merge_context_set Evd.univ_rigid new_defs ctx in let gl = Goal.build e in let entry = (econstr, typ) :: ret in entry, { solution = new_defs; comb = gl::comb; } @@ -88,6 +89,12 @@ let partial_proof entry pv = List.map (return_constr pv) (List.map fst entry) let emit_side_effects eff x = { x with solution = Evd.emit_side_effects eff x.solution } +(* let return { initial=init; solution=defs } = *) +(* let evdref = ref defs in *) +(* let nf,subst = Evarutil.e_nf_evars_and_universes evdref in *) +(* ((List.map (fun (c,t) -> (nf c, nf t)) init, subst), *) +(* Evd.universe_context !evdref) *) + (* spiwack: this function should probably go in the Util section, but I'd rather have Util (or a separate module for lists) raise proper exceptions before *) diff --git a/proofs/proofview.mli b/proofs/proofview.mli index 55d93f92e..bfb88c897 100644 --- a/proofs/proofview.mli +++ b/proofs/proofview.mli @@ -37,7 +37,7 @@ type entry (* Initialises a proofview, the argument is a list of environement, conclusion types, creating that many initial goals. *) -val init : Evd.evar_map -> (Environ.env * Term.types) list -> entry * proofview +val init : Evd.evar_map -> (Environ.env * Term.types Univ.in_universe_context_set) list -> entry * proofview type telescope = | TNil diff --git a/proofs/refiner.ml b/proofs/refiner.ml index 9a78a79fd..663e24f9f 100644 --- a/proofs/refiner.ml +++ b/proofs/refiner.ml @@ -27,6 +27,10 @@ let refiner pr goal_sigma = let (sgl,sigma') = prim_refiner pr goal_sigma.sigma goal_sigma.it in { it = sgl; sigma = sigma'; } +(* Profiling refiner *) +(* let refiner_key = Profile.declare_profile "refiner" *) +(* let refiner = Profile.profile2 refiner_key refiner *) + (*********************) (* Tacticals *) (*********************) @@ -318,6 +322,19 @@ let rec tclREPEAT_MAIN t g = (* Change evars *) let tclEVARS sigma gls = tclIDTAC {gls with sigma=sigma} +(* Push universe context *) +let tclPUSHCONTEXT rigid ctx tac gl = + tclTHEN (tclEVARS (Evd.merge_context_set rigid (project gl) ctx)) tac gl + +let tclPUSHEVARUNIVCONTEXT ctx gl = + tclEVARS (Evd.merge_universe_context (project gl) ctx) gl + +let tclPUSHCONSTRAINTS cst gl = + tclEVARS (Evd.add_constraints (project gl) cst) gl + +let tclPUSHUNIVERSECONSTRAINTS cst gl = + tclEVARS (Evd.add_universe_constraints (project gl) cst) gl + (* Check that holes in arguments have been resolved *) let check_evars env sigma extsigma origsigma = diff --git a/proofs/refiner.mli b/proofs/refiner.mli index f73bdaf93..25ab1fb76 100644 --- a/proofs/refiner.mli +++ b/proofs/refiner.mli @@ -34,6 +34,12 @@ val tclIDTAC_MESSAGE : Pp.std_ppcmds -> tactic (** [tclEVARS sigma] changes the current evar map *) val tclEVARS : evar_map -> tactic +val tclPUSHCONTEXT : Evd.rigid -> Univ.universe_context_set -> tactic -> tactic +val tclPUSHEVARUNIVCONTEXT : Evd.evar_universe_context -> tactic + +val tclPUSHCONSTRAINTS : Univ.constraints -> tactic +val tclPUSHUNIVERSECONSTRAINTS : Univ.UniverseConstraints.t -> tactic + (** [tclTHEN tac1 tac2 gls] applies the tactic [tac1] to [gls] and applies [tac2] to every resulting subgoals *) val tclTHEN : tactic -> tactic -> tactic diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml index 855529ac2..2faf18355 100644 --- a/proofs/tacmach.ml +++ b/proofs/tacmach.ml @@ -86,8 +86,10 @@ let pf_unfoldn ubinds = pf_reduce (unfoldn ubinds) let pf_type_of = pf_reduce type_of let pf_get_type_of = pf_reduce Retyping.get_type_of -let pf_conv_x = pf_reduce is_conv -let pf_conv_x_leq = pf_reduce is_conv_leq +let pf_conv_x gl = pf_reduce test_conversion gl Reduction.CONV +let pf_conv_x_leq gl = pf_reduce test_conversion gl Reduction.CUMUL +let pf_const_value = pf_reduce (fun env _ -> constant_value_in env) + let pf_reduce_to_quantified_ind = pf_reduce reduce_to_quantified_ind let pf_reduce_to_atomic_ind = pf_reduce reduce_to_atomic_ind diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli index 7bac4c6e9..326d14bf6 100644 --- a/proofs/tacmach.mli +++ b/proofs/tacmach.mli @@ -62,12 +62,13 @@ val pf_whd_betadeltaiota : goal sigma -> constr -> constr val pf_hnf_constr : goal sigma -> constr -> constr val pf_nf : goal sigma -> constr -> constr val pf_nf_betaiota : goal sigma -> constr -> constr -val pf_reduce_to_quantified_ind : goal sigma -> types -> inductive * types -val pf_reduce_to_atomic_ind : goal sigma -> types -> inductive * types +val pf_reduce_to_quantified_ind : goal sigma -> types -> pinductive * types +val pf_reduce_to_atomic_ind : goal sigma -> types -> pinductive * types val pf_compute : goal sigma -> constr -> constr val pf_unfoldn : (occurrences * evaluable_global_reference) list -> goal sigma -> constr -> constr +val pf_const_value : goal sigma -> pconstant -> constr val pf_conv_x : goal sigma -> constr -> constr -> bool val pf_conv_x_leq : goal sigma -> constr -> constr -> bool @@ -125,7 +126,7 @@ module New : sig val pf_last_hyp : [ `NF ] Proofview.Goal.t -> named_declaration val pf_nf_concl : [ `LZ ] Proofview.Goal.t -> types - val pf_reduce_to_quantified_ind : 'a Proofview.Goal.t -> types -> inductive * types + val pf_reduce_to_quantified_ind : 'a Proofview.Goal.t -> types -> pinductive * types val pf_hnf_constr : 'a Proofview.Goal.t -> constr -> types val pf_hnf_type_of : 'a Proofview.Goal.t -> constr -> types diff --git a/stm/lemmas.ml b/stm/lemmas.ml index 8f16ad5a4..2aeb8141e 100644 --- a/stm/lemmas.ml +++ b/stm/lemmas.ml @@ -73,7 +73,7 @@ let find_mutually_recursive_statements thms = | Some (Some (_,id),CStructRec) -> let i,b,typ = lookup_rel_id id hyps in (match kind_of_term t with - | Ind (kn,_ as ind) when + | Ind ((kn,_ as ind), u) when let mind = Global.lookup_mind kn in mind.mind_finite && Option.is_empty b -> [ind,x,i],[] @@ -90,7 +90,7 @@ let find_mutually_recursive_statements thms = let ind_hyps = List.flatten (List.map_i (fun i (_,b,t) -> match kind_of_term t with - | Ind (kn,_ as ind) when + | Ind ((kn,_ as ind),u) when let mind = Global.lookup_mind kn in mind.mind_finite && Option.is_empty b -> [ind,x,i] @@ -100,7 +100,7 @@ let find_mutually_recursive_statements thms = let cclenv = push_rel_context hyps (Global.env()) in let whnf_ccl,_ = whd_betadeltaiota_stack cclenv Evd.empty ccl in match kind_of_term whnf_ccl with - | Ind (kn,_ as ind) when + | Ind ((kn,_ as ind),u) when let mind = Global.lookup_mind kn in Int.equal mind.mind_ntypes n && not mind.mind_finite -> [ind,x,0] @@ -167,9 +167,11 @@ let look_for_possibly_mutual_statements = function (* Saving a goal *) -let save id const do_guard (locality,kind) hook = +let save id const cstrs do_guard (locality,poly,kind) hook = let const = adjust_guardness_conditions const do_guard in let k = Kindops.logical_kind_of_goal_kind kind in + (* Add global constraints necessary to check the type of the proof *) + let () = Global.add_constraints cstrs in let l,r = match locality with | Discharge when Lib.sections_are_opened () -> let c = SectionLocalDef const in @@ -198,14 +200,14 @@ let compute_proof_name locality = function | None -> next_global_ident_away default_thm_id (Pfedit.get_all_proof_names ()) -let save_remaining_recthms (locality,kind) body opaq i (id,(t_i,(_,imps))) = +let save_remaining_recthms (locality,p,kind) body opaq i (id,((t_i,ctx_i),(_,imps))) = match body with | None -> (match locality with | Discharge -> let impl = false in (* copy values from Vernacentries *) let k = IsAssumption Conjectural in - let c = SectionLocalAssum (t_i,impl) in + let c = SectionLocalAssum ((t_i,ctx_i),p,impl) in let _ = declare_variable id (Lib.cwd(),c,k) in (Discharge, VarRef id,imps) | Local | Global -> @@ -215,7 +217,8 @@ let save_remaining_recthms (locality,kind) body opaq i (id,(t_i,(_,imps))) = | Global -> false | Discharge -> assert false in - let decl = (ParameterEntry (None,t_i,None), k) in + let ctx = Univ.ContextSet.to_context ctx_i in + let decl = (ParameterEntry (None,p,(t_i,ctx),None), k) in let kn = declare_constant id ~local decl in (locality,ConstRef kn,imps)) | Some body -> @@ -230,27 +233,26 @@ let save_remaining_recthms (locality,kind) body opaq i (id,(t_i,(_,imps))) = Future.from_val (body_i,Declareops.no_seff); const_entry_secctx = None; const_entry_type = Some t_i; + const_entry_proj = None; const_entry_opaque = opaq; - const_entry_inline_code = false; const_entry_feedback = None; + const_entry_inline_code = false; + const_entry_polymorphic = p; + const_entry_universes = Univ.ContextSet.to_context ctx_i } in let c = SectionLocalDef const in let _ = declare_variable id (Lib.cwd(), c, k) in (Discharge,VarRef id,imps) | Local | Global -> + let ctx = Univ.ContextSet.to_context ctx_i in let local = match locality with | Local -> true | Global -> false | Discharge -> assert false in - let const = { const_entry_body = - Future.from_val (body_i,Declareops.no_seff); - const_entry_secctx = None; - const_entry_type = Some t_i; - const_entry_opaque = opaq; - const_entry_inline_code = false; - const_entry_feedback = None; - } in + let const = + Declare.definition_entry ~types:t_i ~poly:p ~univs:ctx ~opaque:opaq body_i + in let kn = declare_constant id ~local (DefinitionEntry const, k) in (locality,ConstRef kn,imps) @@ -258,8 +260,8 @@ let save_hook = ref ignore let set_save_hook f = save_hook := f let save_named proof = - let id,const,do_guard,persistence,hook = proof in - save id const do_guard persistence hook + let id,const,cstrs,do_guard,persistence,hook = proof in + save id const cstrs do_guard persistence hook let check_anonymity id save_ident = if not (String.equal (atompart_of_id id) (Id.to_string (default_thm_id))) then @@ -267,25 +269,29 @@ let check_anonymity id save_ident = let save_anonymous proof save_ident = - let id,const,do_guard,persistence,hook = proof in + let id,const,cstrs,do_guard,persistence,hook = proof in check_anonymity id save_ident; - save save_ident const do_guard persistence hook + save save_ident const cstrs do_guard persistence hook let save_anonymous_with_strength proof kind save_ident = - let id,const,do_guard,_,hook = proof in + let id,const,cstrs,do_guard,_,hook = proof in check_anonymity id save_ident; (* we consider that non opaque behaves as local for discharge *) - save save_ident const do_guard (Global, Proof kind) hook + save save_ident const cstrs do_guard (Global, const.const_entry_polymorphic, Proof kind) hook (* Admitted *) let admit hook () = let (id,k,typ) = Pfedit.current_proof_statement () in - let e = Pfedit.get_used_variables(), typ, None in - let kn = declare_constant id (ParameterEntry e,IsAssumption Conjectural) in - let () = match fst k with - | Global -> () - | Local | Discharge -> + let ctx = + let evd = fst (Pfedit.get_current_goal_context ()) in + Evd.universe_context evd + in + let e = Pfedit.get_used_variables(), pi2 k, (typ, ctx), None in + let kn = declare_constant id (ParameterEntry e, IsAssumption Conjectural) in + let () = match k with + | Global, _, _ -> () + | Local, _, _ | Discharge, _, _ -> msg_warning (str "Let definition" ++ spc () ++ pr_id id ++ spc () ++ str "declared as an axiom.") in @@ -302,7 +308,8 @@ let get_proof proof do_guard hook opacity = let (id,(const,persistence)) = Pfedit.cook_this_proof proof in - id,{const with const_entry_opaque = opacity},do_guard,persistence,hook + (** FIXME *) + id,{const with const_entry_opaque = opacity},Univ.Constraint.empty,do_guard,persistence,hook let standard_proof_terminator compute_guard hook = let open Proof_global in function @@ -325,13 +332,14 @@ let start_proof id kind ?sign c ?init_tac ?(compute_guard=[]) hook = | Some sign -> sign | None -> initialize_named_context_for_proof () in - !start_hook c; + !start_hook (fst c); Pfedit.start_proof id kind sign c ?init_tac terminator +(* FIXME: forgetting about the universes here *) let rec_tac_initializer finite guard thms snl = if finite then - match List.map (fun (id,(t,_)) -> (id,t)) thms with + match List.map (fun (id,(t,_)) -> (id,fst t)) thms with | (id,_)::l -> Tactics.mutual_cofix id l 0 | _ -> assert false else @@ -339,7 +347,7 @@ let rec_tac_initializer finite guard thms snl = let nl = match snl with | None -> List.map succ (List.map List.last guard) | Some nl -> nl - in match List.map2 (fun (id,(t,_)) n -> (id,n,t)) thms nl with + in match List.map2 (fun (id,(t,_)) n -> (id,n,fst t)) thms nl with | (id,n,_)::l -> Tactics.mutual_fix id n l 0 | _ -> assert false @@ -382,19 +390,24 @@ let start_proof_with_initialization kind recguard thms snl hook = start_proof id kind t ?init_tac hook ~compute_guard:guard let start_proof_com kind thms hook = - let evdref = ref Evd.empty in let env0 = Global.env () in + let evdref = ref (Evd.from_env env0) in let thms = List.map (fun (sopt,(bl,t,guard)) -> let impls, ((env, ctx), imps) = interp_context_evars evdref env0 bl in let t', imps' = interp_type_evars_impls ~impls evdref env t in check_evars_are_solved env Evd.empty !evdref; let ids = List.map pi1 ctx in - (compute_proof_name (fst kind) sopt, + (compute_proof_name (pi1 kind) sopt, (nf_evar !evdref (it_mkProd_or_LetIn t' ctx), (ids, imps @ lift_implicits (List.length ids) imps'), guard))) thms in let recguard,thms,snl = look_for_possibly_mutual_statements thms in + let evd, nf = Evarutil.nf_evars_and_universes !evdref in + let ctxset = Evd.get_universe_context_set evd in + let thms = List.map (fun (n, (t, info)) -> (n, ((nf t, ctxset), info))) + thms + in start_proof_with_initialization kind recguard thms snl hook @@ -419,13 +432,3 @@ let get_current_context () = try Pfedit.get_current_goal_context () with e when Logic.catchable_exception e -> (Evd.empty, Global.env()) - - - - - - - - - - diff --git a/stm/lemmas.mli b/stm/lemmas.mli index bbe383a85..f8694a096 100644 --- a/stm/lemmas.mli +++ b/stm/lemmas.mli @@ -17,7 +17,7 @@ open Pfedit (** A hook start_proof calls on the type of the definition being started *) val set_start_hook : (types -> unit) -> unit -val start_proof : Id.t -> goal_kind -> ?sign:Environ.named_context_val -> types -> +val start_proof : Id.t -> goal_kind -> ?sign:Environ.named_context_val -> types Univ.in_universe_context_set -> ?init_tac:unit Proofview.tactic -> ?compute_guard:lemma_possible_guards -> unit declaration_hook -> unit @@ -27,7 +27,7 @@ val start_proof_com : goal_kind -> val start_proof_with_initialization : goal_kind -> (bool * lemma_possible_guards * unit Proofview.tactic list option) option -> - (Id.t * (types * (Name.t list * Impargs.manual_explicitation list))) list + (Id.t * (types Univ.in_universe_context_set * (Name.t list * Impargs.manual_explicitation list))) list -> int list option -> unit declaration_hook -> unit val standard_proof_terminator : diff --git a/stm/stm.ml b/stm/stm.ml index 6fe3fd03a..0218c923b 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -741,8 +741,9 @@ end = struct let l = Future.force (build_proof_here exn_info loc eop) in List.iter (fun (_,se) -> Declareops.iter_side_effects (function | Declarations.SEsubproof(_, - { Declarations.const_body = Declarations.OpaqueDef f } ) -> - Opaqueproof.join_opaque f + { Declarations.const_body = Declarations.OpaqueDef f; + const_universes = univs } ) -> + Opaqueproof.join_opaque f; ignore (Future.join univs) (* FIXME: MS: needed?*) | _ -> ()) se) l; l, Unix.gettimeofday () -. wall_clock in @@ -814,7 +815,7 @@ end = struct let extra = Future.join uc in u.(bucket) <- uc; p.(bucket) <- pr; - u, Univ.union_constraints cst extra, false + u, Univ.union_constraint cst extra, false | _ -> assert false let check_task name l i = @@ -982,13 +983,13 @@ end = struct Pp.feedback (Interface.InProgress ~-1) *) last_task := None; raise KillRespawn - | _, RespGetCounterFreshLocalUniv -> - marshal_more_data oc (MoreDataLocalUniv - (CList.init 10 (fun _ -> Univ.fresh_local_univ ()))); - if !cancel_switch then raise KillRespawn else loop () + | _, RespGetCounterFreshLocalUniv -> assert false (* Deprecated function *) + (* marshal_more_data oc (MoreDataLocalUniv *) + (* (CList.init 10 (fun _ -> Universes.fresh_local_univ ()))); *) + (* loop () *) | _, RespGetCounterNewUnivLevel -> marshal_more_data oc (MoreDataUnivLevel - (CList.init 10 (fun _ -> Termops.new_univ_level ()))); + (CList.init 10 (fun _ -> Universes.new_univ_level (Global.current_dirpath ())))); loop () | _, RespFeedback {id = State state_id; content = msg} -> Pp.feedback ~state_id msg; @@ -1082,14 +1083,10 @@ end = struct Marshal.to_channel oc (RespFeedback fb) []; flush oc in Pp.set_feeder (slave_feeder !slave_oc); - Termops.set_remote_new_univ_level (bufferize (fun () -> + Universes.set_remote_new_univ_level (bufferize (fun () -> marshal_response !slave_oc RespGetCounterNewUnivLevel; match unmarshal_more_data !slave_ic with | MoreDataUnivLevel l -> l | _ -> assert false)); - Univ.set_remote_fresh_local_univ (bufferize (fun () -> - marshal_response !slave_oc RespGetCounterFreshLocalUniv; - match unmarshal_more_data !slave_ic with - | MoreDataLocalUniv l -> l | _ -> assert false)); let working = ref false in slave_handshake (); while true do diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index 49cbcd246..3bd83f46b 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -66,6 +66,7 @@ let rec classify_vernac e = (* Nested vernac exprs *) | VernacProgram e -> classify_vernac e | VernacLocal (_,e) -> classify_vernac e + | VernacPolymorphic (b, e) -> classify_vernac e | VernacTimeout (_,e) -> classify_vernac e | VernacTime e -> classify_vernac e | VernacFail e -> (* Fail Qed or Fail Lemma must not join/fork the DAG *) diff --git a/tactics/auto.ml b/tactics/auto.ml index 152556c74..0f296c6af 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -36,16 +36,17 @@ open Tacexpr open Mod_subst open Locus open Proofview.Notations +open Decl_kinds (****************************************************************************) (* The Type of Constructions Autotactic Hints *) (****************************************************************************) type 'a auto_tactic = - | Res_pf of constr * 'a (* Hint Apply *) - | ERes_pf of constr * 'a (* Hint EApply *) - | Give_exact of constr - | Res_pf_THEN_trivial_fail of constr * 'a (* Hint Immediate *) + | Res_pf of 'a (* Hint Apply *) + | ERes_pf of 'a (* Hint EApply *) + | Give_exact of 'a + | Res_pf_THEN_trivial_fail of 'a (* Hint Immediate *) | Unfold_nth of evaluable_global_reference (* Hint Unfold *) | Extern of glob_tactic_expr (* Hint Extern *) @@ -61,16 +62,22 @@ type hints_path = | PathEmpty | PathEpsilon +type hint_term = + | IsGlobRef of global_reference + | IsConstr of constr * Univ.universe_context_set + type 'a gen_auto_tactic = { pri : int; (* A number lower is higher priority *) + poly : polymorphic; (** Is the hint polymorpic and hence should be refreshed at each application *) pat : constr_pattern option; (* A pattern for the concl of the Goal *) name : hints_path_atom; (* A potential name to refer to the hint *) code : 'a auto_tactic (* the tactic to apply when the concl matches pat *) } -type pri_auto_tactic = clausenv gen_auto_tactic +type pri_auto_tactic = (constr * clausenv) gen_auto_tactic -type hint_entry = global_reference option * types gen_auto_tactic +type hint_entry = global_reference option * + (constr * types * Univ.universe_context_set) gen_auto_tactic let eq_hints_path_atom p1 p2 = match p1, p2 with | PathHints gr1, PathHints gr2 -> List.equal eq_gr gr1 gr2 @@ -80,7 +87,7 @@ let eq_hints_path_atom p1 p2 = match p1, p2 with let eq_auto_tactic t1 t2 = match t1, t2 with | Res_pf (c1, _), Res_pf (c2, _) -> Constr.equal c1 c2 | ERes_pf (c1, _), ERes_pf (c2, _) -> Constr.equal c1 c2 -| Give_exact c1, Give_exact c2 -> Constr.equal c1 c2 +| Give_exact (c1, _), Give_exact (c2, _) -> Constr.equal c1 c2 | Res_pf_THEN_trivial_fail (c1, _), Res_pf_THEN_trivial_fail (c2, _) -> Constr.equal c1 c2 | Unfold_nth gr1, Unfold_nth gr2 -> eq_egr gr1 gr2 | Extern tac1, Extern tac2 -> tac1 == tac2 (** May cause redundancy in addkv *) @@ -134,17 +141,23 @@ type search_entry = stored_data list * stored_data list * Bounded_net.t let empty_se = ([],[],Bounded_net.create ()) +let eq_constr_or_reference x y = + match x, y with + | IsConstr (x,_), IsConstr (y,_) -> eq_constr x y + | IsGlobRef x, IsGlobRef y -> eq_gr x y + | _, _ -> false + let eq_pri_auto_tactic (_, x) (_, y) = if Int.equal x.pri y.pri && Option.equal constr_pattern_eq x.pat y.pat then match x.code,y.code with - | Res_pf(cstr,_),Res_pf(cstr1,_) -> + | Res_pf (cstr,_),Res_pf (cstr1,_) -> eq_constr cstr cstr1 - | ERes_pf(cstr,_),ERes_pf(cstr1,_) -> + | ERes_pf (cstr,_),ERes_pf (cstr1,_) -> eq_constr cstr cstr1 - | Give_exact cstr,Give_exact cstr1 -> + | Give_exact (cstr,_),Give_exact (cstr1,_) -> eq_constr cstr cstr1 - | Res_pf_THEN_trivial_fail(cstr,_) - ,Res_pf_THEN_trivial_fail(cstr1,_) -> + | Res_pf_THEN_trivial_fail (cstr,_) + ,Res_pf_THEN_trivial_fail (cstr1,_) -> eq_constr cstr cstr1 | _,_ -> false else @@ -176,20 +189,44 @@ let is_transparent_gr (ids, csts) = function let dummy_goal = Goal.V82.dummy_goal -let translate_hint (go,p) = - let mk_clenv (c,t) = - let cl = mk_clenv_from dummy_goal (c,t) in {cl with env = empty_env } +let instantiate_constr_or_ref env sigma c = + let c, ctx = Universes.fresh_global_or_constr_instance env c in + let cty = Retyping.get_type_of env sigma c in + (c, cty), ctx + +let strip_params env c = + match kind_of_term c with + | App (f, args) -> + (match kind_of_term f with + | Const (p,_) -> + let cb = lookup_constant p env in + (match cb.Declarations.const_proj with + | Some pb -> + let n = pb.Declarations.proj_npars in + mkApp (mkProj (p, args.(n)), + Array.sub args (n+1) (Array.length args - (n + 1))) + | None -> c) + | _ -> c) + | _ -> c + +let instantiate_hint p = + let mk_clenv c cty ctx = + let sigma = Evd.merge_context_set univ_flexible dummy_goal.sigma ctx in + let goal = { dummy_goal with sigma = sigma } in + let cl = mk_clenv_from goal (c,cty) in + {cl with templval = + { cl.templval with rebus = strip_params (Global.env()) cl.templval.rebus }; + env = empty_env} in let code = match p.code with - | Res_pf (c,t) -> Res_pf (c, mk_clenv (c,t)) - | ERes_pf (c,t) -> ERes_pf (c, mk_clenv (c,t)) - | Res_pf_THEN_trivial_fail (c,t) -> - Res_pf_THEN_trivial_fail (c, mk_clenv (c,t)) - | Give_exact c -> Give_exact c + | Res_pf (c, cty, ctx) -> Res_pf (c, mk_clenv c cty ctx) + | ERes_pf (c, cty, ctx) -> ERes_pf (c, mk_clenv c cty ctx) + | Res_pf_THEN_trivial_fail (c, cty, ctx) -> + Res_pf_THEN_trivial_fail (c, mk_clenv c cty ctx) + | Give_exact (c, cty, ctx) -> Give_exact (c, mk_clenv c cty ctx) | Unfold_nth e -> Unfold_nth e | Extern t -> Extern t - in - (go,{ p with code = code }) + in { pri = p.pri; poly = p.poly; name = p.name; pat = p.pat; code = code } let hints_path_atom_eq h1 h2 = match h1, h2 with | PathHints l1, PathHints l2 -> List.equal eq_gr l1 l2 @@ -350,17 +387,19 @@ module Hint_db = struct try Constr_map.find key db.hintdb_map with Not_found -> empty_se + let realize_tac (id,tac) = tac + let map_none db = - List.map snd (List.merge pri_order_int (List.map snd db.hintdb_nopat) []) + List.map realize_tac (Sort.merge pri_order (List.map snd db.hintdb_nopat) []) let map_all k db = let (l,l',_) = find k db in - List.map snd (List.merge pri_order_int (List.map snd db.hintdb_nopat @ l) l') + List.map realize_tac (Sort.merge pri_order (List.map snd db.hintdb_nopat @ l) l') let map_auto (k,c) db = let st = if db.use_dn then Some db.hintdb_state else None in let l' = lookup_tacs (k,c) st (find k db) in - List.map snd (List.merge pri_order_int (List.map snd db.hintdb_nopat) l') + List.map realize_tac (Sort.merge pri_order (List.map snd db.hintdb_nopat) l') let is_exact = function | Give_exact _ -> true @@ -384,6 +423,7 @@ module Hint_db = struct (** ppedrot: this equality here is dubious. Maybe we can remove it? *) let is_present (_, (_, v')) = eq_gen_auto_tactic v v' in if not (List.exists is_present db.hintdb_nopat) then + (** FIXME *) { db with hintdb_nopat = (gr,idv) :: db.hintdb_nopat } else db | Some gr -> @@ -397,8 +437,8 @@ module Hint_db = struct in List.fold_left (fun db (gr,(id,v)) -> addkv gr id v db) db' db.hintdb_nopat - let add_one kv db = - let (k,v) = translate_hint kv in + let add_one (k, v) db = + let v = instantiate_hint v in let st',db,rebuild = match v.code with | Unfold_nth egr -> @@ -432,8 +472,8 @@ module Hint_db = struct let remove_one gr db = remove_list [gr] db let iter f db = - f None (List.map (fun x -> snd (snd x)) db.hintdb_nopat); - Constr_map.iter (fun k (l,l',_) -> f (Some k) (List.map snd (l@l'))) db.hintdb_map + f None (List.map (fun x -> realize_tac (snd x)) db.hintdb_nopat); + Constr_map.iter (fun k (l,l',_) -> f (Some k) (List.map realize_tac (l@l'))) db.hintdb_map let fold f db accu = let accu = f None (List.map (fun x -> snd (snd x)) db.hintdb_nopat) accu in @@ -516,7 +556,7 @@ let try_head_pattern c = try head_pattern_bound c with BoundPattern -> error "Bound head variable." -let make_exact_entry sigma pri ?(name=PathAny) (c,cty) = +let make_exact_entry env sigma pri poly ?(name=PathAny) (c, cty, ctx) = let cty = strip_outer_cast cty in match kind_of_term cty with | Prod _ -> failwith "make_exact_entry" @@ -528,15 +568,17 @@ let make_exact_entry sigma pri ?(name=PathAny) (c,cty) = in (Some hd, { pri = (match pri with None -> 0 | Some p -> p); + poly = poly; pat = Some pat; name = name; - code = Give_exact c }) + code = Give_exact (c, cty, ctx) }) -let make_apply_entry env sigma (eapply,hnf,verbose) pri ?(name=PathAny) (c,cty) = +let make_apply_entry env sigma (eapply,hnf,verbose) pri poly ?(name=PathAny) (c, cty, ctx) = let cty = if hnf then hnf_constr env sigma cty else cty in match kind_of_term cty with | Prod _ -> - let ce = mk_clenv_from dummy_goal (c,cty) in + let sigma' = Evd.merge_context_set univ_flexible dummy_goal.sigma ctx in + let ce = mk_clenv_from { dummy_goal with sigma = sigma' } (c,cty) in let c' = clenv_type (* ~reduce:false *) ce in let pat = snd (Patternops.pattern_of_constr sigma c') in let hd = @@ -546,9 +588,10 @@ let make_apply_entry env sigma (eapply,hnf,verbose) pri ?(name=PathAny) (c,cty) if Int.equal nmiss 0 then (Some hd, { pri = (match pri with None -> nb_hyp cty | Some p -> p); + poly = poly; pat = Some pat; name = name; - code = Res_pf(c,cty) }) + code = Res_pf(c,cty,ctx) }) else begin if not eapply then failwith "make_apply_entry"; if verbose then @@ -556,9 +599,10 @@ let make_apply_entry env sigma (eapply,hnf,verbose) pri ?(name=PathAny) (c,cty) str " will only be used by eauto"); (Some hd, { pri = (match pri with None -> nb_hyp cty + nmiss | Some p -> p); + poly = poly; pat = Some pat; name = name; - code = ERes_pf(c,cty) }) + code = ERes_pf(c,cty,ctx) }) end | _ -> failwith "make_apply_entry" @@ -566,12 +610,18 @@ let make_apply_entry env sigma (eapply,hnf,verbose) pri ?(name=PathAny) (c,cty) c is a constr cty is the type of constr *) -let make_resolves env sigma flags pri ?name c = +let fresh_global_or_constr env sigma poly cr = + match cr with + | IsGlobRef gr -> Universes.fresh_global_instance env gr + | IsConstr (c, ctx) -> (c, ctx) + +let make_resolves env sigma flags pri poly ?name cr = + let c, ctx = fresh_global_or_constr env sigma poly cr in let cty = Retyping.get_type_of env sigma c in let try_apply f = - try Some (f (c, cty)) with Failure _ -> None in + try Some (f (c, cty, ctx)) with Failure _ -> None in let ents = List.map_filter try_apply - [make_exact_entry sigma pri ?name; make_apply_entry env sigma flags pri ?name] + [make_exact_entry env sigma pri poly ?name; make_apply_entry env sigma flags pri poly ?name] in if List.is_empty ents then errorlabstrm "Hint" @@ -583,9 +633,9 @@ let make_resolves env sigma flags pri ?name c = (* used to add an hypothesis to the local hint database *) let make_resolve_hyp env sigma (hname,_,htyp) = try - [make_apply_entry env sigma (true, true, false) None + [make_apply_entry env sigma (true, true, false) None false ~name:(PathHints [VarRef hname]) - (mkVar hname, htyp)] + (mkVar hname, htyp, Univ.ContextSet.empty)] with | Failure _ -> [] | e when Logic.catchable_exception e -> anomaly (Pp.str "make_resolve_hyp") @@ -595,6 +645,7 @@ let make_unfold eref = let g = global_of_evaluable_reference eref in (Some g, { pri = 4; + poly = false; pat = None; name = PathHints [g]; code = Unfold_nth eref }) @@ -603,19 +654,21 @@ let make_extern pri pat tacast = let hdconstr = Option.map try_head_pattern pat in (hdconstr, { pri = pri; + poly = false; pat = pat; name = PathAny; code = Extern tacast }) -let make_trivial env sigma ?(name=PathAny) r = - let c = constr_of_global_or_constr r in +let make_trivial env sigma poly ?(name=PathAny) r = + let c,ctx = fresh_global_or_constr env sigma poly r in let t = hnf_constr env sigma (type_of env sigma c) in - let hd = head_of_constr_reference (fst (head_constr t)) in + let hd = head_of_constr_reference (head_constr t) in let ce = mk_clenv_from dummy_goal (c,t) in (Some hd, { pri=1; + poly = poly; pat = Some (snd (Patternops.pattern_of_constr sigma (clenv_type ce))); name = name; - code=Res_pf_THEN_trivial_fail(c,t) }) + code=Res_pf_THEN_trivial_fail(c,t,ctx) }) open Vernacexpr @@ -675,11 +728,21 @@ let cache_autohint (_,(local,name,hints)) = let (forward_subst_tactic, extern_subst_tactic) = Hook.make () + (* let subst_mps_or_ref subst cr = *) + (* match cr with *) + (* | IsConstr c -> let c' = subst_mps subst c in *) + (* if c' == c then cr *) + (* else IsConstr c' *) + (* | IsGlobal r -> let r' = subst_global_reference subst r in *) + (* if r' == r then cr *) + (* else IsGlobal r' *) + (* in *) + let subst_autohint (subst,(local,name,hintlist as obj)) = let subst_key gr = let (lab'', elab') = subst_global subst gr in let gr' = - (try head_of_constr_reference (fst (head_constr_bound elab')) + (try head_of_constr_reference (head_constr_bound elab') with Tactics.Bound -> lab'') in if gr' == gr then gr else gr' in @@ -687,21 +750,22 @@ let subst_autohint (subst,(local,name,hintlist as obj)) = let k' = Option.smartmap subst_key k in let pat' = Option.smartmap (subst_pattern subst) data.pat in let code' = match data.code with - | Res_pf (c,t) -> + | Res_pf (c,t,ctx) -> let c' = subst_mps subst c in let t' = subst_mps subst t in - if c==c' && t'==t then data.code else Res_pf (c', t') - | ERes_pf (c,t) -> + if c==c' && t'==t then data.code else Res_pf (c', t',ctx) + | ERes_pf (c,t,ctx) -> let c' = subst_mps subst c in let t' = subst_mps subst t in - if c==c' && t'==t then data.code else ERes_pf (c',t') - | Give_exact c -> + if c==c' && t'==t then data.code else ERes_pf (c',t',ctx) + | Give_exact (c,t,ctx) -> let c' = subst_mps subst c in - if c==c' then data.code else Give_exact c' - | Res_pf_THEN_trivial_fail (c,t) -> + let t' = subst_mps subst t in + if c==c' && t'== t then data.code else Give_exact (c',t',ctx) + | Res_pf_THEN_trivial_fail (c,t,ctx) -> let c' = subst_mps subst c in let t' = subst_mps subst t in - if c==c' && t==t' then data.code else Res_pf_THEN_trivial_fail (c',t') + if c==c' && t==t' then data.code else Res_pf_THEN_trivial_fail (c',t',ctx) | Unfold_nth ref -> let ref' = subst_evaluable_reference subst ref in if ref==ref' then data.code else Unfold_nth ref' @@ -765,13 +829,9 @@ let add_resolves env sigma clist local dbnames = Lib.add_anonymous_leaf (inAutoHint (local,dbname, AddHints - (List.flatten (List.map (fun (x, hnf, path, gr) -> - let c = - match gr with - | IsConstr c -> c - | IsGlobal gr -> constr_of_global gr - in - make_resolves env sigma (true,hnf,Flags.is_verbose()) x ~name:path c) clist))))) + (List.flatten (List.map (fun (pri, poly, hnf, path, gr) -> + make_resolves env sigma (true,hnf,Flags.is_verbose()) + pri poly ~name:path gr) clist))))) dbnames let add_unfolds l local dbnames = @@ -808,14 +868,20 @@ let add_trivials env sigma l local dbnames = (fun dbname -> Lib.add_anonymous_leaf ( inAutoHint(local,dbname, - AddHints (List.map (fun (name, c) -> make_trivial env sigma ~name c) l)))) + AddHints (List.map (fun (name, poly, c) -> make_trivial env sigma poly ~name c) l)))) dbnames let (forward_intern_tac, extern_intern_tac) = Hook.make () +type hnf = bool + +let pr_hint_term = function + | IsConstr (c,_) -> pr_constr c + | IsGlobRef gr -> pr_global gr + type hints_entry = - | HintsResolveEntry of (int option * bool * hints_path_atom * global_reference_or_constr) list - | HintsImmediateEntry of (hints_path_atom * global_reference_or_constr) list + | HintsResolveEntry of (int option * polymorphic * hnf * hints_path_atom * hint_term) list + | HintsImmediateEntry of (hints_path_atom * polymorphic * hint_term) list | HintsCutEntry of hints_path | HintsUnfoldEntry of evaluable_global_reference list | HintsTransparencyEntry of evaluable_global_reference list * bool @@ -826,7 +892,7 @@ let h = Id.of_string "H" exception Found of constr * types -let prepare_hint env (sigma,c) = +let prepare_hint check env init (sigma,c) = let sigma = Typeclasses.resolve_typeclasses ~fail:false env sigma in (* We re-abstract over uninstantiated evars. It is actually a bit stupid to generalize over evars since the first @@ -853,15 +919,16 @@ let prepare_hint env (sigma,c) = vars := Id.Set.add id !vars; subst := (evar,mkVar id)::!subst; mkNamedLambda id t (iter (replace_term evar (mkVar id) c)) in - iter c + let c' = iter c in + if check then Evarutil.check_evars (Global.env()) Evd.empty sigma c'; + let diff = Evd.diff sigma init in + IsConstr (c', Evd.get_universe_context_set diff) -let interp_hints = +let interp_hints poly = fun h -> let f c = let evd,c = Constrintern.interp_open_constr Evd.empty (Global.env()) c in - let c = prepare_hint (Global.env()) (evd,c) in - Evarutil.check_evars (Global.env()) Evd.empty evd c; - c in + prepare_hint true (Global.env()) Evd.empty (evd,c) in let fr r = let gr = global_with_alias r in let r' = evaluable_of_global_reference (Global.env()) gr in @@ -871,12 +938,17 @@ let interp_hints = match c with | HintsReference c -> let gr = global_with_alias c in - (PathHints [gr], IsGlobal gr) - | HintsConstr c -> (PathAny, IsConstr (f c)) + (PathHints [gr], poly, IsGlobRef gr) + | HintsConstr c -> + (* if poly then *) + (* errorlabstrm "Hint" (Ppconstr.pr_constr_expr c ++ spc () ++ *) + (* str" is a term and cannot be made a polymorphic hint," ++ *) + (* str" only global references can be polymorphic hints.") *) + (* else *) (PathAny, poly, f c) in - let fres (o, b, c) = - let path, gr = fi c in - (o, b, path, gr) + let fres (pri, b, r) = + let path, poly, gr = fi r in + (pri, poly, b, path, gr) in let fp = Constrintern.intern_constr_pattern (Global.env()) in match h with @@ -888,11 +960,14 @@ let interp_hints = | HintsConstructors lqid -> let constr_hints_of_ind qid = let ind = global_inductive_with_alias qid in + let mib,_ = Global.lookup_inductive ind in Dumpglob.dump_reference (fst (qualid_of_reference qid)) "<>" (string_of_reference qid) "ind"; - List.init (nconstructors ind) (fun i -> let c = (ind,i+1) in - let gr = ConstructRef c in - None, true, PathHints [gr], IsGlobal gr) in - HintsResolveEntry (List.flatten (List.map constr_hints_of_ind lqid)) + List.init (nconstructors ind) + (fun i -> let c = (ind,i+1) in + let gr = ConstructRef c in + None, mib.Declarations.mind_polymorphic, true, + PathHints [gr], IsGlobRef gr) + in HintsResolveEntry (List.flatten (List.map constr_hints_of_ind lqid)) | HintsExtern (pri, patcom, tacexp) -> let pat = Option.map fp patcom in let l = match pat with None -> [] | Some (l, _) -> l in @@ -922,7 +997,7 @@ let pr_autotactic = function | Res_pf (c,clenv) -> (str"apply " ++ pr_constr c) | ERes_pf (c,clenv) -> (str"eapply " ++ pr_constr c) - | Give_exact c -> (str"exact " ++ pr_constr c) + | Give_exact (c,clenv) -> (str"exact " ++ pr_constr c) | Res_pf_THEN_trivial_fail (c,clenv) -> (str"apply " ++ pr_constr c ++ str" ; trivial") | Unfold_nth c -> (str"unfold " ++ pr_evaluable_reference c) @@ -970,11 +1045,11 @@ let pr_hint_term cl = let dbs = current_db () in let valid_dbs = let fn = try - let (hdc,args) = head_constr_bound cl in + let hdc = head_constr_bound cl in let hd = head_of_constr_reference hdc in if occur_existential cl then Hint_db.map_all hd - else Hint_db.map_auto (hd, applist (hdc,args)) + else Hint_db.map_auto (hd, cl) with Bound -> Hint_db.map_none in let fn db = List.map (fun x -> 0, x) (fn db) in @@ -1072,40 +1147,52 @@ let auto_unif_flags = { (* Try unification with the precompiled clause, then use registered Apply *) -let unify_resolve_nodelta (c,clenv) gl = - let clenv' = connect_clenv gl clenv in +let unify_resolve_nodelta poly (c,clenv) gl = + let clenv' = if poly then fst (Clenv.refresh_undefined_univs clenv) else clenv in + let clenv' = connect_clenv gl clenv' in let clenv'' = clenv_unique_resolver ~flags:auto_unif_flags clenv' gl in Clenvtac.clenv_refine false clenv'' gl -let unify_resolve flags (c,clenv) gl = - let clenv' = connect_clenv gl clenv in +let unify_resolve poly flags (c,clenv) gl = + let clenv' = if poly then fst (Clenv.refresh_undefined_univs clenv) else clenv in + let clenv' = connect_clenv gl clenv' in let clenv'' = clenv_unique_resolver ~flags clenv' gl in Clenvtac.clenv_refine false clenv'' gl -let unify_resolve_gen = function - | None -> unify_resolve_nodelta - | Some flags -> unify_resolve flags - +let unify_resolve_gen poly = function + | None -> unify_resolve_nodelta poly + | Some flags -> unify_resolve poly flags + +let exact poly (c,clenv) = + let c' = + if poly then + let evd', subst = Evd.refresh_undefined_universes clenv.evd in + subst_univs_level_constr subst c + else c + in exact_check c' + (* Util *) -let expand_constructor_hints env lems = - List.map_append (fun (sigma,lem) -> +let expand_constructor_hints env sigma lems = + List.map_append (fun (evd,lem) -> match kind_of_term lem with - | Ind ind -> - List.init (nconstructors ind) (fun i -> mkConstruct (ind,i+1)) + | Ind (ind,u) -> + List.init (nconstructors ind) + (fun i -> IsConstr (mkConstructU ((ind,i+1),u), + Univ.ContextSet.empty)) | _ -> - [prepare_hint env (sigma,lem)]) lems + [prepare_hint false env sigma (evd,lem)]) lems (* builds a hint database from a constr signature *) (* typically used with (lid, ltyp) = pf_hyps_types <some goal> *) let add_hint_lemmas eapply lems hint_db gl = - let lems = expand_constructor_hints (pf_env gl) lems in + let lems = expand_constructor_hints (pf_env gl) (project gl) lems in let hintlist' = - List.map_append (pf_apply make_resolves gl (eapply,true,false) None) lems in + List.map_append (pf_apply make_resolves gl (eapply,true,false) None true) lems in Hint_db.add_list hintlist' hint_db -let make_local_hint_db ?ts eapply lems gl = +let make_local_hint_db ts eapply lems gl = let sign = pf_hyps gl in let ts = match ts with | None -> Hint_db.transparent_state (searchtable_map "core") @@ -1115,6 +1202,15 @@ let make_local_hint_db ?ts eapply lems gl = add_hint_lemmas eapply lems (Hint_db.add_list hintlist (Hint_db.empty ts false)) gl +let make_local_hint_db = + if Flags.profile then + let key = Profile.declare_profile "make_local_hint_db" in + Profile.profile4 key make_local_hint_db + else make_local_hint_db + +let make_local_hint_db ?ts eapply lems gl = + make_local_hint_db ts eapply lems gl + (* Serait-ce possible de compiler d'abord la tactique puis de faire la substitution sans passer par bdize dont l'objectif est de préparer un terme pour l'affichage ? (HH) *) @@ -1358,15 +1454,15 @@ and my_find_search_delta db_list local_db hdc concl = in List.map (fun x -> (Some flags,x)) l) (local_db::db_list) -and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t})) = +and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t;poly=poly})) = let tactic = match t with - | Res_pf (c,cl) -> Proofview.V82.tactic (unify_resolve_gen flags (c,cl)) + | Res_pf (c,cl) -> Proofview.V82.tactic (unify_resolve_gen poly flags (c,cl)) | ERes_pf _ -> Proofview.V82.tactic (fun gl -> error "eres_pf") - | Give_exact c -> Proofview.V82.tactic (exact_check c) + | Give_exact (c, cl) -> Proofview.V82.tactic (exact poly (c, cl)) | Res_pf_THEN_trivial_fail (c,cl) -> Tacticals.New.tclTHEN - (Proofview.V82.tactic (unify_resolve_gen flags (c,cl))) + (Proofview.V82.tactic (unify_resolve_gen poly flags (c,cl))) (* With "(debug) trivial", we shouldn't end here, and with "debug auto" we don't display the details of inner trivial *) (trivial_fail_db (no_dbg ()) (not (Option.is_empty flags)) db_list local_db) @@ -1382,7 +1478,7 @@ and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t})) = and trivial_resolve dbg mod_delta db_list local_db cl = try let head = - try let hdconstr,_ = head_constr_bound cl in + try let hdconstr = head_constr_bound cl in Some (head_of_constr_reference hdconstr) with Bound -> None in @@ -1436,7 +1532,7 @@ let h_trivial ?(debug=Off) lems l = gen_trivial ~debug lems l let possible_resolve dbg mod_delta db_list local_db cl = try let head = - try let hdconstr,_ = head_constr_bound cl in + try let hdconstr = head_constr_bound cl in Some (head_of_constr_reference hdconstr) with Bound -> None in @@ -1482,7 +1578,7 @@ let search d n mod_delta db_list local_db = let default_search_depth = ref 5 -let delta_auto ?(debug=Off) mod_delta n lems dbnames = +let delta_auto debug mod_delta n lems dbnames = Proofview.Goal.enter begin fun gl -> let db_list = make_db_list dbnames in let d = mk_auto_dbg debug in @@ -1491,9 +1587,15 @@ let delta_auto ?(debug=Off) mod_delta n lems dbnames = (search d n mod_delta db_list hints) end -let auto ?(debug=Off) n = delta_auto ~debug false n +let delta_auto = + if Flags.profile then + let key = Profile.declare_profile "delta_auto" in + Profile.profile5 key delta_auto + else delta_auto + +let auto ?(debug=Off) n = delta_auto debug false n -let new_auto ?(debug=Off) n = delta_auto ~debug true n +let new_auto ?(debug=Off) n = delta_auto debug true n let default_auto = auto !default_search_depth [] [] diff --git a/tactics/auto.mli b/tactics/auto.mli index 2d2720880..b85f86ea4 100644 --- a/tactics/auto.mli +++ b/tactics/auto.mli @@ -21,16 +21,17 @@ open Vernacexpr open Mod_subst open Misctypes open Pp +open Decl_kinds (** Auto and related automation tactics *) type 'a auto_tactic = - | Res_pf of constr * 'a (** Hint Apply *) - | ERes_pf of constr * 'a (** Hint EApply *) - | Give_exact of constr - | Res_pf_THEN_trivial_fail of constr * 'a (** Hint Immediate *) - | Unfold_nth of evaluable_global_reference (** Hint Unfold *) - | Extern of Tacexpr.glob_tactic_expr (** Hint Extern *) + | Res_pf of 'a (* Hint Apply *) + | ERes_pf of 'a (* Hint EApply *) + | Give_exact of 'a + | Res_pf_THEN_trivial_fail of 'a (* Hint Immediate *) + | Unfold_nth of evaluable_global_reference (* Hint Unfold *) + | Extern of Tacexpr.glob_tactic_expr (* Hint Extern *) type hints_path_atom = | PathHints of global_reference list @@ -38,20 +39,20 @@ type hints_path_atom = type 'a gen_auto_tactic = { pri : int; (** A number between 0 and 4, 4 = lower priority *) + poly : polymorphic; (** Is the hint polymorpic and hence should be refreshed at each application *) pat : constr_pattern option; (** A pattern for the concl of the Goal *) name : hints_path_atom; (** A potential name to refer to the hint *) code : 'a auto_tactic; (** the tactic to apply when the concl matches pat *) } -type pri_auto_tactic = clausenv gen_auto_tactic - -type stored_data = int * clausenv gen_auto_tactic +type pri_auto_tactic = (constr * clausenv) gen_auto_tactic type search_entry (** The head may not be bound. *) -type hint_entry = global_reference option * types gen_auto_tactic +type hint_entry = global_reference option * + (constr * types * Univ.universe_context_set) gen_auto_tactic type hints_path = | PathAtom of hints_path_atom @@ -94,9 +95,16 @@ type hint_db_name = string type hint_db = Hint_db.t +type hnf = bool + +type hint_term = + | IsGlobRef of global_reference + | IsConstr of constr * Univ.universe_context_set + type hints_entry = - | HintsResolveEntry of (int option * bool * hints_path_atom * global_reference_or_constr) list - | HintsImmediateEntry of (hints_path_atom * global_reference_or_constr) list + | HintsResolveEntry of (int option * polymorphic * hnf * hints_path_atom * + hint_term) list + | HintsImmediateEntry of (hints_path_atom * polymorphic * hint_term) list | HintsCutEntry of hints_path | HintsUnfoldEntry of evaluable_global_reference list | HintsTransparencyEntry of evaluable_global_reference list * bool @@ -118,11 +126,12 @@ val remove_hints : bool -> hint_db_name list -> global_reference list -> unit val current_db_names : unit -> String.Set.t -val interp_hints : hints_expr -> hints_entry +val interp_hints : polymorphic -> hints_expr -> hints_entry val add_hints : locality_flag -> hint_db_name list -> hints_entry -> unit -val prepare_hint : env -> open_constr -> constr +val prepare_hint : bool (* Check no remaining evars *) -> env -> evar_map -> + open_constr -> hint_term val pr_searchtable : unit -> std_ppcmds val pr_applicable_hint : unit -> std_ppcmds @@ -134,7 +143,8 @@ val pr_hint_db : Hint_db.t -> std_ppcmds [c] is the term given as an exact proof to solve the goal; [ctyp] is the type of [c]. *) -val make_exact_entry : evar_map -> int option -> ?name:hints_path_atom -> constr * constr -> hint_entry +val make_exact_entry : env -> evar_map -> int option -> polymorphic -> ?name:hints_path_atom -> + (constr * types * Univ.universe_context_set) -> hint_entry (** [make_apply_entry (eapply,hnf,verbose) pri (c,cty)]. [eapply] is true if this hint will be used only with EApply; @@ -144,8 +154,8 @@ val make_exact_entry : evar_map -> int option -> ?name:hints_path_atom -> constr [cty] is the type of [c]. *) val make_apply_entry : - env -> evar_map -> bool * bool * bool -> int option -> ?name:hints_path_atom -> - constr * constr -> hint_entry + env -> evar_map -> bool * bool * bool -> int option -> polymorphic -> ?name:hints_path_atom -> + (constr * types * Univ.universe_context_set) -> hint_entry (** A constr which is Hint'ed will be: - (1) used as an Exact, if it does not start with a product @@ -155,8 +165,8 @@ val make_apply_entry : has missing arguments. *) val make_resolves : - env -> evar_map -> bool * bool * bool -> int option -> ?name:hints_path_atom -> - constr -> hint_entry list + env -> evar_map -> bool * bool * bool -> int option -> polymorphic -> ?name:hints_path_atom -> + hint_term -> hint_entry list (** [make_resolve_hyp hname htyp]. used to add an hypothesis to the local hint database; @@ -194,9 +204,9 @@ val default_search_depth : int ref val auto_unif_flags : Unification.unify_flags (** Try unification with the precompiled clause, then use registered Apply *) -val unify_resolve_nodelta : (constr * clausenv) -> tactic +val unify_resolve_nodelta : polymorphic -> (constr * clausenv) -> tactic -val unify_resolve : Unification.unify_flags -> (constr * clausenv) -> tactic +val unify_resolve : polymorphic -> Unification.unify_flags -> (constr * clausenv) -> tactic (** [ConclPattern concl pat tacast]: if the term concl matches the pattern pat, (in sense of @@ -255,7 +265,7 @@ val full_trivial : ?debug:Tacexpr.debug -> val h_trivial : ?debug:Tacexpr.debug -> open_constr list -> hint_db_name list option -> unit Proofview.tactic -val pr_autotactic : 'a auto_tactic -> Pp.std_ppcmds +val pr_autotactic : (constr * 'a) auto_tactic -> Pp.std_ppcmds (** Hook for changing the initialization of auto *) diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index ba3676145..0809c0500 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -23,6 +23,7 @@ open Locus type rew_rule = { rew_lemma: constr; rew_type: types; rew_pat: constr; + rew_ctx: Univ.universe_context_set; rew_l2r: bool; rew_tac: glob_tactic_expr option } @@ -85,18 +86,26 @@ let print_rewrite_hintdb bas = Pptactic.pr_glob_tactic (Global.env()) tac) (mt ()) h.rew_tac) (find_rewrites bas)) -type raw_rew_rule = Loc.t * constr * bool * raw_tactic_expr option +type raw_rew_rule = Loc.t * constr Univ.in_universe_context_set * bool * raw_tactic_expr option (* Applies all the rules of one base *) let one_base general_rewrite_maybe_in tac_main bas = let lrul = find_rewrites bas in + let try_rewrite dir ctx c tc = Proofview.Goal.enter (fun gl -> + let subst, ctx' = Universes.fresh_universe_context_set_instance ctx in + let c' = Vars.subst_univs_level_constr subst c in + let sigma = Proofview.Goal.sigma gl in + let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx' in + Tacticals.New.tclTHEN (Proofview.V82.tclEVARS sigma) + (general_rewrite_maybe_in dir c' tc) + ) in let lrul = List.map (fun h -> let tac = match h.rew_tac with None -> Proofview.tclUNIT () | Some t -> Tacinterp.eval_tactic t in - (h.rew_lemma,h.rew_l2r,tac)) lrul in - Tacticals.New.tclREPEAT_MAIN (Proofview.tclPROGRESS (List.fold_left (fun tac (csr,dir,tc) -> + (h.rew_ctx,h.rew_lemma,h.rew_l2r,tac)) lrul in + Tacticals.New.tclREPEAT_MAIN (Proofview.tclPROGRESS (List.fold_left (fun tac (ctx,csr,dir,tc) -> Tacticals.New.tclTHEN tac (Tacticals.New.tclREPEAT_MAIN - (Tacticals.New.tclTHENFIRST (general_rewrite_maybe_in dir csr tc) tac_main))) + (Tacticals.New.tclTHENFIRST (try_rewrite dir ctx csr tc) tac_main))) (Proofview.tclUNIT()) lrul)) (* The AutoRewrite tactic *) @@ -284,11 +293,11 @@ let add_rew_rules base lrul = let counter = ref 0 in let lrul = List.fold_left - (fun dn (loc,c,b,t) -> + (fun dn (loc,(c,ctx),b,t) -> let info = find_applied_relation false loc (Global.env ()) Evd.empty c b in let pat = if b then info.hyp_left else info.hyp_right in let rul = { rew_lemma = c; rew_type = info.hyp_ty; - rew_pat = pat; rew_l2r = b; + rew_pat = pat; rew_ctx = ctx; rew_l2r = b; rew_tac = Option.map Tacintern.glob_tactic t} in incr counter; HintDN.add pat (!counter, rul) dn) HintDN.empty lrul diff --git a/tactics/autorewrite.mli b/tactics/autorewrite.mli index 198fa36f5..046291135 100644 --- a/tactics/autorewrite.mli +++ b/tactics/autorewrite.mli @@ -11,7 +11,7 @@ open Tacexpr open Equality (** Rewriting rules before tactic interpretation *) -type raw_rew_rule = Loc.t * Term.constr * bool * Tacexpr.raw_tactic_expr option +type raw_rew_rule = Loc.t * Term.constr Univ.in_universe_context_set * bool * Tacexpr.raw_tactic_expr option (** To add rewriting rules to a base *) val add_rew_rules : string -> raw_rew_rule list -> unit @@ -27,6 +27,7 @@ val autorewrite_in : ?conds:conditions -> Names.Id.t -> unit Proofview.tactic -> type rew_rule = { rew_lemma: constr; rew_type: types; rew_pat: constr; + rew_ctx: Univ.universe_context_set; rew_l2r: bool; rew_tac: glob_tactic_expr option } diff --git a/tactics/btermdn.ml b/tactics/btermdn.ml index 9492ae1a0..df8e98604 100644 --- a/tactics/btermdn.ml +++ b/tactics/btermdn.ml @@ -48,8 +48,8 @@ let decomp = let constr_val_discr t = let c, l = decomp t in match kind_of_term c with - | Ind ind_sp -> Label(GRLabel (IndRef ind_sp),l) - | Construct cstr_sp -> Label(GRLabel (ConstructRef cstr_sp),l) + | Ind (ind_sp,u) -> Label(GRLabel (IndRef ind_sp),l) + | Construct (cstr_sp,u) -> Label(GRLabel (ConstructRef cstr_sp),l) | Var id -> Label(GRLabel (VarRef id),l) | Const _ -> Everything | _ -> Nothing @@ -67,9 +67,9 @@ let constr_pat_discr t = let constr_val_discr_st (idpred,cpred) t = let c, l = decomp t in match kind_of_term c with - | Const c -> if Cpred.mem c cpred then Everything else Label(GRLabel (ConstRef c),l) - | Ind ind_sp -> Label(GRLabel (IndRef ind_sp),l) - | Construct cstr_sp -> Label(GRLabel (ConstructRef cstr_sp),l) + | Const (c,u) -> if Cpred.mem c cpred then Everything else Label(GRLabel (ConstRef c),l) + | Ind (ind_sp,u) -> Label(GRLabel (IndRef ind_sp),l) + | Construct (cstr_sp,u) -> Label(GRLabel (ConstructRef cstr_sp),l) | Var id when not (Id.Pred.mem id idpred) -> Label(GRLabel (VarRef id),l) | Prod (n, d, c) -> Label(ProdLabel, [d; c]) | Lambda (n, d, c) -> Label(LambdaLabel, [d; c] @ l) @@ -141,6 +141,77 @@ struct let create = Dn.create +(* FIXME: MS: remove *) +(* let decomp = + let rec decrec acc c = match kind_of_term c with + | App (f,l) -> decrec (Array.fold_right (fun a l -> a::l) l acc) f + | Proj (p,c) -> decrec (c :: acc) (mkConst p) + | Cast (c1,_,_) -> decrec acc c1 + | _ -> (c,acc) + in + decrec [] + + let constr_val_discr t = + let c, l = decomp t in + match kind_of_term c with + | Ind (ind_sp,_) -> Dn.Label(Term_dn.GRLabel (IndRef ind_sp),l) + | Construct (cstr_sp,_) -> Dn.Label(Term_dn.GRLabel (ConstructRef cstr_sp),l) + | Var id -> Dn.Label(Term_dn.GRLabel (VarRef id),l) + | Const _ -> Dn.Everything + | Proj (p, c) -> Dn.Everything + | _ -> Dn.Nothing + + let constr_val_discr_st (idpred,cpred) t = + let c, l = decomp t in + match kind_of_term c with + | Const (c,_) -> if Cpred.mem c cpred then Dn.Everything else Dn.Label(Term_dn.GRLabel (ConstRef c),l) + | Ind (ind_sp,_) -> Dn.Label(Term_dn.GRLabel (IndRef ind_sp),l) + | Construct (cstr_sp,_) -> Dn.Label(Term_dn.GRLabel (ConstructRef cstr_sp),l) + | Proj (p,c) -> + if Cpred.mem p cpred then Dn.Everything else Dn.Label(Term_dn.GRLabel (ConstRef p), c::l) + | Var id when not (Id.Pred.mem id idpred) -> Dn.Label(Term_dn.GRLabel (VarRef id),l) + | Prod (n, d, c) -> Dn.Label(Term_dn.ProdLabel, [d; c]) + | Lambda (n, d, c) -> Dn.Label(Term_dn.LambdaLabel, [d; c] @ l) + | Sort _ -> Dn.Label(Term_dn.SortLabel, []) + | Evar _ -> Dn.Everything + | _ -> Dn.Nothing + + let bounded_constr_pat_discr_st st (t,depth) = + if Int.equal depth 0 then + None + else + match Term_dn.constr_pat_discr_st st t with + | None -> None + | Some (c,l) -> Some(c,List.map (fun c -> (c,depth-1)) l) + + let bounded_constr_val_discr_st st (t,depth) = + if Int.equal depth 0 then + Dn.Nothing + else + match constr_val_discr_st st t with + | Dn.Label (c,l) -> Dn.Label(c,List.map (fun c -> (c,depth-1)) l) + | Dn.Nothing -> Dn.Nothing + | Dn.Everything -> Dn.Everything + + let bounded_constr_pat_discr (t,depth) = + if Int.equal depth 0 then + None + else + match Term_dn.constr_pat_discr t with + | None -> None + | Some (c,l) -> Some(c,List.map (fun c -> (c,depth-1)) l) + + let bounded_constr_val_discr (t,depth) = + if Int.equal depth 0 then + Dn.Nothing + else + match constr_val_discr t with + | Dn.Label (c,l) -> Dn.Label(c,List.map (fun c -> (c,depth-1)) l) + | Dn.Nothing -> Dn.Nothing + | Dn.Everything -> Dn.Everything + +*) + let add = function | None -> (fun dn (c,v) -> diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index 6d7c797af..02e671a5c 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -50,7 +50,7 @@ let evars_to_goals p evm = open Auto -let e_give_exact flags c gl = +let e_give_exact flags (c,cl) gl = let t1 = (pf_type_of gl c) in tclTHEN (Clenvtac.unify ~flags t1) (exact_no_check c) gl @@ -91,15 +91,17 @@ let progress_evars t = in t <*> check end -let unify_e_resolve flags (c,clenv) gls = - let clenv' = connect_clenv gls clenv in +let unify_e_resolve poly flags (c,clenv) gls = + let clenv' = if poly then fst (Clenv.refresh_undefined_univs clenv) else clenv in + let clenv' = connect_clenv gls clenv' in let clenv' = clenv_unique_resolver ~flags clenv' gls in Clenvtac.clenv_refine true ~with_classes:false clenv' gls -let unify_resolve flags (c,clenv) gls = - let clenv' = connect_clenv gls clenv in +let unify_resolve poly flags (c,clenv) gls = + let clenv' = if poly then fst (Clenv.refresh_undefined_univs clenv) else clenv in + let clenv' = connect_clenv gls clenv' in let clenv' = clenv_unique_resolver ~flags clenv' gls in - Clenvtac.clenv_refine false ~with_classes:false clenv' gls + Clenvtac.clenv_refine false(*uhoh, was true*) ~with_classes:false clenv' gls let clenv_of_prods nprods (c, clenv) gls = if Int.equal nprods 0 then Some clenv @@ -107,6 +109,7 @@ let clenv_of_prods nprods (c, clenv) gls = let ty = pf_type_of gls c in let diff = nb_prod ty - nprods in if Pervasives.(>=) diff 0 then + (* Was Some clenv... *) Some (mk_clenv_from_n gls (Some diff) (c,ty)) else None @@ -152,14 +155,14 @@ and e_my_find_search db_list local_db hdc complete concl = (local_db::db_list) in let tac_of_hint = - fun (flags, {pri = b; pat = p; code = t; name = name}) -> + fun (flags, {pri = b; pat = p; poly = poly; code = t; name = name}) -> let tac = match t with - | Res_pf (term,cl) -> with_prods nprods (term,cl) (unify_resolve flags) - | ERes_pf (term,cl) -> with_prods nprods (term,cl) (unify_e_resolve flags) - | Give_exact (c) -> e_give_exact flags c + | Res_pf (term,cl) -> with_prods nprods (term,cl) (unify_resolve poly flags) + | ERes_pf (term,cl) -> with_prods nprods (term,cl) (unify_e_resolve poly flags) + | Give_exact c -> e_give_exact flags c | Res_pf_THEN_trivial_fail (term,cl) -> - tclTHEN (with_prods nprods (term,cl) (unify_e_resolve flags)) + tclTHEN (with_prods nprods (term,cl) (unify_e_resolve poly flags)) (if complete then tclIDTAC else e_trivial_fail_db db_list local_db) | Unfold_nth c -> tclWEAK_PROGRESS (unfold_in_concl [AllOccurrences,c]) | Extern tacast -> @@ -178,13 +181,13 @@ and e_my_find_search db_list local_db hdc complete concl = and e_trivial_resolve db_list local_db gl = try e_my_find_search db_list local_db - (fst (head_constr_bound gl)) true gl + (head_constr_bound gl) true gl with Bound | Not_found -> [] let e_possible_resolve db_list local_db gl = try e_my_find_search db_list local_db - (fst (head_constr_bound gl)) false gl + (head_constr_bound gl) false gl with Bound | Not_found -> [] let catchable = function @@ -223,8 +226,8 @@ let make_resolve_hyp env sigma st flags only_classes pri (id, _, cty) = let rec iscl env ty = let ctx, ar = decompose_prod_assum ty in match kind_of_term (fst (decompose_app ar)) with - | Const c -> is_class (ConstRef c) - | Ind i -> is_class (IndRef i) + | Const (c,_) -> is_class (ConstRef c) + | Ind (i,_) -> is_class (IndRef i) | _ -> let env' = Environ.push_rel_context ctx env in let ty' = whd_betadeltaiota env' ar in @@ -241,13 +244,16 @@ let make_resolve_hyp env sigma st flags only_classes pri (id, _, cty) = let hints = build_subclasses ~check:false env sigma (VarRef id) None in (List.map_append (fun (path,pri, c) -> make_resolves env sigma ~name:(PathHints path) - (true,false,Flags.is_verbose()) pri c) + (true,false,Flags.is_verbose()) pri false + (IsConstr (c,Univ.ContextSet.empty))) hints) else [] in (hints @ List.map_filter - (fun f -> try Some (f (c, cty)) with Failure _ | UserError _ -> None) - [make_exact_entry ~name sigma pri; make_apply_entry ~name env sigma flags pri]) + (fun f -> try Some (f (c, cty, Univ.ContextSet.empty)) + with Failure _ | UserError _ -> None) + [make_exact_entry ~name env sigma pri false; + make_apply_entry ~name env sigma flags pri false]) else [] let pf_filtered_hyps gls = @@ -266,21 +272,19 @@ let make_hints g st only_classes sign = (PathEmpty, []) sign in Hint_db.add_list hintlist (Hint_db.empty st true) -let autogoal_hints_cache - : (bool * Environ.named_context_val * hint_db) option ref - = Summary.ref None ~name:"autogoal-hints-cache" -let freeze () = !autogoal_hints_cache -let unfreeze v = autogoal_hints_cache := v - let make_autogoal_hints = - fun only_classes ?(st=full_transparent_state) g -> - let sign = pf_filtered_hyps g in - match freeze () with - | Some (onlyc, sign', hints) - when (onlyc : bool) == only_classes && - Environ.eq_named_context_val sign sign' -> hints - | _ -> let hints = make_hints g st only_classes (Environ.named_context_of_val sign) in - unfreeze (Some (only_classes, sign, hints)); hints + let cache = ref (true, Environ.empty_named_context_val, + Hint_db.empty full_transparent_state true) + in + fun only_classes ?(st=full_transparent_state) g -> + let sign = pf_filtered_hyps g in + let (onlyc, sign', cached_hints) = !cache in + if onlyc == only_classes && + (sign == sign' || Environ.eq_named_context_val sign sign') then + cached_hints + else + let hints = make_hints g st only_classes (Environ.named_context_of_val sign) in + cache := (only_classes, sign, hints); hints let lift_tactic tac (f : goal list sigma -> autoinfo -> autogoal list sigma) : 'a tac = { skft = fun sk fk {it = gl,hints; sigma=s;} -> @@ -467,7 +471,8 @@ let run_on_evars ?(only_classes=true) ?(st=full_transparent_state) p evm hints t let res = run_list_tac tac p goals (make_autogoals ~only_classes ~st hints goals evm') in match get_result res with | None -> raise Not_found - | Some (evm', fk) -> Some (evars_reset_evd ~with_conv_pbs:true evm' evm, fk) + | Some (evm', fk) -> + Some (evars_reset_evd ~with_conv_pbs:true ~with_univs:false evm' evm, fk) let eauto_tac hints = then_tac normevars_tac (or_tac (hints_tac hints) intro_tac) @@ -743,4 +748,4 @@ let autoapply c i gl = let flags = flags_of_state (Auto.Hint_db.transparent_state (Auto.searchtable_map i)) in let cty = pf_type_of gl c in let ce = mk_clenv_from gl (c,cty) in - unify_e_resolve flags (c,ce) gl + unify_e_resolve false flags (c,ce) gl diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml index f245247a9..faeb9fc25 100644 --- a/tactics/contradiction.ml +++ b/tactics/contradiction.ml @@ -34,6 +34,7 @@ let absurd c gls = exact_no_check (mkApp(mkVar idna,[|mkVar ida|])) gl))); tclIDTAC])); tclIDTAC])) { gls with Evd.sigma; } + let absurd c = Proofview.V82.tactic (absurd c) (* Contradiction *) diff --git a/tactics/eauto.ml4 b/tactics/eauto.ml4 index 0ab426cd2..328d45991 100644 --- a/tactics/eauto.ml4 +++ b/tactics/eauto.ml4 @@ -32,7 +32,7 @@ let eauto_unif_flags = { auto_unif_flags with Unification.modulo_delta = full_tr let e_give_exact ?(flags=eauto_unif_flags) c gl = let t1 = (pf_type_of gl c) and t2 = pf_concl gl in if occur_existential t1 || occur_existential t2 then - tclTHEN (Clenvtac.unify ~flags t1) (exact_check c) gl + tclTHEN (Clenvtac.unify ~flags t1) (exact_no_check c) gl else exact_check c gl let assumption id = e_give_exact (mkVar id) @@ -86,8 +86,12 @@ let rec prolog l n gl = let prol = (prolog l (n-1)) in (tclFIRST (List.map (fun t -> (tclTHEN t prol)) (one_step l gl))) gl +let out_term = function + | IsConstr (c, _) -> c + | IsGlobRef gr -> fst (Universes.fresh_global_instance (Global.env ()) gr) + let prolog_tac l n gl = - let l = List.map (prepare_hint (pf_env gl)) l in + let l = List.map (fun x -> out_term (pf_apply (prepare_hint false) gl x)) l in let n = match n with | ArgArg n -> n @@ -110,11 +114,19 @@ open Unification let priority l = List.map snd (List.filter (fun (pr,_) -> Int.equal pr 0) l) -let unify_e_resolve flags (c,clenv) gls = - let clenv' = connect_clenv gls clenv in +let unify_e_resolve poly flags (c,clenv) gls = + let clenv', subst = if poly then Clenv.refresh_undefined_univs clenv + else clenv, Univ.empty_level_subst in + let clenv' = connect_clenv gls clenv' in let _ = clenv_unique_resolver ~flags clenv' gls in - Tactics.Simple.eapply c gls - + Tactics.Simple.eapply (Vars.subst_univs_level_constr subst c) gls + +let e_exact poly flags (c,clenv) = + let clenv', subst = + if poly then Clenv.refresh_undefined_univs clenv + else clenv, Univ.empty_level_subst + in e_give_exact ~flags (Vars.subst_univs_level_constr subst c) + let rec e_trivial_fail_db db_list local_db goal = let tacl = registered_e_assumption :: @@ -141,15 +153,15 @@ and e_my_find_search db_list local_db hdc concl = List.map (fun x -> flags, x) (Hint_db.map_auto (hdc,concl) db)) (local_db::db_list) in let tac_of_hint = - fun (st, {pri=b; pat = p; code=t}) -> + fun (st, {pri = b; pat = p; code = t; poly = poly}) -> (b, let tac = match t with - | Res_pf (term,cl) -> unify_resolve st (term,cl) - | ERes_pf (term,cl) -> unify_e_resolve st (term,cl) - | Give_exact (c) -> e_give_exact c + | Res_pf (term,cl) -> unify_resolve poly st (term,cl) + | ERes_pf (term,cl) -> unify_e_resolve poly st (term,cl) + | Give_exact (c,cl) -> e_exact poly st (c,cl) | Res_pf_THEN_trivial_fail (term,cl) -> - tclTHEN (unify_e_resolve st (term,cl)) + tclTHEN (unify_e_resolve poly st (term,cl)) (e_trivial_fail_db db_list local_db) | Unfold_nth c -> reduce (Unfold [AllOccurrences,c]) onConcl | Extern tacast -> Proofview.V82.of_tactic (conclPattern concl p tacast) @@ -162,13 +174,13 @@ and e_trivial_resolve db_list local_db gl = try priority (e_my_find_search db_list local_db - (fst (head_constr_bound gl)) gl) + (head_constr_bound gl) gl) with Bound | Not_found -> [] let e_possible_resolve db_list local_db gl = try List.map snd (e_my_find_search db_list local_db - (fst (head_constr_bound gl)) gl) + (head_constr_bound gl) gl) with Bound | Not_found -> [] let find_first_goal gls = @@ -363,6 +375,9 @@ let e_search_auto debug (in_depth,p) lems db_list gl = pr_info_nop d; error "eauto: search failed" +(* let e_search_auto_key = Profile.declare_profile "e_search_auto" *) +(* let e_search_auto = Profile.profile5 e_search_auto_key e_search_auto *) + let eauto_with_bases ?(debug=Off) np lems db_list = tclTRY (e_search_auto debug np lems db_list) @@ -494,8 +509,8 @@ let unfold_head env (ids, csts) c = (match Environ.named_body id env with | Some b -> true, b | None -> false, c) - | Const cst when Cset.mem cst csts -> - true, Environ.constant_value env cst + | Const (cst,u as c) when Cset.mem cst csts -> + true, Environ.constant_value_in env c | App (f, args) -> (match aux f with | true, f' -> true, Reductionops.whd_betaiota Evd.empty (mkApp (f', args)) @@ -558,7 +573,7 @@ TACTIC EXTEND autounfoldify | [ "autounfoldify" constr(x) ] -> [ Proofview.V82.tactic ( let db = match kind_of_term x with - | Const c -> Label.to_string (con_label c) + | Const (c,_) -> Label.to_string (con_label c) | _ -> assert false in autounfold ["core";db] onConcl )] diff --git a/tactics/elim.ml b/tactics/elim.ml index 0720273bb..2a7b3bff1 100644 --- a/tactics/elim.ml +++ b/tactics/elim.ml @@ -104,12 +104,12 @@ let head_in indl t gl = if !up_to_delta then find_mrectype env sigma t else extract_mrectype t - in List.exists (fun i -> eq_ind i ity) indl + in List.exists (fun i -> eq_ind (fst i) (fst ity)) indl with Not_found -> false let decompose_these c l = Proofview.Goal.raw_enter begin fun gl -> - let indl = (*List.map inductive_of*) l in + let indl = List.map (fun x -> x, Univ.Instance.empty) l in general_decompose (fun (_,t) -> head_in indl t gl) c end diff --git a/tactics/elimschemes.ml b/tactics/elimschemes.ml index 9c020930c..617475bb7 100644 --- a/tactics/elimschemes.ml +++ b/tactics/elimschemes.ml @@ -23,13 +23,16 @@ open Ind_tables (* Induction/recursion schemes *) let optimize_non_type_induction_scheme kind dep sort ind = + let env = Global.env () in + let sigma = Evd.from_env env in if check_scheme kind ind then (* in case the inductive has a type elimination, generates only one induction scheme, the other ones share the same code with the apropriate type *) let cte, eff = find_scheme kind ind in - let c = mkConst cte in - let t = type_of_constant (Global.env()) cte in + let sigma, cte = Evd.fresh_constant_instance env sigma cte in + let c = mkConstU cte in + let t = type_of_constant_in (Global.env()) cte in let (mib,mip) = Global.lookup_inductive ind in let npars = (* if a constructor of [ind] contains a recursive call, the scheme @@ -39,13 +42,29 @@ let optimize_non_type_induction_scheme kind dep sort ind = mib.mind_nparams_rec else mib.mind_nparams in - snd (weaken_sort_scheme (new_sort_in_family sort) npars c t), eff + let sigma, sort = Evd.fresh_sort_in_family env sigma sort in + let sigma, t', c' = weaken_sort_scheme env sigma false sort npars c t in + let sigma, nf = Evarutil.nf_evars_and_universes sigma in + (nf c', Evd.evar_universe_context sigma), eff else - build_induction_scheme (Global.env()) Evd.empty ind dep sort, Declareops.no_seff + let mib,mip = Inductive.lookup_mind_specif env ind in + let ctx = if mib.mind_polymorphic then mib.mind_universes else Univ.UContext.empty in + let u = Univ.UContext.instance ctx in + let ctxset = Univ.ContextSet.of_context ctx in + let sigma, c = build_induction_scheme env (Evd.from_env ~ctx:ctxset env) (ind,u) dep sort in + (c, Evd.evar_universe_context sigma), Declareops.no_seff let build_induction_scheme_in_type dep sort ind = - build_induction_scheme (Global.env()) Evd.empty ind dep sort - + let env = Global.env () in + let ctx = + let mib,mip = Inductive.lookup_mind_specif env ind in + Inductive.inductive_context mib + in + let u = Univ.UContext.instance ctx in + let ctxset = Univ.ContextSet.of_context ctx in + let sigma, c = build_induction_scheme env (Evd.from_env ~ctx:ctxset env) (ind,u) dep sort in + c, Evd.evar_universe_context sigma + let rect_scheme_kind_from_type = declare_individual_scheme_object "_rect_nodep" (fun x -> build_induction_scheme_in_type false InType x, Declareops.no_seff) @@ -81,7 +100,11 @@ let rec_dep_scheme_kind_from_type = (* Case analysis *) let build_case_analysis_scheme_in_type dep sort ind = - build_case_analysis_scheme (Global.env()) Evd.empty ind dep sort + let env = Global.env () in + let sigma = Evd.from_env env in + let sigma, indu = Evd.fresh_inductive_instance env sigma ind in + let sigma, c = build_case_analysis_scheme env sigma indu dep sort in + c, Evd.evar_universe_context sigma let case_scheme_kind_from_type = declare_individual_scheme_object "_case_nodep" diff --git a/tactics/eqdecide.ml b/tactics/eqdecide.ml index 23c4c0b2d..7909b669b 100644 --- a/tactics/eqdecide.ml +++ b/tactics/eqdecide.ml @@ -80,8 +80,13 @@ let solveNoteqBranch side = (* Constructs the type {c1=c2}+{~c1=c2} *) +let make_eq () = +(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq ()) +let make_eq_refl () = +(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq_refl ()) + let mkDecideEqGoal eqonleft op rectype c1 c2 = - let equality = mkApp(build_coq_eq(), [|rectype; c1; c2|]) in + let equality = mkApp(make_eq(), [|rectype; c1; c2|]) in let disequality = mkApp(build_coq_not (), [|equality|]) in if eqonleft then mkApp(op, [|equality; disequality |]) else mkApp(op, [|disequality; equality |]) @@ -173,7 +178,7 @@ let decideGralEquality = match_eqdec concl >>= fun (eqonleft,_,c1,c2,typ) -> let headtyp = hd_app (pf_compute gl typ) in begin match kind_of_term headtyp with - | Ind mi -> Proofview.tclUNIT mi + | Ind (mi,_) -> Proofview.tclUNIT mi | _ -> tclZEROMSG (Pp.str"This decision procedure only works for inductive objects.") end >>= fun rectype -> (tclTHEN diff --git a/tactics/eqschemes.ml b/tactics/eqschemes.ml index 7aac37d1b..08c887b77 100644 --- a/tactics/eqschemes.ml +++ b/tactics/eqschemes.ml @@ -63,11 +63,13 @@ let hid = Id.of_string "H" let xid = Id.of_string "X" let default_id_of_sort = function InProp | InSet -> hid | InType -> xid let fresh env id = next_global_ident_away id [] +let with_context_set ctx (b, ctx') = + (b, Univ.ContextSet.union ctx ctx') let build_dependent_inductive ind (mib,mip) = let realargs,_ = List.chop mip.mind_nrealargs_ctxt mip.mind_arity_ctxt in applist - (mkInd ind, + (mkIndU ind, extended_rel_list mip.mind_nrealargs_ctxt mib.mind_params_ctxt @ extended_rel_list 0 realargs) @@ -76,12 +78,13 @@ let my_it_mkProd_or_LetIn s c = it_mkProd_or_LetIn c s let my_it_mkLambda_or_LetIn_name s c = it_mkLambda_or_LetIn_name (Global.env()) c s -let get_coq_eq () = +let get_coq_eq ctx = try let eq = Globnames.destIndRef Coqlib.glob_eq in - let _ = Global.lookup_inductive eq in (* Do not force the lazy if they are not defined *) - mkInd eq, Coqlib.build_coq_eq_refl () + let eq, ctx = with_context_set ctx + (Universes.fresh_inductive_instance (Global.env ()) eq) in + mkIndU eq, mkConstructUi (eq,1), ctx with Not_found -> error "eq not found." @@ -94,12 +97,14 @@ let get_coq_eq () = (* in which case, a symmetry lemma is definable *) (**********************************************************************) -let get_sym_eq_data env ind = +let get_sym_eq_data env (ind,u) = let (mib,mip as specif) = lookup_mind_specif env ind in if not (Int.equal (Array.length mib.mind_packets) 1) || not (Int.equal (Array.length mip.mind_nf_lc) 1) then error "Not an inductive type with a single constructor."; - let realsign,_ = List.chop mip.mind_nrealargs_ctxt mip.mind_arity_ctxt in + let subst = Inductive.make_inductive_subst mib u in + let arityctxt = Vars.subst_univs_context subst mip.mind_arity_ctxt in + let realsign,_ = List.chop mip.mind_nrealargs_ctxt arityctxt in if List.exists (fun (_,b,_) -> not (Option.is_empty b)) realsign then error "Inductive equalities with local definitions in arity not supported."; let constrsign,ccl = decompose_prod_assum mip.mind_nf_lc.(0) in @@ -110,12 +115,13 @@ let get_sym_eq_data env ind = if mip.mind_nrealargs > mib.mind_nparams then error "Constructors arguments must repeat the parameters."; let _,params2 = List.chop (mib.mind_nparams-mip.mind_nrealargs) params in + let paramsctxt = Vars.subst_univs_context subst mib.mind_params_ctxt in let paramsctxt1,_ = - List.chop (mib.mind_nparams-mip.mind_nrealargs) mib.mind_params_ctxt in + List.chop (mib.mind_nparams-mip.mind_nrealargs) paramsctxt in if not (List.equal eq_constr params2 constrargs) then error "Constructors arguments must repeat the parameters."; (* nrealargs_ctxt and nrealargs are the same here *) - (specif,mip.mind_nrealargs,realsign,mib.mind_params_ctxt,paramsctxt1) + (specif,mip.mind_nrealargs,realsign,paramsctxt,paramsctxt1) (**********************************************************************) (* Check if an inductive type [ind] has the form *) @@ -127,12 +133,14 @@ let get_sym_eq_data env ind = (* such that symmetry is a priori definable *) (**********************************************************************) -let get_non_sym_eq_data env ind = +let get_non_sym_eq_data env (ind,u) = let (mib,mip as specif) = lookup_mind_specif env ind in if not (Int.equal (Array.length mib.mind_packets) 1) || not (Int.equal (Array.length mip.mind_nf_lc) 1) then error "Not an inductive type with a single constructor."; - let realsign,_ = List.chop mip.mind_nrealargs_ctxt mip.mind_arity_ctxt in + let subst = Inductive.make_inductive_subst mib u in + let arityctxt = Vars.subst_univs_context subst mip.mind_arity_ctxt in + let realsign,_ = List.chop mip.mind_nrealargs_ctxt arityctxt in if List.exists (fun (_,b,_) -> not (Option.is_empty b)) realsign then error "Inductive equalities with local definitions in arity not supported"; let constrsign,ccl = decompose_prod_assum mip.mind_nf_lc.(0) in @@ -140,7 +148,9 @@ let get_non_sym_eq_data env ind = if not (Int.equal (rel_context_length constrsign) (rel_context_length mib.mind_params_ctxt)) then error "Constructor must have no arguments"; let _,constrargs = List.chop mib.mind_nparams constrargs in - (specif,constrargs,realsign,mip.mind_nrealargs) + let constrargs = List.map (Vars.subst_univs_constr subst) constrargs in + let paramsctxt = Vars.subst_univs_context subst mib.mind_params_ctxt in + (specif,constrargs,realsign,paramsctxt,mip.mind_nrealargs) (**********************************************************************) (* Build the symmetry lemma associated to an inductive type *) @@ -157,30 +167,35 @@ let get_non_sym_eq_data env ind = (**********************************************************************) let build_sym_scheme env ind = + let (ind,u as indu), ctx = Universes.fresh_inductive_instance env ind in let (mib,mip as specif),nrealargs,realsign,paramsctxt,paramsctxt1 = - get_sym_eq_data env ind in + get_sym_eq_data env indu in let cstr n = - mkApp (mkConstruct(ind,1),extended_rel_vect n mib.mind_params_ctxt) in + mkApp (mkConstructUi(indu,1),extended_rel_vect n mib.mind_params_ctxt) in let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in - let applied_ind = build_dependent_inductive ind specif in + let applied_ind = build_dependent_inductive indu specif in let realsign_ind = name_context env ((Name varH,None,applied_ind)::realsign) in let ci = make_case_info (Global.env()) ind RegularStyle in + let c = (my_it_mkLambda_or_LetIn mib.mind_params_ctxt (my_it_mkLambda_or_LetIn_name realsign_ind (mkCase (ci, my_it_mkLambda_or_LetIn_name (lift_rel_context (nrealargs+1) realsign_ind) - (mkApp (mkInd ind,Array.concat + (mkApp (mkIndU indu,Array.concat [extended_rel_vect (3*nrealargs+2) paramsctxt1; rel_vect 1 nrealargs; rel_vect (2*nrealargs+2) nrealargs])), mkRel 1 (* varH *), [|cstr (nrealargs+1)|])))) + in c, Evd.evar_universe_context_of ctx let sym_scheme_kind = declare_individual_scheme_object "_sym_internal" - (fun ind -> build_sym_scheme (Global.env() (* side-effect! *)) ind, Declareops.no_seff) + (fun ind -> + let c, ctx = build_sym_scheme (Global.env() (* side-effect! *)) ind in + (c, ctx), Declareops.no_seff) (**********************************************************************) (* Build the involutivity of symmetry for an inductive type *) @@ -198,51 +213,59 @@ let sym_scheme_kind = (* *) (**********************************************************************) +let const_of_scheme kind env ind ctx = + let sym_scheme, eff = (find_scheme kind ind) in + let sym, ctx = with_context_set ctx + (Universes.fresh_constant_instance (Global.env()) sym_scheme) in + mkConstU sym, ctx, eff + let build_sym_involutive_scheme env ind = + let (ind,u as indu), ctx = Universes.fresh_inductive_instance env ind in let (mib,mip as specif),nrealargs,realsign,paramsctxt,paramsctxt1 = - get_sym_eq_data env ind in - let c, eff = find_scheme sym_scheme_kind ind in - let sym = mkConst c in - let (eq,eqrefl) = get_coq_eq () in - let cstr n = mkApp (mkConstruct(ind,1),extended_rel_vect n paramsctxt) in + get_sym_eq_data env indu in + let eq,eqrefl,ctx = get_coq_eq ctx in + let sym, ctx, eff = const_of_scheme sym_scheme_kind env ind ctx in + let cstr n = mkApp (mkConstructUi (indu,1),extended_rel_vect n paramsctxt) in let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in - let applied_ind = build_dependent_inductive ind specif in + let applied_ind = build_dependent_inductive indu specif in let applied_ind_C = mkApp - (mkInd ind, Array.append + (mkIndU indu, Array.append (extended_rel_vect (nrealargs+1) mib.mind_params_ctxt) (rel_vect (nrealargs+1) nrealargs)) in let realsign_ind = name_context env ((Name varH,None,applied_ind)::realsign) in let ci = make_case_info (Global.env()) ind RegularStyle in - (my_it_mkLambda_or_LetIn paramsctxt - (my_it_mkLambda_or_LetIn_name realsign_ind - (mkCase (ci, - my_it_mkLambda_or_LetIn_name - (lift_rel_context (nrealargs+1) realsign_ind) - (mkApp (eq,[| - mkApp - (mkInd ind, Array.concat - [extended_rel_vect (3*nrealargs+2) paramsctxt1; - rel_vect (2*nrealargs+2) nrealargs; - rel_vect 1 nrealargs]); - mkApp (sym,Array.concat - [extended_rel_vect (3*nrealargs+2) paramsctxt1; - rel_vect 1 nrealargs; - rel_vect (2*nrealargs+2) nrealargs; - [|mkApp (sym,Array.concat - [extended_rel_vect (3*nrealargs+2) paramsctxt1; - rel_vect (2*nrealargs+2) nrealargs; - rel_vect 1 nrealargs; - [|mkRel 1|]])|]]); - mkRel 1|])), - mkRel 1 (* varH *), - [|mkApp(eqrefl,[|applied_ind_C;cstr (nrealargs+1)|])|])))), - eff + let c = + (my_it_mkLambda_or_LetIn paramsctxt + (my_it_mkLambda_or_LetIn_name realsign_ind + (mkCase (ci, + my_it_mkLambda_or_LetIn_name + (lift_rel_context (nrealargs+1) realsign_ind) + (mkApp (eq,[| + mkApp + (mkIndU indu, Array.concat + [extended_rel_vect (3*nrealargs+2) paramsctxt1; + rel_vect (2*nrealargs+2) nrealargs; + rel_vect 1 nrealargs]); + mkApp (sym,Array.concat + [extended_rel_vect (3*nrealargs+2) paramsctxt1; + rel_vect 1 nrealargs; + rel_vect (2*nrealargs+2) nrealargs; + [|mkApp (sym,Array.concat + [extended_rel_vect (3*nrealargs+2) paramsctxt1; + rel_vect (2*nrealargs+2) nrealargs; + rel_vect 1 nrealargs; + [|mkRel 1|]])|]]); + mkRel 1|])), + mkRel 1 (* varH *), + [|mkApp(eqrefl,[|applied_ind_C;cstr (nrealargs+1)|])|])))) + in (c, Evd.evar_universe_context_of ctx), eff let sym_involutive_scheme_kind = declare_individual_scheme_object "_sym_involutive" - (fun ind -> build_sym_involutive_scheme (Global.env() (* side-effect! *)) ind) + (fun ind -> + build_sym_involutive_scheme (Global.env() (* side-effect! *)) ind) (**********************************************************************) (* Build the left-to-right rewriting lemma for conclusion associated *) @@ -305,28 +328,27 @@ let sym_involutive_scheme_kind = (**********************************************************************) let build_l2r_rew_scheme dep env ind kind = + let (ind,u as indu), ctx = Universes.fresh_inductive_instance env ind in let (mib,mip as specif),nrealargs,realsign,paramsctxt,paramsctxt1 = - get_sym_eq_data env ind in - let c, eff = find_scheme sym_scheme_kind ind in - let sym = mkConst c in - let c, eff' = find_scheme sym_involutive_scheme_kind ind in - let sym_involutive = mkConst c in - let (eq,eqrefl) = get_coq_eq () in + get_sym_eq_data env indu in + let sym, ctx, eff = const_of_scheme sym_scheme_kind env ind ctx in + let sym_involutive, ctx, eff' = const_of_scheme sym_involutive_scheme_kind env ind ctx in + let eq,eqrefl,ctx = get_coq_eq ctx in let cstr n p = - mkApp (mkConstruct(ind,1), + mkApp (mkConstructUi(indu,1), Array.concat [extended_rel_vect n paramsctxt1; rel_vect p nrealargs]) in let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in let varHC = fresh env (Id.of_string "HC") in let varP = fresh env (Id.of_string "P") in - let applied_ind = build_dependent_inductive ind specif in + let applied_ind = build_dependent_inductive indu specif in let applied_ind_P = - mkApp (mkInd ind, Array.concat + mkApp (mkIndU indu, Array.concat [extended_rel_vect (3*nrealargs) paramsctxt1; rel_vect 0 nrealargs; rel_vect nrealargs nrealargs]) in let applied_ind_G = - mkApp (mkInd ind, Array.concat + mkApp (mkIndU indu, Array.concat [extended_rel_vect (3*nrealargs+3) paramsctxt1; rel_vect (nrealargs+3) nrealargs; rel_vect 0 nrealargs]) in @@ -345,9 +367,11 @@ let build_l2r_rew_scheme dep env ind kind = rel_vect (nrealargs+4) nrealargs; rel_vect 1 nrealargs; [|mkRel 1|]]) in - let s = mkSort (new_sort_in_family kind) in + let s, ctx' = Universes.fresh_sort_in_family (Global.env ()) kind in + let ctx = Univ.ContextSet.union ctx ctx' in + let s = mkSort s in let ci = make_case_info (Global.env()) ind RegularStyle in - let cieq = make_case_info (Global.env()) (destInd eq) RegularStyle in + let cieq = make_case_info (Global.env()) (fst (destInd eq)) RegularStyle in let applied_PC = mkApp (mkVar varP,Array.append (extended_rel_vect 1 realsign) (if dep then [|cstr (2*nrealargs+1) 1|] else [||])) in @@ -372,6 +396,7 @@ let build_l2r_rew_scheme dep env ind kind = my_it_mkLambda_or_LetIn_name realsign_ind_G applied_PG, applied_sym_C 3, [|mkVar varHC|]) in + let c = (my_it_mkLambda_or_LetIn mib.mind_params_ctxt (my_it_mkLambda_or_LetIn_name realsign (mkNamedLambda varP @@ -388,8 +413,8 @@ let build_l2r_rew_scheme dep env ind kind = Array.append (extended_rel_vect 3 mip.mind_arity_ctxt) [|mkVar varH|]), [|main_body|]) else - main_body)))))), - Declareops.union_side_effects eff' eff + main_body)))))) + in (c, Evd.evar_universe_context_of ctx), Declareops.union_side_effects eff' eff (**********************************************************************) (* Build the left-to-right rewriting lemma for hypotheses associated *) @@ -418,23 +443,24 @@ let build_l2r_rew_scheme dep env ind kind = (**********************************************************************) let build_l2r_forward_rew_scheme dep env ind kind = + let (ind,u as indu), ctx = Universes.fresh_inductive_instance env ind in let (mib,mip as specif),nrealargs,realsign,paramsctxt,paramsctxt1 = - get_sym_eq_data env ind in + get_sym_eq_data env indu in let cstr n p = - mkApp (mkConstruct(ind,1), + mkApp (mkConstructUi(indu,1), Array.concat [extended_rel_vect n paramsctxt1; rel_vect p nrealargs]) in let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in let varHC = fresh env (Id.of_string "HC") in let varP = fresh env (Id.of_string "P") in - let applied_ind = build_dependent_inductive ind specif in + let applied_ind = build_dependent_inductive indu specif in let applied_ind_P = - mkApp (mkInd ind, Array.concat + mkApp (mkIndU indu, Array.concat [extended_rel_vect (4*nrealargs+2) paramsctxt1; rel_vect 0 nrealargs; rel_vect (nrealargs+1) nrealargs]) in let applied_ind_P' = - mkApp (mkInd ind, Array.concat + mkApp (mkIndU indu, Array.concat [extended_rel_vect (3*nrealargs+1) paramsctxt1; rel_vect 0 nrealargs; rel_vect (2*nrealargs+1) nrealargs]) in @@ -443,7 +469,9 @@ let build_l2r_forward_rew_scheme dep env ind kind = name_context env ((Name varH,None,applied_ind)::realsign) in let realsign_ind_P n aP = name_context env ((Name varH,None,aP)::realsign_P n) in - let s = mkSort (new_sort_in_family kind) in + let s, ctx' = Universes.fresh_sort_in_family (Global.env ()) kind in + let ctx = Univ.ContextSet.union ctx ctx' in + let s = mkSort s in let ci = make_case_info (Global.env()) ind RegularStyle in let applied_PC = mkApp (mkVar varP,Array.append @@ -457,6 +485,7 @@ let build_l2r_forward_rew_scheme dep env ind kind = let applied_PG = mkApp (mkVar varP,Array.append (rel_vect 3 nrealargs) (if dep then [|cstr (3*nrealargs+4) 3|] else [||])) in + let c = (my_it_mkLambda_or_LetIn mib.mind_params_ctxt (my_it_mkLambda_or_LetIn_name realsign (mkNamedLambda varH applied_ind @@ -473,6 +502,7 @@ let build_l2r_forward_rew_scheme dep env ind kind = (if dep then realsign_ind_P 1 applied_ind_P' else realsign_P 2) s) (mkNamedLambda varHC applied_PC' (mkVar varHC))|]))))) + in c, Evd.evar_universe_context_of ctx (**********************************************************************) (* Build the right-to-left rewriting lemma for hypotheses associated *) @@ -504,19 +534,22 @@ let build_l2r_forward_rew_scheme dep env ind kind = (* statement but no need for symmetry of the equality. *) (**********************************************************************) -let build_r2l_forward_rew_scheme dep env ind kind = - let ((mib,mip as specif),constrargs,realsign,nrealargs) = - get_non_sym_eq_data env ind in +let build_r2l_forward_rew_scheme dep env ind kind = + let (ind,u as indu), ctx = Universes.fresh_inductive_instance env ind in + let ((mib,mip as specif),constrargs,realsign,paramsctxt,nrealargs) = + get_non_sym_eq_data env indu in let cstr n = - mkApp (mkConstruct(ind,1),extended_rel_vect n mib.mind_params_ctxt) in + mkApp (mkConstructUi(indu,1),extended_rel_vect n mib.mind_params_ctxt) in let constrargs_cstr = constrargs@[cstr 0] in let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in let varHC = fresh env (Id.of_string "HC") in let varP = fresh env (Id.of_string "P") in - let applied_ind = build_dependent_inductive ind specif in + let applied_ind = build_dependent_inductive indu specif in let realsign_ind = name_context env ((Name varH,None,applied_ind)::realsign) in - let s = mkSort (new_sort_in_family kind) in + let s, ctx' = Universes.fresh_sort_in_family (Global.env ()) kind in + let ctx = Univ.ContextSet.union ctx ctx' in + let s = mkSort s in let ci = make_case_info (Global.env()) ind RegularStyle in let applied_PC = applist (mkVar varP,if dep then constrargs_cstr else constrargs) in @@ -524,7 +557,8 @@ let build_r2l_forward_rew_scheme dep env ind kind = mkApp (mkVar varP, if dep then extended_rel_vect 0 realsign_ind else extended_rel_vect 1 realsign) in - (my_it_mkLambda_or_LetIn mib.mind_params_ctxt + let c = + (my_it_mkLambda_or_LetIn paramsctxt (my_it_mkLambda_or_LetIn_name realsign_ind (mkNamedLambda varP (my_it_mkProd_or_LetIn (lift_rel_context (nrealargs+1) @@ -541,6 +575,7 @@ let build_r2l_forward_rew_scheme dep env ind kind = lift (nrealargs+3) applied_PC, mkRel 1)|]), [|mkVar varHC|])))))) + in c, Evd.evar_universe_context_of ctx (**********************************************************************) (* This function "repairs" the non-dependent r2l forward rewriting *) @@ -558,11 +593,12 @@ let build_r2l_forward_rew_scheme dep env ind kind = (* *) (**********************************************************************) -let fix_r2l_forward_rew_scheme c = +let fix_r2l_forward_rew_scheme (c, ctx') = let t = Retyping.get_type_of (Global.env()) Evd.empty c in let ctx,_ = decompose_prod_assum t in match ctx with | hp :: p :: ind :: indargs -> + let c' = my_it_mkLambda_or_LetIn indargs (mkLambda_or_LetIn (map_rel_declaration (liftn (-1) 1) p) (mkLambda_or_LetIn (map_rel_declaration (liftn (-1) 2) hp) @@ -570,6 +606,7 @@ let fix_r2l_forward_rew_scheme c = (Reductionops.whd_beta Evd.empty (applist (c, extended_rel_list 3 indargs @ [mkRel 1;mkRel 3;mkRel 2])))))) + in c', ctx' | _ -> anomaly (Pp.str "Ill-formed non-dependent left-to-right rewriting scheme") (**********************************************************************) @@ -592,9 +629,16 @@ let fix_r2l_forward_rew_scheme c = (* (H:I q1..qm a1..an), *) (* P b1..bn C -> P a1..an H *) (**********************************************************************) - + let build_r2l_rew_scheme dep env ind k = - build_case_analysis_scheme env Evd.empty ind dep k + let sigma, indu = Evd.fresh_inductive_instance env (Evd.from_env env) ind in + let sigma', c = build_case_analysis_scheme env sigma indu dep k in + c, Evd.evar_universe_context sigma' + +let build_l2r_rew_scheme = build_l2r_rew_scheme +let build_l2r_forward_rew_scheme = build_l2r_forward_rew_scheme +let build_r2l_rew_scheme = build_r2l_rew_scheme +let build_r2l_forward_rew_scheme = build_r2l_forward_rew_scheme (**********************************************************************) (* Register the rewriting schemes *) @@ -681,17 +725,22 @@ let rew_r2l_scheme_kind = (* TODO: extend it to types with more than one index *) -let build_congr env (eq,refl) ind = +let build_congr env (eq,refl,ctx) ind = + let (ind,u as indu), ctx = with_context_set ctx + (Universes.fresh_inductive_instance env ind) in let (mib,mip) = lookup_mind_specif env ind in + let subst = Inductive.make_inductive_subst mib u in if not (Int.equal (Array.length mib.mind_packets) 1) || not (Int.equal (Array.length mip.mind_nf_lc) 1) then error "Not an inductive type with a single constructor."; if not (Int.equal mip.mind_nrealargs 1) then error "Expect an inductive type with one predicate parameter."; let i = 1 in - let realsign,_ = List.chop mip.mind_nrealargs_ctxt mip.mind_arity_ctxt in + let arityctxt = Vars.subst_univs_context subst mip.mind_arity_ctxt in + let paramsctxt = Vars.subst_univs_context subst mib.mind_params_ctxt in + let realsign,_ = List.chop mip.mind_nrealargs_ctxt arityctxt in if List.exists (fun (_,b,_) -> not (Option.is_empty b)) realsign then error "Inductive equalities with local definitions in arity not supported."; - let env_with_arity = push_rel_context mip.mind_arity_ctxt env in + let env_with_arity = push_rel_context arityctxt env in let (_,_,ty) = lookup_rel (mip.mind_nrealargs - i + 1) env_with_arity in let constrsign,ccl = decompose_prod_assum mip.mind_nf_lc.(0) in let _,constrargs = decompose_app ccl in @@ -702,14 +751,16 @@ let build_congr env (eq,refl) ind = let varH = fresh env (Id.of_string "H") in let varf = fresh env (Id.of_string "f") in let ci = make_case_info (Global.env()) ind RegularStyle in - my_it_mkLambda_or_LetIn mib.mind_params_ctxt - (mkNamedLambda varB (new_Type ()) + let uni, ctx = Universes.extend_context (Universes.new_global_univ ()) ctx in + let c = + my_it_mkLambda_or_LetIn paramsctxt + (mkNamedLambda varB (mkSort (Type uni)) (mkNamedLambda varf (mkArrow (lift 1 ty) (mkVar varB)) (my_it_mkLambda_or_LetIn_name (lift_rel_context 2 realsign) (mkNamedLambda varH (applist - (mkInd ind, - extended_rel_list (mip.mind_nrealargs+2) mib.mind_params_ctxt @ + (mkIndU indu, + extended_rel_list (mip.mind_nrealargs+2) paramsctxt @ extended_rel_list 0 realsign)) (mkCase (ci, my_it_mkLambda_or_LetIn_name @@ -717,9 +768,9 @@ let build_congr env (eq,refl) ind = (mkLambda (Anonymous, applist - (mkInd ind, + (mkIndU indu, extended_rel_list (2*mip.mind_nrealargs_ctxt+3) - mib.mind_params_ctxt + paramsctxt @ extended_rel_list 0 realsign), mkApp (eq, [|mkVar varB; @@ -729,8 +780,9 @@ let build_congr env (eq,refl) ind = [|mkApp (refl, [|mkVar varB; mkApp (mkVar varf, [|lift (mip.mind_nrealargs+3) b|])|])|])))))) + in c, Evd.evar_universe_context_of ctx let congr_scheme_kind = declare_individual_scheme_object "_congr" (fun ind -> (* May fail if equality is not defined *) - build_congr (Global.env()) (get_coq_eq ()) ind, Declareops.no_seff) + build_congr (Global.env()) (get_coq_eq Univ.ContextSet.empty) ind, Declareops.no_seff) diff --git a/tactics/eqschemes.mli b/tactics/eqschemes.mli index 72412d12d..f18991d72 100644 --- a/tactics/eqschemes.mli +++ b/tactics/eqschemes.mli @@ -22,24 +22,26 @@ val rew_l2r_forward_dep_scheme_kind : individual scheme_kind val rew_r2l_dep_scheme_kind : individual scheme_kind val rew_r2l_scheme_kind : individual scheme_kind -val build_r2l_rew_scheme : bool -> env -> inductive -> sorts_family -> constr -val build_l2r_rew_scheme : - bool -> env -> inductive -> sorts_family -> constr * Declareops.side_effects +val build_r2l_rew_scheme : bool -> env -> inductive -> sorts_family -> + constr Evd.in_evar_universe_context +val build_l2r_rew_scheme : bool -> env -> inductive -> sorts_family -> + constr Evd.in_evar_universe_context * Declareops.side_effects val build_r2l_forward_rew_scheme : - bool -> env -> inductive -> sorts_family -> constr + bool -> env -> inductive -> sorts_family -> constr Evd.in_evar_universe_context val build_l2r_forward_rew_scheme : - bool -> env -> inductive -> sorts_family -> constr + bool -> env -> inductive -> sorts_family -> constr Evd.in_evar_universe_context (** Builds a symmetry scheme for a symmetrical equality type *) -val build_sym_scheme : env -> inductive -> constr +val build_sym_scheme : env -> inductive -> constr Evd.in_evar_universe_context val sym_scheme_kind : individual scheme_kind -val build_sym_involutive_scheme : - env -> inductive -> constr * Declareops.side_effects +val build_sym_involutive_scheme : env -> inductive -> + constr Evd.in_evar_universe_context * Declareops.side_effects val sym_involutive_scheme_kind : individual scheme_kind (** Builds a congruence scheme for an equality type *) val congr_scheme_kind : individual scheme_kind -val build_congr : env -> constr * constr -> inductive -> constr +val build_congr : env -> constr * constr * Univ.universe_context_set -> inductive -> + constr Evd.in_evar_universe_context diff --git a/tactics/equality.ml b/tactics/equality.ml index b062da23e..57931f600 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -1,4 +1,4 @@ -(************************************************************************) +1(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) @@ -280,33 +280,32 @@ let jmeq_same_dom gl = function let find_elim hdcncl lft2rgt dep cls ot gl = let inccl = Option.is_empty cls in - let hdcncl_is u = eq_constr hdcncl (constr_of_reference u) in - if (hdcncl_is (Coqlib.glob_eq) || - hdcncl_is (Coqlib.glob_jmeq) && jmeq_same_dom gl ot) - && not dep - || Flags.version_less_or_equal Flags.V8_2 + if (is_global Coqlib.glob_eq hdcncl || + (is_global Coqlib.glob_jmeq hdcncl && + jmeq_same_dom gl ot)) && not dep + || Flags.version_less_or_equal Flags.V8_2 then match kind_of_term hdcncl with - | Ind ind_sp -> + | Ind (ind_sp,u) -> let pr1 = lookup_eliminator ind_sp (elimination_sort_of_clause cls gl) in begin match lft2rgt, cls with | Some true, None | Some false, Some _ -> - let c1 = destConst pr1 in + let c1 = destConstRef pr1 in let mp,dp,l = repr_con (constant_of_kn (canonical_con c1)) in let l' = Label.of_id (add_suffix (Label.to_id l) "_r") in let c1' = Global.constant_of_delta_kn (make_kn mp dp l') in begin try let _ = Global.lookup_constant c1' in - mkConst c1', Declareops.no_seff + c1', Declareops.no_seff with Not_found -> let rwr_thm = Label.to_string l' in error ("Cannot find rewrite principle "^rwr_thm^".") end - | _ -> pr1, Declareops.no_seff + | _ -> destConstRef pr1, Declareops.no_seff end | _ -> (* cannot occur since we checked that we are in presence of @@ -326,9 +325,9 @@ let find_elim hdcncl lft2rgt dep cls ot gl = | true, _, false -> rew_r2l_forward_dep_scheme_kind in match kind_of_term hdcncl with - | Ind ind -> + | Ind (ind,u) -> let c, eff = find_scheme scheme_name ind in - mkConst c , eff + c , eff | _ -> assert false let type_of_clause cls gl = match cls with @@ -342,10 +341,13 @@ let leibniz_rewrite_ebindings_clause cls lft2rgt tac c t l with_evars frzevars d let type_of_cls = type_of_clause cls gl in let dep = dep_proof_ok && dep_fun c type_of_cls in let (elim,effs) = find_elim hdcncl lft2rgt dep cls (Some t) gl in + let tac elim = + general_elim_clause with_evars frzevars tac cls c t l + (match lft2rgt with None -> false | Some b -> b) + {elimindex = None; elimbody = (elim,NoBindings)} + in Proofview.tclEFFECTS effs <*> - general_elim_clause with_evars frzevars tac cls c t l - (match lft2rgt with None -> false | Some b -> b) - {elimindex = None; elimbody = (elim,NoBindings)} + pf_constr_of_global (ConstRef elim) tac end let adjust_rewriting_direction args lft2rgt = @@ -534,26 +536,34 @@ let multi_replace clause c2 c1 unsafe try_prove_eq_opt = let get_type_of = pf_apply get_type_of gl in let t1 = get_type_of c1 and t2 = get_type_of c2 in - let is_conv = pf_apply is_conv gl in - if unsafe || (is_conv t1 t2) then + let evd = + if unsafe then Some (Proofview.Goal.sigma gl) + else + try Some (Evarconv.the_conv_x (Proofview.Goal.env gl) t1 t2 (Proofview.Goal.sigma gl)) + with Evarconv.UnableToUnify _ -> None + in + match evd with + | None -> + tclFAIL 0 (str"Terms do not have convertible types.") + | Some evd -> let e = build_coq_eq () in let sym = build_coq_eq_sym () in + Tacticals.New.pf_constr_of_global e (fun e -> let eq = applist (e, [t1;c1;c2]) in if check_setoid clause then init_setoid (); - tclTHENS (assert_as false None eq) - [onLastHypId (fun id -> - tclTHEN - (tclTRY (general_multi_rewrite false false (mkVar id,NoBindings) clause)) - (clear [id])); - tclFIRST - [assumption; - tclTHEN (Proofview.V82.tactic (apply sym)) assumption; - try_prove_eq - ] - ] - else - tclFAIL 0 (str"Terms do not have convertible types.") + Tacticals.New.pf_constr_of_global sym (fun sym -> + tclTHENS (assert_as false None eq) + [onLastHypId (fun id -> + tclTHEN + (tclTRY (general_multi_rewrite false false (mkVar id,NoBindings) clause)) + (clear [id])); + tclFIRST + [assumption; + tclTHEN (Proofview.V82.tactic (apply sym)) assumption; + try_prove_eq + ] + ])) end let replace c2 c1 = multi_replace onConcl c2 c1 false None @@ -627,8 +637,7 @@ let find_positions env sigma t1 t2 = let hd1,args1 = whd_betadeltaiota_stack env sigma t1 in let hd2,args2 = whd_betadeltaiota_stack env sigma t2 in match (kind_of_term hd1, kind_of_term hd2) with - - | Construct sp1, Construct sp2 + | Construct (sp1,_), Construct (sp2,_) when Int.equal (List.length args1) (mis_constructor_nargs_env env sp1) -> let sorts = @@ -636,7 +645,7 @@ let find_positions env sigma t1 t2 = in (* both sides are fully applied constructors, so either we descend, or we can discriminate here. *) - if is_conv env sigma hd1 hd2 then + if eq_constructor sp1 sp2 then let nrealargs = constructor_nrealargs env sp1 in let rargs1 = List.lastn nrealargs args1 in let rargs2 = List.lastn nrealargs args2 in @@ -746,7 +755,7 @@ let descend_then sigma env head dirn = try find_rectype env sigma (get_type_of env sigma head) with Not_found -> error "Cannot project on an inductive type derived from a dependency." in - let ind,_ = dest_ind_family indf in + let (ind,_),_ = dest_ind_family indf in let (mib,mip) = lookup_mind_specif env ind in let cstr = get_constructors env indf in let dirn_nlams = cstr.(dirn-1).cs_nargs in @@ -795,7 +804,7 @@ let construct_discriminator sigma env dirn c sort = errorlabstrm "Equality.construct_discriminator" (str "Cannot discriminate on inductive constructors with \ dependent types.") in - let (ind,_) = dest_ind_family indf in + let ((ind,_),_) = dest_ind_family indf in let (mib,mip) = lookup_mind_specif env ind in let (true_0,false_0,sort_0) = build_coq_True(),build_coq_False(),Prop Null in let deparsign = make_arity_signature env true indf in @@ -847,22 +856,23 @@ let gen_absurdity id = *) let ind_scheme_of_eq lbeq = - let (mib,mip) = Global.lookup_inductive (destInd lbeq.eq) in + let (mib,mip) = Global.lookup_inductive (destIndRef lbeq.eq) in let kind = inductive_sort_family mip in (* use ind rather than case by compatibility *) let kind = if kind == InProp then Elimschemes.ind_scheme_kind_from_prop else Elimschemes.ind_scheme_kind_from_type in - let c, eff = find_scheme kind (destInd lbeq.eq) in - mkConst c, eff + let c, eff = find_scheme kind (destIndRef lbeq.eq) in + ConstRef c, eff -let discrimination_pf e (t,t1,t2) discriminator lbeq = +let discrimination_pf env sigma e (t,t1,t2) discriminator lbeq = let i = build_coq_I () in let absurd_term = build_coq_False () in let eq_elim, eff = ind_scheme_of_eq lbeq in - (applist (eq_elim, [t;t1;mkNamedLambda e t discriminator;i;t2]), absurd_term), - eff + let sigma, eq_elim = Evd.fresh_global env sigma eq_elim in + sigma, (applist (eq_elim, [t;t1;mkNamedLambda e t discriminator;i;t2]), absurd_term), + eff let eq_baseid = Id.of_string "e" @@ -880,11 +890,12 @@ let discr_positions env sigma (lbeq,eqn,(t,t1,t2)) eq_clause cpath dirn sort = let e_env = push_named (e,None,t) env in let discriminator = build_discriminator sigma e_env dirn (mkVar e) sort cpath in - let (pf, absurd_term), eff = - discrimination_pf e (t,t1,t2) discriminator lbeq in + let sigma,(pf, absurd_term), eff = + discrimination_pf env sigma e (t,t1,t2) discriminator lbeq in let pf_ty = mkArrow eqn absurd_term in let absurd_clause = apply_on_clause (pf,pf_ty) eq_clause in let pf = clenv_value_cast_meta absurd_clause in + Proofview.V82.tclEVARS sigma <*> Proofview.tclEFFECTS eff <*> tclTHENS (cut_intro absurd_term) [onLastHypId gen_absurdity; (Proofview.V82.tactic (refine pf))] @@ -911,7 +922,7 @@ let onEquality with_evars tac (c,lbindc) = let eq_clause = pf_apply make_clenv_binding gl (c,t') lbindc in let eq_clause' = clenv_pose_dependent_evars with_evars eq_clause in let eqn = clenv_type eq_clause' in - let (eq,eq_args) = find_this_eq_data_decompose gl eqn in + let (eq,u,eq_args) = find_this_eq_data_decompose gl eqn in tclTHEN (Proofview.V82.tclEVARS eq_clause'.evd) (tac (eq,eqn,eq_args) eq_clause') @@ -964,7 +975,7 @@ let discrHyp id = discrClause false (onHyp id) constructor depending on the sort *) (* J.F.: correction du bug #1167 en accord avec Hugo. *) -let find_sigma_data s = build_sigma_type () +let find_sigma_data env s = build_sigma_type () (* [make_tuple env sigma (rterm,rty) lind] assumes [lind] is the lesser index bound in [rty] @@ -978,16 +989,18 @@ let find_sigma_data s = build_sigma_type () let make_tuple env sigma (rterm,rty) lind = assert (dependent (mkRel lind) rty); - let {intro = exist_term; typ = sig_term} = - find_sigma_data (get_sort_of env sigma rty) in + let sigdata = find_sigma_data env (get_sort_of env sigma rty) in let a = type_of env sigma (mkRel lind) in let (na,_,_) = lookup_rel lind env in (* We move [lind] to [1] and lift other rels > [lind] by 1 *) let rty = lift (1-lind) (liftn lind (lind+1) rty) in (* Now [lind] is [mkRel 1] and we abstract on (na:a) *) let p = mkLambda (na, a, rty) in - (applist(exist_term,[a;p;(mkRel lind);rterm]), - applist(sig_term,[a;p])) + let sigma, exist_term = Evd.fresh_global env sigma sigdata.intro in + let sigma, sig_term = Evd.fresh_global env sigma sigdata.typ in + sigma, + (applist(exist_term,[a;p;(mkRel lind);rterm]), + applist(sig_term,[a;p])) (* check that the free-references of the type of [c] are contained in the free-references of the normal-form of that type. Strictly @@ -1052,7 +1065,7 @@ let minimal_free_rels_rec env sigma = *) let sig_clausal_form env sigma sort_of_ty siglen ty dflt = - let { intro = exist_term } = find_sigma_data sort_of_ty in + let sigdata = find_sigma_data env sort_of_ty in let evdref = ref (Evd.create_goal_evar_defs sigma) in let rec sigrec_clausal_form siglen p_i = if Int.equal siglen 0 then @@ -1078,13 +1091,14 @@ let sig_clausal_form env sigma sort_of_ty siglen ty dflt = | Some w -> let w_type = type_of env sigma w in if Evarconv.e_cumul env evdref w_type a then + let exist_term = Evarutil.evd_comb1 (Evd.fresh_global env) evdref sigdata.intro in applist(exist_term,[w_type;p_i_minus_1;w;tuple_tail]) else error "Cannot solve a unification problem." | None -> anomaly (Pp.str "Not enough components to build the dependent tuple") in let scf = sigrec_clausal_form siglen ty in - Evarutil.nf_evar !evdref scf + !evdref, Evarutil.nf_evar !evdref scf (* The problem is to build a destructor (a generalization of the predecessor) which, when applied to a term made of constructors @@ -1148,13 +1162,13 @@ let make_iterated_tuple env sigma dflt (z,zty) = let (zty,rels) = minimal_free_rels_rec env sigma (z,zty) in let sort_of_zty = get_sort_of env sigma zty in let sorted_rels = Int.Set.elements rels in - let (tuple,tuplety) = - List.fold_left (make_tuple env sigma) (z,zty) sorted_rels + let sigma, (tuple,tuplety) = + List.fold_left (fun (sigma, t) -> make_tuple env sigma t) (sigma, (z,zty)) sorted_rels in assert (closed0 tuplety); let n = List.length sorted_rels in - let dfltval = sig_clausal_form env sigma sort_of_zty n tuplety dflt in - (tuple,tuplety,dfltval) + let sigma, dfltval = sig_clausal_form env sigma sort_of_zty n tuplety dflt in + sigma, (tuple,tuplety,dfltval) let rec build_injrec sigma env dflt c = function | [] -> make_iterated_tuple env sigma dflt (c,type_of env sigma c) @@ -1162,15 +1176,14 @@ let rec build_injrec sigma env dflt c = function try let (cnum_nlams,cnum_env,kont) = descend_then sigma env c cnum in let newc = mkRel(cnum_nlams-argnum) in - let (subval,tuplety,dfltval) = build_injrec sigma cnum_env dflt newc l in - (kont subval (dfltval,tuplety), - tuplety,dfltval) + let sigma, (subval,tuplety,dfltval) = build_injrec sigma cnum_env dflt newc l in + sigma, (kont subval (dfltval,tuplety), tuplety,dfltval) with UserError _ -> failwith "caught" let build_injector sigma env dflt c cpath = - let (injcode,resty,_) = build_injrec sigma env dflt c cpath in - (injcode,resty) + let sigma, (injcode,resty,_) = build_injrec sigma env dflt c cpath in + sigma, (injcode,resty) (* let try_delta_expand env sigma t = @@ -1199,28 +1212,32 @@ let simplify_args env sigma t = let inject_at_positions env sigma l2r (eq,_,(t,t1,t2)) eq_clause posns tac = let e = next_ident_away eq_baseid (ids_of_context env) in let e_env = push_named (e, None,t) env in + let evdref = ref sigma in let filter (cpath, t1', t2') = try (* arbitrarily take t1' as the injector default value *) - let (injbody,resty) = build_injector sigma e_env t1' (mkVar e) cpath in + let sigma, (injbody,resty) = build_injector !evdref e_env t1' (mkVar e) cpath in let injfun = mkNamedLambda e t injbody in - let pf = applist(eq.congr,[t;resty;injfun;t1;t2]) in - let pf_typ = get_type_of env sigma pf in + let congr = Evarutil.evd_comb1 (Evd.fresh_global env) evdref eq.congr in + let pf = applist(congr,[t;resty;injfun;t1;t2]) in + let sigma, pf_typ = Typing.e_type_of env sigma pf in let inj_clause = apply_on_clause (pf,pf_typ) eq_clause in let pf = clenv_value_cast_meta inj_clause in let ty = simplify_args env sigma (clenv_type inj_clause) in - Some (pf, ty) + evdref := sigma; + Some (pf, ty) with Failure _ -> None in let injectors = List.map_filter filter posns in if List.is_empty injectors then Proofview.tclZERO (Errors.UserError ("Equality.inj" , str "Failed to decompose the equality.")) else - Proofview.tclBIND + Proofview.tclTHEN (Proofview.V82.tclEVARS !evdref) + (Proofview.tclBIND (Proofview.Monad.List.map (fun (pf,ty) -> tclTHENS (cut ty) [Proofview.tclUNIT (); Proofview.V82.tactic (refine pf)]) (if l2r then List.rev injectors else injectors)) - (fun _ -> tac (List.length injectors)) + (fun _ -> tac (List.length injectors))) exception Not_dep_pair @@ -1232,30 +1249,32 @@ let eqdep_dec = qualid_of_string "Coq.Logic.Eqdep_dec" let inject_if_homogenous_dependent_pair env sigma (eq,_,(t,t1,t2)) = Proofview.Goal.raw_enter begin fun gl -> (* fetch the informations of the pair *) - let ceq = constr_of_global Coqlib.glob_eq in + let ceq = Universes.constr_of_global Coqlib.glob_eq in let sigTconstr () = (Coqlib.build_sigma_type()).Coqlib.typ in let eqTypeDest = fst (destApp t) in let _,ar1 = destApp t1 and _,ar2 = destApp t2 in let ind = destInd ar1.(0) in - (* check whether the equality deals with dep pairs or not *) - (* if yes, check if the user has declared the dec principle *) - (* and compare the fst arguments of the dep pair *) + (* check whether the equality deals with dep pairs or not *) + (* if yes, check if the user has declared the dec principle *) + (* and compare the fst arguments of the dep pair *) let new_eq_args = [|type_of env sigma ar1.(3);ar1.(3);ar2.(3)|] in - if (eq_constr eqTypeDest (sigTconstr())) && - (Ind_tables.check_scheme (!eq_dec_scheme_kind_name()) ind) && + if (Globnames.is_global (sigTconstr()) eqTypeDest) && + (Ind_tables.check_scheme (!eq_dec_scheme_kind_name()) (fst ind)) && (is_conv env sigma ar1.(2) ar2.(2)) then begin Library.require_library [Loc.ghost,eqdep_dec] (Some false); let inj2 = Coqlib.coq_constant "inj_pair2_eq_dec is missing" ["Logic";"Eqdep_dec"] "inj_pair2_eq_dec" in - let c, eff = find_scheme (!eq_dec_scheme_kind_name()) ind in + let scheme, eff = find_scheme (!eq_dec_scheme_kind_name()) (Univ.out_punivs ind) in (* cut with the good equality and prove the requested goal *) tclTHENS (tclTHEN (Proofview.tclEFFECTS eff) (cut (mkApp (ceq,new_eq_args)))) - [tclIDTAC; tclTHEN (Proofview.V82.tactic (apply ( - mkApp(inj2,[|ar1.(0);mkConst c;ar1.(1);ar1.(2);ar1.(3);ar2.(3)|]) + [tclIDTAC; + pf_constr_of_global (ConstRef scheme) (fun c -> + tclTHEN (Proofview.V82.tactic (apply ( + mkApp(inj2,[|ar1.(0);c;ar1.(1);ar1.(2);ar1.(3);ar2.(3)|]) ))) (Auto.trivial [] []) - ] + )] (* not a dep eq or no decidable type found *) end else raise Not_dep_pair @@ -1341,29 +1360,31 @@ let swap_equality_args = function | HeterogenousEq (t1,e1,t2,e2) -> [t2;e2;t1;e1] let swap_equands eqn = - let (lbeq,eq_args) = find_eq_data eqn in - applist(lbeq.eq,swap_equality_args eq_args) + let (lbeq,u,eq_args) = find_eq_data eqn in + let eq = Universes.constr_of_global_univ (lbeq.eq,u) in + applist(eq,swap_equality_args eq_args) let swapEquandsInConcl = Proofview.Goal.raw_enter begin fun gl -> - let (lbeq,eq_args) = find_eq_data (pf_nf_concl gl) in - let sym_equal = lbeq.sym in + let (lbeq,u,eq_args) = find_eq_data (pf_nf_concl gl) in let args = swap_equality_args eq_args @ [Evarutil.mk_new_meta ()] in - Proofview.V82.tactic (fun gl -> refine (applist (sym_equal, args)) gl) + pf_constr_of_global lbeq.sym (fun sym_equal -> + Proofview.V82.tactic (refine (applist (sym_equal, args)))) end (* Refine from [|- P e2] to [|- P e1] and [|- e1=e2:>t] (body is P (Rel 1)) *) -let bareRevSubstInConcl lbeq body (t,e1,e2) = +let bareRevSubstInConcl (lbeq,u) body (t,e1,e2) = Proofview.Goal.raw_enter begin fun gl -> (* find substitution scheme *) - let eq_elim, effs = find_elim lbeq.eq (Some false) false None None gl in + let eq = Universes.constr_of_global_univ (lbeq.eq,u) in + let eq_elim, effs = find_elim eq (Some false) false None None gl in (* build substitution predicate *) let p = lambda_create (Proofview.Goal.env gl) (t,body) in (* apply substitution scheme *) let args = [t; e1; p; Evarutil.mk_new_meta (); e2; Evarutil.mk_new_meta ()] in - let tac gl = refine (applist (eq_elim, args)) gl in - Proofview.V82.tactic tac + pf_constr_of_global (ConstRef eq_elim) (fun c -> + Proofview.V82.tactic (refine (applist (c, args)))) end (* [subst_tuple_term dep_pair B] @@ -1402,17 +1423,15 @@ let decomp_tuple_term env c t = let rec decomprec inner_code ex exty = let iterated_decomp = try - let {proj1=p1; proj2=p2},(a,p,car,cdr) = find_sigma_data_decompose ex in - let car_code = applist (p1,[a;p;inner_code]) - and cdr_code = applist (p2,[a;p;inner_code]) in + let ({proj1=p1; proj2=p2}),(i,a,p,car,cdr) = find_sigma_data_decompose ex in + let car_code = applist (mkConstU (destConstRef p1,i),[a;p;inner_code]) + and cdr_code = applist (mkConstU (destConstRef p2,i),[a;p;inner_code]) in let cdrtyp = beta_applist (p,[car]) in List.map (fun l -> ((car,a),car_code)::l) (decomprec cdr_code cdr cdrtyp) with ConstrMatching.PatternMatchingFailure -> [] - in - [((ex,exty),inner_code)]::iterated_decomp - in - decomprec (mkRel 1) c t + in [((ex,exty),inner_code)]::iterated_decomp + in decomprec (mkRel 1) c t let subst_tuple_term env sigma dep_pair1 dep_pair2 b = let typ = get_type_of env sigma dep_pair1 in @@ -1435,7 +1454,7 @@ let subst_tuple_term env sigma dep_pair1 dep_pair2 b = let expected_goal = beta_applist (abst_B,List.map fst e2_list) in (* Simulate now the normalisation treatment made by Logic.mk_refgoals *) let expected_goal = nf_betaiota sigma expected_goal in - pred_body,expected_goal + pred_body,expected_goal (* Like "replace" but decompose dependent equalities *) @@ -1443,12 +1462,12 @@ exception NothingToRewrite let cutSubstInConcl_RL eqn = Proofview.Goal.raw_enter begin fun gl -> - let (lbeq,(t,e1,e2 as eq)) = find_eq_data_decompose gl eqn in + let (lbeq,u,(t,e1,e2 as eq)) = find_eq_data_decompose gl eqn in let concl = pf_nf_concl gl in let body,expected_goal = pf_apply subst_tuple_term gl e2 e1 concl in if not (dependent (mkRel 1) body) then raise NothingToRewrite; tclTHENFIRST - (bareRevSubstInConcl lbeq body eq) + (bareRevSubstInConcl (lbeq,u) body eq) (Proofview.V82.tactic (fun gl -> convert_concl expected_goal DEFAULTcast gl)) end @@ -1465,12 +1484,12 @@ let cutSubstInConcl l2r =if l2r then cutSubstInConcl_LR else cutSubstInConcl_RL let cutSubstInHyp_LR eqn id = Proofview.Goal.enter begin fun gl -> - let (lbeq,(t,e1,e2 as eq)) = find_eq_data_decompose gl eqn in + let (lbeq,u,(t,e1,e2 as eq)) = find_eq_data_decompose gl eqn in let idtyp = pf_get_hyp_typ id gl in let body,expected_goal = pf_apply subst_tuple_term gl e1 e2 idtyp in if not (dependent (mkRel 1) body) then raise NothingToRewrite; let refine = Proofview.V82.tactic (fun gl -> Tacmach.refine_no_check (mkVar id) gl) in - let subst = Proofview.V82.of_tactic (tclTHENFIRST (bareRevSubstInConcl lbeq body eq) refine) in + let subst = Proofview.V82.of_tactic (tclTHENFIRST (bareRevSubstInConcl (lbeq,u) body eq) refine) in Proofview.V82.tactic (fun gl -> cut_replacing id expected_goal subst gl) end @@ -1555,8 +1574,8 @@ let unfold_body x = let restrict_to_eq_and_identity eq = (* compatibility *) - if not (eq_constr eq (constr_of_global glob_eq)) && - not (eq_constr eq (constr_of_global glob_identity)) + if not (is_global glob_eq eq) && + not (is_global glob_identity eq) then raise ConstrMatching.PatternMatchingFailure exception FoundHyp of (Id.t * constr * bool) @@ -1565,7 +1584,7 @@ exception FoundHyp of (Id.t * constr * bool) let is_eq_x gl x (id,_,c) = try let c = pf_nf_evar gl c in - let (_,lhs,rhs) = snd (find_eq_data_decompose gl c) in + let (_,lhs,rhs) = pi3 (find_eq_data_decompose gl c) in if (eq_constr x lhs) && not (occur_term x rhs) then raise (FoundHyp (id,rhs,true)); if (eq_constr x rhs) && not (occur_term x lhs) then raise (FoundHyp (id,lhs,false)) with ConstrMatching.PatternMatchingFailure -> @@ -1664,8 +1683,9 @@ let subst_all ?(flags=default_subst_tactic_flags ()) () = let find_eq_data_decompose = find_eq_data_decompose gl in let test (_,c) = try - let lbeq,(_,x,y) = find_eq_data_decompose c in - if flags.only_leibniz then restrict_to_eq_and_identity lbeq.eq; + let lbeq,u,(_,x,y) = find_eq_data_decompose c in + let eq = Universes.constr_of_global_univ (lbeq.eq,u) in + if flags.only_leibniz then restrict_to_eq_and_identity eq; (* J.F.: added to prevent failure on goal containing x=x as an hyp *) if eq_constr x y then failwith "caught"; match kind_of_term x with Var x -> x | _ -> @@ -1684,19 +1704,19 @@ let subst_all ?(flags=default_subst_tactic_flags ()) () = let cond_eq_term_left c t gl = try - let (_,x,_) = snd (find_eq_data_decompose gl t) in + let (_,x,_) = pi3 (find_eq_data_decompose gl t) in if pf_conv_x gl c x then true else failwith "not convertible" with ConstrMatching.PatternMatchingFailure -> failwith "not an equality" let cond_eq_term_right c t gl = try - let (_,_,x) = snd (find_eq_data_decompose gl t) in + let (_,_,x) = pi3 (find_eq_data_decompose gl t) in if pf_conv_x gl c x then false else failwith "not convertible" with ConstrMatching.PatternMatchingFailure -> failwith "not an equality" let cond_eq_term c t gl = try - let (_,x,y) = snd (find_eq_data_decompose gl t) in + let (_,x,y) = pi3 (find_eq_data_decompose gl t) in if pf_conv_x gl c x then true else if pf_conv_x gl c y then false else failwith "not convertible" diff --git a/tactics/equality.mli b/tactics/equality.mli index b59b4bbe0..82e30b940 100644 --- a/tactics/equality.mli +++ b/tactics/equality.mli @@ -88,7 +88,7 @@ val dEq : evars_flag -> constr with_bindings induction_arg option -> unit Proofv val dEqThen : evars_flag -> (constr -> int -> unit Proofview.tactic) -> constr with_bindings induction_arg option -> unit Proofview.tactic val make_iterated_tuple : - env -> evar_map -> constr -> (constr * types) -> constr * constr * constr + env -> evar_map -> constr -> (constr * types) -> evar_map * (constr * constr * constr) (* The family cutRewriteIn expect an equality statement *) val cutRewriteInHyp : bool -> types -> Id.t -> unit Proofview.tactic diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4 index f8790796d..bda217566 100644 --- a/tactics/extratactics.ml4 +++ b/tactics/extratactics.ml4 @@ -252,7 +252,14 @@ TACTIC EXTEND rewrite_star let add_rewrite_hint bases ort t lcsr = let env = Global.env() and sigma = Evd.empty in - let f c = Constrexpr_ops.constr_loc c, Constrintern.interp_constr sigma env c, ort, t in + let poly = Flags.is_universe_polymorphism () in + let f ce = + let c, ctx = Constrintern.interp_constr sigma env ce in + let ctx = + if poly then ctx + else (Global.add_constraints (snd ctx); Univ.ContextSet.empty) + in + Constrexpr_ops.constr_loc ce, (c, ctx), ort, t in let eqs = List.map f lcsr in let add_hints base = add_rew_rules base eqs in List.iter add_hints bases @@ -281,8 +288,8 @@ open Coqlib let project_hint pri l2r r = let gr = Smartlocate.global_with_alias r in let env = Global.env() in - let c = Globnames.constr_of_global gr in - let t = Retyping.get_type_of env Evd.empty c in + let c,ctx = Universes.fresh_global_instance env gr in + let t = Retyping.get_type_of env (Evd.from_env ~ctx env) c in let t = Tacred.reduce_to_quantified_ref env Evd.empty (Lazy.force coq_iff_ref) t in let sign,ccl = decompose_prod_assum t in @@ -294,7 +301,11 @@ let project_hint pri l2r r = let c = Reductionops.whd_beta Evd.empty (mkApp (c,Termops.extended_rel_vect 0 sign)) in let c = it_mkLambda_or_LetIn (mkApp (p,[|mkArrow a (lift 1 b);mkArrow b (lift 1 a);c|])) sign in - (pri,true,Auto.PathAny, Globnames.IsConstr c) + let id = + Nameops.add_suffix (Nametab.basename_of_global gr) ("_proj_" ^ (if l2r then "l2r" else "r2l")) + in + let c = Declare.declare_definition ~internal:Declare.KernelSilent id (c,ctx) in + (pri,false,true,Auto.PathAny, Auto.IsGlobRef (Globnames.ConstRef c)) let add_hints_iff l2r lc n bl = Auto.add_hints true bl @@ -473,7 +484,7 @@ let inTransitivity : bool * constr -> obj = (* Main entry points *) let add_transitivity_lemma left lem = - let lem' = Constrintern.interp_constr Evd.empty (Global.env ()) lem in + let lem',ctx (*FIXME*) = Constrintern.interp_constr Evd.empty (Global.env ()) lem in add_anonymous_leaf (inTransitivity (left,lem')) (* Vernacular syntax *) @@ -513,8 +524,8 @@ END VERNAC COMMAND EXTEND RetroknowledgeRegister CLASSIFIED AS SIDEFF | [ "Register" constr(c) "as" retroknowledge_field(f) "by" constr(b)] -> - [ let tc = Constrintern.interp_constr Evd.empty (Global.env ()) c in - let tb = Constrintern.interp_constr Evd.empty (Global.env ()) b in + [ let tc,ctx = Constrintern.interp_constr Evd.empty (Global.env ()) c in + let tb,ctx(*FIXME*) = Constrintern.interp_constr Evd.empty (Global.env ()) b in Global.register f tc tb ] END @@ -607,9 +618,11 @@ let hResolve id c occ t gl = let loc = match Loc.get_loc e with None -> Loc.ghost | Some loc -> loc in resolve_hole (subst_hole_with_term (fst (Loc.unloc loc)) c_raw t_hole) in - let t_constr = resolve_hole (subst_var_with_hole occ id t_raw) in + let t_constr,ctx = resolve_hole (subst_var_with_hole occ id t_raw) in + let sigma = Evd.merge_context_set Evd.univ_rigid sigma ctx in let t_constr_type = Retyping.get_type_of env sigma t_constr in - change_in_concl None (mkLetIn (Anonymous,t_constr,t_constr_type,pf_concl gl)) gl + tclTHEN (Refiner.tclEVARS sigma) + (change_in_concl None (mkLetIn (Anonymous,t_constr,t_constr_type,pf_concl gl))) gl let hResolve_auto id c t gl = let rec resolve_auto n = @@ -749,6 +762,11 @@ TACTIC EXTEND constr_eq if eq_constr x y then Proofview.tclUNIT () else Tacticals.New.tclFAIL 0 (str "Not equal") ] END +TACTIC EXTEND constr_eq_nounivs +| [ "constr_eq_nounivs" constr(x) constr(y) ] -> [ + if eq_constr_nounivs x y then Proofview.tclUNIT () else Tacticals.New.tclFAIL 0 (str "Not equal") ] +END + TACTIC EXTEND is_evar | [ "is_evar" constr(x) ] -> [ match kind_of_term x with @@ -772,6 +790,7 @@ let rec has_evar x = has_evar t1 || has_evar t2 || has_evar_array ts | Fix ((_, tr)) | CoFix ((_, tr)) -> has_evar_prec tr + | Proj (p, c) -> has_evar c and has_evar_array x = Array.exists has_evar x and has_evar_prec (_, ts1, ts2) = diff --git a/tactics/g_rewrite.ml4 b/tactics/g_rewrite.ml4 index 954892e81..d00626d32 100644 --- a/tactics/g_rewrite.ml4 +++ b/tactics/g_rewrite.ml4 @@ -105,6 +105,12 @@ END let db_strat db = StratUnary ("topdown", StratHints (false, db)) let cl_rewrite_clause_db db = cl_rewrite_clause_strat (strategy_of_ast (db_strat db)) +let cl_rewrite_clause_db = + if Flags.profile then + let key = Profile.declare_profile "cl_rewrite_clause_db" in + Profile.profile3 key cl_rewrite_clause_db + else cl_rewrite_clause_db + TACTIC EXTEND rewrite_strat | [ "rewrite_strat" rewstrategy(s) "in" hyp(id) ] -> [ Proofview.V82.tactic (cl_rewrite_clause_strat s (Some id)) ] | [ "rewrite_strat" rewstrategy(s) ] -> [ Proofview.V82.tactic (cl_rewrite_clause_strat s None) ] @@ -140,21 +146,21 @@ TACTIC EXTEND setoid_rewrite [ Proofview.V82.tactic (cl_rewrite_clause c o (occurrences_of occ) (Some id))] END -let cl_rewrite_clause_newtac_tac c o occ cl = - cl_rewrite_clause_newtac' c o occ cl - -TACTIC EXTEND GenRew -| [ "rew" orient(o) glob_constr_with_bindings(c) "in" hyp(id) "at" occurrences(occ) ] -> - [ cl_rewrite_clause_newtac_tac c o (occurrences_of occ) (Some id) ] -| [ "rew" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) "in" hyp(id) ] -> - [ cl_rewrite_clause_newtac_tac c o (occurrences_of occ) (Some id) ] -| [ "rew" orient(o) glob_constr_with_bindings(c) "in" hyp(id) ] -> - [ cl_rewrite_clause_newtac_tac c o AllOccurrences (Some id) ] -| [ "rew" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) ] -> - [ cl_rewrite_clause_newtac_tac c o (occurrences_of occ) None ] -| [ "rew" orient(o) glob_constr_with_bindings(c) ] -> - [ cl_rewrite_clause_newtac_tac c o AllOccurrences None ] -END +(* let cl_rewrite_clause_newtac_tac c o occ cl = *) +(* cl_rewrite_clause_newtac' c o occ cl *) + +(* TACTIC EXTEND GenRew *) +(* | [ "rew" orient(o) glob_constr_with_bindings(c) "in" hyp(id) "at" occurrences(occ) ] -> *) +(* [ cl_rewrite_clause_newtac_tac c o (occurrences_of occ) (Some id) ] *) +(* | [ "rew" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) "in" hyp(id) ] -> *) +(* [ cl_rewrite_clause_newtac_tac c o (occurrences_of occ) (Some id) ] *) +(* | [ "rew" orient(o) glob_constr_with_bindings(c) "in" hyp(id) ] -> *) +(* [ cl_rewrite_clause_newtac_tac c o AllOccurrences (Some id) ] *) +(* | [ "rew" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) ] -> *) +(* [ cl_rewrite_clause_newtac_tac c o (occurrences_of occ) None ] *) +(* | [ "rew" orient(o) glob_constr_with_bindings(c) ] -> *) +(* [ cl_rewrite_clause_newtac_tac c o AllOccurrences None ] *) +(* END *) VERNAC COMMAND EXTEND AddRelation CLASSIFIED AS SIDEFF | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) diff --git a/tactics/hipattern.ml4 b/tactics/hipattern.ml4 index 89aaee485..130e66720 100644 --- a/tactics/hipattern.ml4 +++ b/tactics/hipattern.ml4 @@ -47,7 +47,7 @@ let match_with_non_recursive_type t = | App _ -> let (hdapp,args) = decompose_app t in (match kind_of_term hdapp with - | Ind ind -> + | Ind (ind,u) -> if not (Global.lookup_mind (fst ind)).mind_finite then Some (hdapp,args) else @@ -90,9 +90,9 @@ let match_with_one_constructor style onlybinary allow_rec t = let (hdapp,args) = decompose_app t in let res = match kind_of_term hdapp with | Ind ind -> - let (mib,mip) = Global.lookup_inductive ind in + let (mib,mip) = Global.lookup_inductive (fst ind) in if Int.equal (Array.length mip.mind_consnames) 1 - && (allow_rec || not (mis_is_recursive (ind,mib,mip))) + && (allow_rec || not (mis_is_recursive (fst ind,mib,mip))) && (Int.equal mip.mind_nrealargs 0) then if is_strict_conjunction style (* strict conjunction *) then @@ -137,8 +137,8 @@ let match_with_tuple t = let t = match_with_one_constructor None false true t in Option.map (fun (hd,l) -> let ind = destInd hd in - let (mib,mip) = Global.lookup_inductive ind in - let isrec = mis_is_recursive (ind,mib,mip) in + let (mib,mip) = Global.lookup_pinductive ind in + let isrec = mis_is_recursive (fst ind,mib,mip) in (hd,l,isrec)) t let is_tuple t = @@ -158,7 +158,7 @@ let test_strict_disjunction n lc = let match_with_disjunction ?(strict=false) ?(onlybinary=false) t = let (hdapp,args) = decompose_app t in let res = match kind_of_term hdapp with - | Ind ind -> + | Ind (ind,u) -> let car = mis_constr_nargs ind in let (mib,mip) = Global.lookup_inductive ind in if Array.for_all (fun ar -> Int.equal ar 1) car @@ -193,7 +193,7 @@ let match_with_empty_type t = let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with | Ind ind -> - let (mib,mip) = Global.lookup_inductive ind in + let (mib,mip) = Global.lookup_pinductive ind in let nconstr = Array.length mip.mind_consnames in if Int.equal nconstr 0 then Some hdapp else None | _ -> None @@ -207,7 +207,7 @@ let match_with_unit_or_eq_type t = let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with | Ind ind -> - let (mib,mip) = Global.lookup_inductive ind in + let (mib,mip) = Global.lookup_pinductive ind in let constr_types = mip.mind_nf_lc in let nconstr = Array.length mip.mind_consnames in let zero_args c = Int.equal (nb_prod c) mib.mind_nparams in @@ -249,7 +249,7 @@ let match_with_equation t = if not (isApp t) then raise NoEquationFound; let (hdapp,args) = destApp t in match kind_of_term hdapp with - | Ind ind -> + | Ind (ind,u) -> if eq_gr (IndRef ind) glob_eq then Some (build_coq_eq_data()),hdapp, PolymorphicLeibnizEq(args.(0),args.(1),args.(2)) @@ -282,7 +282,7 @@ let is_inductive_equality ind = let match_with_equality_type t = let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with - | Ind ind when is_inductive_equality ind -> Some (hdapp,args) + | Ind (ind,_) when is_inductive_equality ind -> Some (hdapp,args) | _ -> None let is_equality_type t = op2bool (match_with_equality_type t) @@ -322,7 +322,7 @@ let match_with_nodep_ind t = let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with | Ind ind -> - let (mib,mip) = Global.lookup_inductive ind in + let (mib,mip) = Global.lookup_pinductive ind in if Array.length (mib.mind_packets)>1 then None else let nodep_constr = has_nodep_prod_after mib.mind_nparams in if Array.for_all nodep_constr mip.mind_nf_lc then @@ -340,7 +340,7 @@ let match_with_sigma_type t= let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with | Ind ind -> - let (mib,mip) = Global.lookup_inductive ind in + let (mib,mip) = Global.lookup_pinductive ind in if Int.equal (Array.length (mib.mind_packets)) 1 && (Int.equal mip.mind_nrealargs 0) && (Int.equal (Array.length mip.mind_consnames)1) && @@ -378,7 +378,7 @@ let match_eq eqn eq_pat = match Id.Map.bindings (matches pat eqn) with | [(m1,t);(m2,x);(m3,y)] -> assert (Id.equal m1 meta1 && Id.equal m2 meta2 && Id.equal m3 meta3); - PolymorphicLeibnizEq (t,x,y) + PolymorphicLeibnizEq (t,x,y) | [(m1,t);(m2,x);(m3,t');(m4,x')] -> assert (Id.equal m1 meta1 && Id.equal m2 meta2 && Id.equal m3 meta3 && Id.equal m4 meta4); HeterogenousEq (t,x,t',x') @@ -387,13 +387,21 @@ let match_eq eqn eq_pat = let no_check () = true let check_jmeq_loaded () = Library.library_is_loaded Coqlib.jmeq_module +let build_coq_jmeq_data_in env = + build_coq_jmeq_data (), Univ.ContextSet.empty + +let build_coq_identity_data_in env = + build_coq_identity_data (), Univ.ContextSet.empty + let equalities = [coq_eq_pattern, no_check, build_coq_eq_data; coq_jmeq_pattern, check_jmeq_loaded, build_coq_jmeq_data; coq_identity_pattern, no_check, build_coq_identity_data] let find_eq_data eqn = (* fails with PatternMatchingFailure *) - first_match (match_eq eqn) equalities + let d,k = first_match (match_eq eqn) equalities in + let hd,u = destInd (fst (destApp eqn)) in + d,u,k let extract_eq_args gl = function | MonomorphicLeibnizEq (e1,e2) -> @@ -404,11 +412,11 @@ let extract_eq_args gl = function else raise PatternMatchingFailure let find_eq_data_decompose gl eqn = - let (lbeq,eq_args) = find_eq_data eqn in - (lbeq,extract_eq_args gl eq_args) + let (lbeq,u,eq_args) = find_eq_data eqn in + (lbeq,u,extract_eq_args gl eq_args) let find_this_eq_data_decompose gl eqn = - let (lbeq,eq_args) = + let (lbeq,u,eq_args) = try (*first_match (match_eq eqn) inversible_equalities*) find_eq_data eqn with PatternMatchingFailure -> @@ -417,7 +425,7 @@ let find_this_eq_data_decompose gl eqn = try extract_eq_args gl eq_args with PatternMatchingFailure -> error "Don't know what to do with JMeq on arguments not of same type." in - (lbeq,eq_args) + (lbeq,u,eq_args) let match_eq_nf gls eqn eq_pat = match Id.Map.bindings (pf_matches gls (Lazy.force eq_pat) eqn) with @@ -439,18 +447,16 @@ let coq_ex_pattern_gen ex = lazy PATTERN [ %ex ?X1 ?X2 ?X3 ?X4 ] let coq_existT_pattern = coq_ex_pattern_gen coq_existT_ref let coq_exist_pattern = coq_ex_pattern_gen coq_exist_ref -let match_sigma ex ex_pat = - match Id.Map.bindings (matches (Lazy.force ex_pat) ex) with - | [(m1,a);(m2,p);(m3,car);(m4,cdr)] -> - assert (Id.equal m1 meta1 && Id.equal m2 meta2 && Id.equal m3 meta3 && Id.equal m4 meta4); - (a,p,car,cdr) - | _ -> - anomaly ~label:"match_sigma" (Pp.str "a successful sigma pattern should match 4 terms") - +let match_sigma ex = + match kind_of_term ex with + | App (f, [| a; p; car; cdr |]) when is_global (Lazy.force coq_exist_ref) f -> + build_sigma (), (snd (destConstruct f), a, p, car, cdr) + | App (f, [| a; p; car; cdr |]) when is_global (Lazy.force coq_existT_ref) f -> + build_sigma_type (), (snd (destConstruct f), a, p, car, cdr) + | _ -> raise PatternMatchingFailure + let find_sigma_data_decompose ex = (* fails with PatternMatchingFailure *) - first_match (match_sigma ex) - [coq_existT_pattern, no_check, build_sigma_type; - coq_exist_pattern, no_check, build_sigma] + match_sigma ex (* Pattern "(sig ?1 ?2)" *) let coq_sig_pattern = lazy PATTERN [ %coq_sig_ref ?X1 ?X2 ] @@ -495,7 +501,7 @@ let match_eqdec t = false,op_or,matches (Lazy.force coq_eqdec_rev_pattern) t in match Id.Map.bindings subst with | [(_,typ);(_,c1);(_,c2)] -> - eqonleft, Globnames.constr_of_global (Lazy.force op), c1, c2, typ + eqonleft, Universes.constr_of_global (Lazy.force op), c1, c2, typ | _ -> anomaly (Pp.str "Unexpected pattern") (* Patterns "~ ?" and "? -> False" *) diff --git a/tactics/hipattern.mli b/tactics/hipattern.mli index fc87fc9ed..3637be41d 100644 --- a/tactics/hipattern.mli +++ b/tactics/hipattern.mli @@ -121,19 +121,19 @@ val match_with_equation: (** Match terms [eq A t u], [identity A t u] or [JMeq A t A u] Returns associated lemmas and [A,t,u] or fails PatternMatchingFailure *) val find_eq_data_decompose : 'a Proofview.Goal.t -> constr -> - coq_eq_data * (types * constr * constr) + coq_eq_data * Univ.universe_instance * (types * constr * constr) (** Idem but fails with an error message instead of PatternMatchingFailure *) val find_this_eq_data_decompose : 'a Proofview.Goal.t -> constr -> - coq_eq_data * (types * constr * constr) + coq_eq_data * Univ.universe_instance * (types * constr * constr) (** A variant that returns more informative structure on the equality found *) -val find_eq_data : constr -> coq_eq_data * equation_kind +val find_eq_data : constr -> coq_eq_data * Univ.universe_instance * equation_kind (** Match a term of the form [(existT A P t p)] Returns associated lemmas and [A,P,t,p] *) val find_sigma_data_decompose : constr -> - coq_sigma_data * (constr * constr * constr * constr) + coq_sigma_data * (Univ.universe_instance * constr * constr * constr * constr) (** Match a term of the form [{x:A|P}], returns [A] and [P] *) val match_sigma : constr -> constr * constr diff --git a/tactics/inv.ml b/tactics/inv.ml index 0c0bcc06a..0ff6b69a5 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -67,7 +67,7 @@ type inversion_status = Dep of constr option | NoDep let compute_eqn env sigma n i ai = (mkRel (n-i),get_type_of env sigma (mkRel (n-i))) -let make_inv_predicate env sigma indf realargs id status concl = +let make_inv_predicate env evd indf realargs id status concl = let nrealargs = List.length realargs in let (hyps,concl) = match status with @@ -86,11 +86,12 @@ let make_inv_predicate env sigma indf realargs id status concl = match dflt_concl with | Some concl -> concl (*assumed it's some [x1..xn,H:I(x1..xn)]C*) | None -> - let sort = get_sort_family_of env sigma concl in - let p = make_arity env true indf (new_sort_in_family sort) in - fst (Unification.abstract_list_all env - (Evd.create_evar_defs sigma) - p concl (realargs@[mkVar id])) in + let sort = get_sort_family_of env !evd concl in + let sort = Evarutil.evd_comb1 (Evd.fresh_sort_in_family env) evd sort in + let p = make_arity env true indf sort in + let evd',(p,ptyp) = Unification.abstract_list_all env + !evd p concl (realargs@[mkVar id]) + in evd := evd'; p in let hyps,bodypred = decompose_lam_n_assum (nrealargs+1) pred in (* We lift to make room for the equations *) (hyps,lift nrealargs bodypred) @@ -102,21 +103,25 @@ let make_inv_predicate env sigma indf realargs id status concl = (* Now, we can recurse down this list, for each ai,(mkRel k) whether to push <Ai>(mkRel k)=ai (when Ai is closed). In any case, we carry along the rest of pairs *) + let eqdata = Coqlib.build_coq_eq_data () in let rec build_concl eqns args n = function | [] -> it_mkProd concl eqns, Array.rev_of_list args | ai :: restlist -> let ai = lift nhyps ai in - let (xi, ti) = compute_eqn env' sigma nhyps n ai in + let (xi, ti) = compute_eqn env' !evd nhyps n ai in let (lhs,eqnty,rhs) = if closed0 ti then (xi,ti,ai) else - make_iterated_tuple env' sigma ai (xi,ti) + let sigma, res = make_iterated_tuple env' !evd ai (xi,ti) in + evd := sigma; res in - let eq_term = Coqlib.build_coq_eq () in - let eqn = applist (eq_term ,[eqnty;lhs;rhs]) in + let eq_term = eqdata.Coqlib.eq in + let eq = Evarutil.evd_comb1 (Evd.fresh_global env) evd eq_term in + let eqn = applist (eq,[eqnty;lhs;rhs]) in let eqns = (Anonymous, lift n eqn) :: eqns in - let refl_term = Coqlib.build_coq_eq_refl () in + let refl_term = eqdata.Coqlib.refl in + let refl_term = Evarutil.evd_comb1 (Evd.fresh_global env) evd refl_term in let refl = mkApp (refl_term, [|eqnty; rhs|]) in let args = refl :: args in build_concl eqns args (succ n) restlist @@ -455,8 +460,10 @@ let raw_inversion inv_kind id status names = Errors.errorlabstrm "" msg in let IndType (indf,realargs) = find_rectype env sigma t in + let evdref = ref sigma in let (elim_predicate, args) = - make_inv_predicate env sigma indf realargs id status concl in + make_inv_predicate env evdref indf realargs id status concl in + let sigma = !evdref in let (cut_concl,case_tac) = if status != NoDep && (dependent c concl) then Reduction.beta_appvect elim_predicate (Array.of_list (realargs@[c])), @@ -470,12 +477,13 @@ let raw_inversion inv_kind id status names = Proofview.Refine.refine (fun h -> h, prf) in let neqns = List.length realargs in - tclTHENS + tclTHEN (Proofview.V82.tclEVARS sigma) + (tclTHENS (assert_tac Anonymous cut_concl) [case_tac names (introCaseAssumsThen (rewrite_equations_tac inv_kind id neqns)) (Some elim_predicate) ind (c, t); - onLastHypId (fun id -> tclTHEN (refined id) reflexivity)] + onLastHypId (fun id -> tclTHEN (refined id) reflexivity)]) end (* Error messages of the inversion tactics *) @@ -486,7 +494,7 @@ let wrap_inv_error id = function (strbrk "Inversion would require case analysis on sort " ++ pr_sort k ++ strbrk " which is not allowed for inductive definition " ++ - pr_inductive (Global.env()) i ++ str "."))) + pr_inductive (Global.env()) (fst i) ++ str "."))) | e -> Proofview.tclZERO e (* The most general inversion tactic *) diff --git a/tactics/leminv.ml b/tactics/leminv.ml index 5e5de2589..23a7c9e53 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -194,7 +194,7 @@ let inversion_scheme env sigma t sort dep_option inv_op = errorlabstrm "lemma_inversion" (str"Computed inversion goal was not closed in initial signature."); *) - let pf = Proof.start Evd.empty [invEnv,invGoal] in + let pf = Proof.start Evd.empty [invEnv,(invGoal,get_universe_context_set sigma)] in let pf = fst (Proof.run_tactic env ( tclTHEN intro (onLastHypId inv_op)) pf) @@ -232,6 +232,9 @@ let add_inversion_lemma name env sigma t sort dep inv_op = const_entry_body = Future.from_val (invProof,Declareops.no_seff); const_entry_secctx = None; const_entry_type = None; + const_entry_proj = None; + const_entry_polymorphic = true; + const_entry_universes = Univ.UContext.empty (*FIXME *); const_entry_opaque = false; const_entry_inline_code = false; const_entry_feedback = None; @@ -244,8 +247,9 @@ let add_inversion_lemma name env sigma t sort dep inv_op = let add_inversion_lemma_exn na com comsort bool tac = let env = Global.env () and sigma = Evd.empty in - let c = Constrintern.interp_type sigma env com in - let sort = Pretyping.interp_sort comsort in + let c,ctx = Constrintern.interp_type sigma env com in + let sigma = Evd.merge_context_set Evd.univ_rigid sigma ctx in + let sigma, sort = Pretyping.interp_sort sigma comsort in try add_inversion_lemma na env sigma c sort bool tac with @@ -260,7 +264,7 @@ let lemInv id c gls = try let clause = mk_clenv_type_of gls c in let clause = clenv_constrain_last_binding (mkVar id) clause in - Clenvtac.res_pf clause ~flags:Unification.elim_flags gls + Clenvtac.res_pf clause ~flags:(Unification.elim_flags ()) gls with | NoSuchBinding -> errorlabstrm "" diff --git a/tactics/nbtermdn.ml b/tactics/nbtermdn.ml new file mode 100644 index 000000000..b07aff99b --- /dev/null +++ b/tactics/nbtermdn.ml @@ -0,0 +1,131 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Util +open Names +open Term +open Pattern +open Globnames + +(* Named, bounded-depth, term-discrimination nets. + Implementation: + Term-patterns are stored in discrimination-nets, which are + themselves stored in a hash-table, indexed by the first label. + They are also stored by name in a table on-the-side, so that we can + override them if needed. *) + +(* The former comments are from Chet. + See the module dn.ml for further explanations. + Eduardo (5/8/97) *) +module Make = + functor (Y:Map.OrderedType) -> +struct + module X = struct + type t = constr_pattern*int + let compare = Pervasives.compare + end + + module Term_dn = Termdn.Make(Y) + open Term_dn + module Z = struct + type t = Term_dn.term_label + let compare x y = + let make_name n = + match n with + | GRLabel(ConstRef con) -> + GRLabel(ConstRef(constant_of_kn(canonical_con con))) + | GRLabel(IndRef (kn,i)) -> + GRLabel(IndRef(mind_of_kn(canonical_mind kn),i)) + | GRLabel(ConstructRef ((kn,i),j ))-> + GRLabel(ConstructRef((mind_of_kn(canonical_mind kn),i),j)) + | k -> k + in + Pervasives.compare (make_name x) (make_name y) + end + + module Dn = Dn.Make(X)(Z)(Y) + module Bounded_net = Btermdn.Make(Y) + + +type 'na t = { + mutable table : ('na,constr_pattern * Y.t) Gmap.t; + mutable patterns : (Term_dn.term_label option,Bounded_net.t) Gmap.t } + + +type 'na frozen_t = + ('na,constr_pattern * Y.t) Gmap.t + * (Term_dn.term_label option, Bounded_net.t) Gmap.t + +let create () = + { table = Gmap.empty; + patterns = Gmap.empty } + +let get_dn dnm hkey = + try Gmap.find hkey dnm with Not_found -> Bounded_net.create () + +let add dn (na,(pat,valu)) = + let hkey = Option.map fst (Term_dn.constr_pat_discr pat) in + dn.table <- Gmap.add na (pat,valu) dn.table; + let dnm = dn.patterns in + dn.patterns <- Gmap.add hkey (Bounded_net.add None (get_dn dnm hkey) (pat,valu)) dnm + +let rmv dn na = + let (pat,valu) = Gmap.find na dn.table in + let hkey = Option.map fst (Term_dn.constr_pat_discr pat) in + dn.table <- Gmap.remove na dn.table; + let dnm = dn.patterns in + dn.patterns <- Gmap.add hkey (Bounded_net.rmv None (get_dn dnm hkey) (pat,valu)) dnm + +let in_dn dn na = Gmap.mem na dn.table + +let remap ndn na (pat,valu) = + rmv ndn na; + add ndn (na,(pat,valu)) + +let decomp = + let rec decrec acc c = match kind_of_term c with + | App (f,l) -> decrec (Array.fold_right (fun a l -> a::l) l acc) f + | Cast (c1,_,_) -> decrec acc c1 + | _ -> (c,acc) + in + decrec [] + + let constr_val_discr t = + let c, l = decomp t in + match kind_of_term c with + | Ind (ind_sp,_) -> Dn.Label(Term_dn.GRLabel (IndRef ind_sp),l) + | Construct (cstr_sp,_) -> Dn.Label(Term_dn.GRLabel (ConstructRef cstr_sp),l) + | Var id -> Dn.Label(Term_dn.GRLabel (VarRef id),l) + | Const _ -> Dn.Everything + | _ -> Dn.Nothing + +let lookup dn valu = + let hkey = + match (constr_val_discr valu) with + | Dn.Label(l,_) -> Some l + | _ -> None + in + try Bounded_net.lookup None (Gmap.find hkey dn.patterns) valu with Not_found -> [] + +let app f dn = Gmap.iter f dn.table + +let dnet_depth = Btermdn.dnet_depth + +let freeze dn = (dn.table, dn.patterns) + +let unfreeze (fnm,fdnm) dn = + dn.table <- fnm; + dn.patterns <- fdnm + +let empty dn = + dn.table <- Gmap.empty; + dn.patterns <- Gmap.empty + +let to2lists dn = + (Gmap.to_list dn.table, Gmap.to_list dn.patterns) +end diff --git a/tactics/rewrite.ml b/tactics/rewrite.ml index ae73d7a41..83cb15f47 100644 --- a/tactics/rewrite.ml +++ b/tactics/rewrite.ml @@ -8,6 +8,8 @@ (*i camlp4deps: "grammar/grammar.cma" i*) +open Names +open Pp open Errors open Util open Nameops @@ -32,91 +34,86 @@ open Decl_kinds open Elimschemes open Goal open Environ -open Pp -open Names open Tacinterp open Termops +open Genarg +open Extraargs +open Pcoq.Constr open Entries open Libnames +open Evarutil (** Typeclass-based generalized rewriting. *) (** Constants used by the tactic. *) let classes_dirpath = - DirPath.make (List.map Id.of_string ["Classes";"Coq"]) + Names.DirPath.make (List.map Id.of_string ["Classes";"Coq"]) let init_setoid () = if is_dirpath_prefix_of classes_dirpath (Lib.cwd ()) then () else Coqlib.check_required_library ["Coq";"Setoids";"Setoid"] -let get_class str = - let qualid = Qualid (Loc.ghost, qualid_of_string str) in - lazy (class_info (Nametab.global qualid)) - -let proper_class = get_class "Coq.Classes.Morphisms.Proper" -let proper_proxy_class = get_class "Coq.Classes.Morphisms.ProperProxy" - -let proper_proj = lazy (mkConst (Option.get (pi3 (List.hd (Lazy.force proper_class).cl_projs)))) - let make_dir l = DirPath.make (List.rev_map Id.of_string l) let try_find_global_reference dir s = let sp = Libnames.make_path (make_dir ("Coq"::dir)) (Id.of_string s) in Nametab.global_of_path sp -let try_find_reference dir s = - constr_of_global (try_find_global_reference dir s) +let find_reference dir s = + let gr = lazy (try_find_global_reference dir s) in + fun () -> Lazy.force gr -let gen_constant dir s = Coqlib.gen_constant "rewrite" dir s -let coq_eq = lazy(gen_constant ["Init"; "Logic"] "eq") -let coq_f_equal = lazy (gen_constant ["Init"; "Logic"] "f_equal") -let coq_all = lazy (gen_constant ["Init"; "Logic"] "all") -let coq_forall = lazy (gen_constant ["Classes"; "Morphisms"] "forall_def") -let impl = lazy (gen_constant ["Program"; "Basics"] "impl") -let arrow = lazy (gen_constant ["Program"; "Basics"] "arrow") +type evars = evar_map * Evar.Set.t (* goal evars, constraint evars *) -let reflexive_type = lazy (try_find_reference ["Classes"; "RelationClasses"] "Reflexive") -let reflexive_proof = lazy (try_find_reference ["Classes"; "RelationClasses"] "reflexivity") +let find_global dir s = + let gr = lazy (try_find_global_reference dir s) in + fun (evd,cstrs) -> + let evd, c = Evarutil.new_global evd (Lazy.force gr) in + (evd, cstrs), c -let symmetric_type = lazy (try_find_reference ["Classes"; "RelationClasses"] "Symmetric") -let symmetric_proof = lazy (try_find_reference ["Classes"; "RelationClasses"] "symmetry") +(** Utility for dealing with polymorphic applications *) -let transitive_type = lazy (try_find_reference ["Classes"; "RelationClasses"] "Transitive") -let transitive_proof = lazy (try_find_reference ["Classes"; "RelationClasses"] "transitivity") +let app_poly evars f args = + let evars, fc = f evars in + evars, mkApp (fc, args) -let coq_inverse = lazy (gen_constant ["Program"; "Basics"] "flip") +let e_app_poly evars f args = + let evars', c = app_poly !evars f args in + evars := evars'; + c -let inverse car rel = mkApp (Lazy.force coq_inverse, [| car ; car; mkProp; rel |]) +(** Global constants. *) -let forall_relation = lazy (gen_constant ["Classes"; "Morphisms"] "forall_relation") -let pointwise_relation = lazy (gen_constant ["Classes"; "Morphisms"] "pointwise_relation") -let respectful = lazy (gen_constant ["Classes"; "Morphisms"] "respectful") -let default_relation = lazy (gen_constant ["Classes"; "SetoidTactics"] "DefaultRelation") -let subrelation = lazy (gen_constant ["Classes"; "RelationClasses"] "subrelation") -let do_subrelation = lazy (gen_constant ["Classes"; "Morphisms"] "do_subrelation") -let apply_subrelation = lazy (gen_constant ["Classes"; "Morphisms"] "apply_subrelation") -let coq_relation = lazy (gen_constant ["Relations";"Relation_Definitions"] "relation") -let mk_relation a = mkApp (Lazy.force coq_relation, [| a |]) -let rewrite_relation_class = lazy (gen_constant ["Classes"; "RelationClasses"] "RewriteRelation") +let gen_reference dir s = Coqlib.gen_reference "rewrite" dir s +let coq_eq_ref = find_reference ["Init"; "Logic"] "eq" +let coq_eq = find_global ["Init"; "Logic"] "eq" +let coq_f_equal = find_global ["Init"; "Logic"] "f_equal" +let coq_all = find_global ["Init"; "Logic"] "all" +let impl = find_global ["Program"; "Basics"] "impl" +let arrow = find_global ["Program"; "Basics"] "arrow" +let coq_inverse = find_global ["Program"; "Basics"] "flip" -let proper_type = lazy (constr_of_global (Lazy.force proper_class).cl_impl) -let proper_proxy_type = lazy (constr_of_global (Lazy.force proper_proxy_class).cl_impl) +(* let coq_inverse = lazy (gen_constant ["Program"; "Basics"] "flip") *) -(** Utility functions *) +(* let inverse car rel = mkApp (Lazy.force coq_inverse, [| car ; car; mkProp; rel |]) *) -let split_head = function - hd :: tl -> hd, tl - | [] -> assert(false) +(* let forall_relation = lazy (gen_constant ["Classes"; "Morphisms"] "forall_relation") *) +(* let pointwise_relation = lazy (gen_constant ["Classes"; "Morphisms"] "pointwise_relation") *) +(* let respectful = lazy (gen_constant ["Classes"; "Morphisms"] "respectful") *) +(* let default_relation = lazy (gen_constant ["Classes"; "SetoidTactics"] "DefaultRelation") *) +(* let subrelation = lazy (gen_constant ["Classes"; "RelationClasses"] "subrelation") *) +(* let do_subrelation = lazy (gen_constant ["Classes"; "Morphisms"] "do_subrelation") *) +(* let apply_subrelation = lazy (gen_constant ["Classes"; "Morphisms"] "apply_subrelation") *) +(* let coq_relation = lazy (gen_constant ["Relations";"Relation_Definitions"] "relation") *) +(* let mk_relation a = mkApp (Lazy.force coq_relation, [| a |]) *) -let evd_convertible env evd x y = - try ignore(Evarconv.the_conv_x env x y evd); true - with e when Errors.noncritical e -> false +(* let proper_type = lazy (Universes.constr_of_global (Lazy.force proper_class).cl_impl) *) +(* let proper_proxy_type = lazy (Universes.constr_of_global (Lazy.force proper_proxy_class).cl_impl) *) -let convertible env evd x y = - Reductionops.is_conv env evd x y -(** Bookkeeping which evars are constraints so that we can + +(** Bookkeeping which evars are constraints so that we can remove them at the end of the tactic. *) let goalevars evars = fst evars @@ -127,10 +124,17 @@ let new_cstr_evar (evd,cstrs) env t = (evd', Evar.Set.add (fst (destEvar t)) cstrs), t (** Building or looking up instances. *) +let e_new_cstr_evar evars env t = + let evd', t = new_cstr_evar !evars env t in evars := evd'; t + +let new_goal_evar (evd,cstrs) env t = + let evd', t = Evarutil.new_evar evd env t in + (evd', cstrs), t + +let e_new_goal_evar evars env t = + let evd', t = new_goal_evar !evars env t in evars := evd'; t -let proper_proof env evars carrier relation x = - let goal = mkApp (Lazy.force proper_proxy_type, [| carrier ; relation; x |]) - in new_cstr_evar evars env goal +(** Building or looking up instances. *) let extends_undefined evars evars' = let f ev evi found = found || not (Evd.mem evars ev) @@ -138,95 +142,328 @@ let extends_undefined evars evars' = let find_class_proof proof_type proof_method env evars carrier relation = try - let goal = mkApp (Lazy.force proof_type, [| carrier ; relation |]) in - let evars', c = Typeclasses.resolve_one_typeclass env evars goal in - if extends_undefined evars evars' then raise Not_found - else mkApp (Lazy.force proof_method, [| carrier; relation; c |]) + let evars, goal = app_poly evars proof_type [| carrier ; relation |] in + let evars', c = Typeclasses.resolve_one_typeclass env (goalevars evars) goal in + if extends_undefined (goalevars evars) evars' then raise Not_found + else app_poly (evars',cstrevars evars) proof_method [| carrier; relation; c |] with e when Logic.catchable_exception e -> raise Not_found + +(** Utility functions *) -let get_reflexive_proof env = find_class_proof reflexive_type reflexive_proof env -let get_symmetric_proof env = find_class_proof symmetric_type symmetric_proof env -let get_transitive_proof env = find_class_proof transitive_type transitive_proof env - -(** Build an infered signature from constraints on the arguments and expected output - relation *) - -let build_signature evars env m (cstrs : (types * types option) option list) - (finalcstr : (types * types option) option) = - let mk_relty evars newenv ty obj = - match obj with +module GlobalBindings (M : sig + val relation_classes : string list + val morphisms : string list + val relation : string list * string +end) = struct + open M + let relation : evars -> evars * constr = find_global (fst relation) (snd relation) + + let reflexive_type = find_global relation_classes "Reflexive" + let reflexive_proof = find_global relation_classes "reflexivity" + + let symmetric_type = find_global relation_classes "Symmetric" + let symmetric_proof = find_global relation_classes "symmetry" + + let transitive_type = find_global relation_classes "Transitive" + let transitive_proof = find_global relation_classes "transitivity" + + let forall_relation = find_global morphisms "forall_relation" + let pointwise_relation = find_global morphisms "pointwise_relation" + + let forall_relation_ref = find_reference morphisms "forall_relation" + let pointwise_relation_ref = find_reference morphisms "pointwise_relation" + + let respectful = find_global morphisms "respectful" + let respectful_ref = find_reference morphisms "respectful" + + let default_relation = find_global ["Classes"; "SetoidTactics"] "DefaultRelation" + + let coq_forall = find_global morphisms "forall_def" + + let subrelation = find_global relation_classes "subrelation" + let do_subrelation = find_global morphisms "do_subrelation" + let apply_subrelation = find_global morphisms "apply_subrelation" + + let rewrite_relation_class = find_global relation_classes "RewriteRelation" + + let proper_class = lazy (class_info (try_find_global_reference morphisms "Proper")) + let proper_proxy_class = lazy (class_info (try_find_global_reference morphisms "ProperProxy")) + + let proper_proj = lazy (mkConst (Option.get (pi3 (List.hd (Lazy.force proper_class).cl_projs)))) + + let proper_type = + let l = lazy (Lazy.force proper_class).cl_impl in + fun (evd,cstrs) -> + let evd, c = Evarutil.new_global evd (Lazy.force l) in + (evd, cstrs), c + + let proper_proxy_type = + let l = lazy (Lazy.force proper_proxy_class).cl_impl in + fun (evd,cstrs) -> + let evd, c = Evarutil.new_global evd (Lazy.force l) in + (evd, cstrs), c + + let proper_proof env evars carrier relation x = + let evars, goal = app_poly evars proper_proxy_type [| carrier ; relation; x |] in + new_cstr_evar evars env goal + + let get_reflexive_proof env = find_class_proof reflexive_type reflexive_proof env + let get_symmetric_proof env = find_class_proof symmetric_type symmetric_proof env + let get_transitive_proof env = find_class_proof transitive_type transitive_proof env + + let mk_relation evd a = + app_poly evd relation [| a |] + + (** Build an infered signature from constraints on the arguments and expected output + relation *) + + let build_signature evars env m (cstrs : (types * types option) option list) + (finalcstr : (types * types option) option) = + let mk_relty evars newenv ty obj = + match obj with | None | Some (_, None) -> - let relty = mk_relation ty in - if closed0 ty then - let env' = Environ.reset_with_named_context (Environ.named_context_val env) env in - new_cstr_evar evars env' relty - else new_cstr_evar evars newenv relty + let evars, relty = mk_relation evars ty in + if closed0 ty then + let env' = Environ.reset_with_named_context (Environ.named_context_val env) env in + new_cstr_evar evars env' relty + else new_cstr_evar evars newenv relty | Some (x, Some rel) -> evars, rel - in - let rec aux env evars ty l = - let t = Reductionops.whd_betadeltaiota env (fst evars) ty in - match kind_of_term t, l with - | Prod (na, ty, b), obj :: cstrs -> + in + let rec aux env evars ty l = + let t = Reductionops.whd_betadeltaiota env (goalevars evars) ty in + match kind_of_term t, l with + | Prod (na, ty, b), obj :: cstrs -> if noccurn 1 b (* non-dependent product *) then - let ty = Reductionops.nf_betaiota (fst evars) ty in + let ty = Reductionops.nf_betaiota (goalevars evars) ty in let (evars, b', arg, cstrs) = aux env evars (subst1 mkProp b) cstrs in let evars, relty = mk_relty evars env ty obj in - let newarg = mkApp (Lazy.force respectful, [| ty ; b' ; relty ; arg |]) in + let evars, newarg = app_poly evars respectful [| ty ; b' ; relty ; arg |] in evars, mkProd(na, ty, b), newarg, (ty, Some relty) :: cstrs else - let (evars, b, arg, cstrs) = aux (Environ.push_rel (na, None, ty) env) evars b cstrs in - let ty = Reductionops.nf_betaiota (fst evars) ty in + let (evars, b, arg, cstrs) = + aux (Environ.push_rel (na, None, ty) env) evars b cstrs + in + let ty = Reductionops.nf_betaiota (goalevars evars) ty in let pred = mkLambda (na, ty, b) in let liftarg = mkLambda (na, ty, arg) in - let arg' = mkApp (Lazy.force forall_relation, [| ty ; pred ; liftarg |]) in + let evars, arg' = app_poly evars forall_relation [| ty ; pred ; liftarg |] in if Option.is_empty obj then evars, mkProd(na, ty, b), arg', (ty, None) :: cstrs else error "build_signature: no constraint can apply on a dependent argument" - | _, obj :: _ -> anomaly ~label:"build_signature" (Pp.str "not enough products") - | _, [] -> + | _, obj :: _ -> anomaly ~label:"build_signature" (Pp.str "not enough products") + | _, [] -> (match finalcstr with | None | Some (_, None) -> - let t = Reductionops.nf_betaiota (fst evars) ty in - let evars, rel = mk_relty evars env t None in - evars, t, rel, [t, Some rel] + let t = Reductionops.nf_betaiota (fst evars) ty in + let evars, rel = mk_relty evars env t None in + evars, t, rel, [t, Some rel] | Some (t, Some rel) -> evars, t, rel, [t, Some rel]) - in aux env evars m cstrs + in aux env evars m cstrs -type hypinfo = { - cl : clausenv; - ext : Evar.Set.t; (* New evars in this clausenv *) - prf : constr; - car : constr; - rel : constr; - c1 : constr; - c2 : constr; - c : (Tacinterp.interp_sign * Tacexpr.glob_constr_and_expr with_bindings) option; - abs : bool; -} + (** Folding/unfolding of the tactic constants. *) + + let unfold_impl t = + match kind_of_term t with + | App (arrow, [| a; b |])(* when eq_constr arrow (Lazy.force impl) *) -> + mkProd (Anonymous, a, lift 1 b) + | _ -> assert false + + let unfold_all t = + match kind_of_term t with + | App (id, [| a; b |]) (* when eq_constr id (Lazy.force coq_all) *) -> + (match kind_of_term b with + | Lambda (n, ty, b) -> mkProd (n, ty, b) + | _ -> assert false) + | _ -> assert false + + let unfold_forall t = + match kind_of_term t with + | App (id, [| a; b |]) (* when eq_constr id (Lazy.force coq_all) *) -> + (match kind_of_term b with + | Lambda (n, ty, b) -> mkProd (n, ty, b) + | _ -> assert false) + | _ -> assert false + + let arrow_morphism evd ta tb a b = + let ap = is_Prop ta and bp = is_Prop tb in + if ap && bp then app_poly evd impl [| a; b |], unfold_impl + else if ap then (* Domain in Prop, CoDomain in Type *) + (evd, mkProd (Anonymous, a, b)), (fun x -> x) + else if bp then (* Dummy forall *) + (app_poly evd coq_all [| a; mkLambda (Anonymous, a, b) |]), unfold_forall + else (* None in Prop, use arrow *) + (app_poly evd arrow [| a; b |]), unfold_impl + + let rec decomp_pointwise n c = + if Int.equal n 0 then c + else + match kind_of_term c with + | App (f, [| a; b; relb |]) when Globnames.is_global (pointwise_relation_ref ()) f -> + decomp_pointwise (pred n) relb + | App (f, [| a; b; arelb |]) when Globnames.is_global (forall_relation_ref ()) f -> + decomp_pointwise (pred n) (Reductionops.beta_applist (arelb, [mkRel 1])) + | _ -> invalid_arg "decomp_pointwise" + + let rec apply_pointwise rel = function + | arg :: args -> + (match kind_of_term rel with + | App (f, [| a; b; relb |]) when Globnames.is_global (pointwise_relation_ref ()) f -> + apply_pointwise relb args + | App (f, [| a; b; arelb |]) when Globnames.is_global (forall_relation_ref ()) f -> + apply_pointwise (Reductionops.beta_applist (arelb, [arg])) args + | _ -> invalid_arg "apply_pointwise") + | [] -> rel + + let pointwise_or_dep_relation evd n t car rel = + if noccurn 1 car && noccurn 1 rel then + app_poly evd pointwise_relation [| t; lift (-1) car; lift (-1) rel |] + else + app_poly evd forall_relation + [| t; mkLambda (n, t, car); mkLambda (n, t, rel) |] + + let lift_cstr env evars (args : constr list) c ty cstr = + let start evars env car = + match cstr with + | None | Some (_, None) -> + let evars, rel = mk_relation evars car in + new_cstr_evar evars env rel + | Some (ty, Some rel) -> evars, rel + in + let rec aux evars env prod n = + if Int.equal n 0 then start evars env prod + else + match kind_of_term (Reduction.whd_betadeltaiota env prod) with + | Prod (na, ty, b) -> + if noccurn 1 b then + let b' = lift (-1) b in + let evars, rb = aux evars env b' (pred n) in + app_poly evars pointwise_relation [| ty; b'; rb |] + else + let evars, rb = aux evars (Environ.push_rel (na, None, ty) env) b (pred n) in + app_poly evars forall_relation + [| ty; mkLambda (na, ty, b); mkLambda (na, ty, rb) |] + | _ -> raise Not_found + in + let rec find env c ty = function + | [] -> None + | arg :: args -> + try let evars, found = aux evars env ty (succ (List.length args)) in + Some (evars, found, c, ty, arg :: args) + with Not_found -> + find env (mkApp (c, [| arg |])) (prod_applist ty [arg]) args + in find env c ty args + + let unlift_cstr env sigma = function + | None -> None + | Some codom -> Some (decomp_pointwise 1 codom) + +end + +(* let my_type_of env evars c = Typing.e_type_of env evars c *) +(* let mytypeofkey = Profile.declare_profile "my_type_of";; *) +(* let my_type_of = Profile.profile3 mytypeofkey my_type_of *) + + +let type_app_poly env evd f args = + let evars, c = app_poly evd f args in + let evd', t = Typing.e_type_of env (goalevars evars) c in + (evd', cstrevars evars), c + +module PropGlobal = struct + module Consts = + struct + let relation_classes = ["Classes"; "RelationClasses"] + let morphisms = ["Classes"; "Morphisms"] + let relation = ["Relations";"Relation_Definitions"], "relation" + end + + module G = GlobalBindings(Consts) + + include G + include Consts + let inverse env evd car rel = + type_app_poly env evd coq_inverse [| car ; car; mkProp; rel |] + (* app_poly evd coq_inverse [| car ; car; mkProp; rel |] *) + +end + +module TypeGlobal = struct + module Consts = + struct + let relation_classes = ["Classes"; "CRelationClasses"] + let morphisms = ["Classes"; "CMorphisms"] + let relation = relation_classes, "crelation" + end + + module G = GlobalBindings(Consts) + include G + + + let inverse env (evd,cstrs) car rel = + let evd, (sort,_) = Evarutil.new_type_evar Evd.univ_flexible evd env in + app_poly (evd,cstrs) coq_inverse [| car ; car; sort; rel |] + +end + +let sort_of_rel env evm rel = + Reductionops.sort_of_arity env evm (Retyping.get_type_of env evm rel) (** Looking up declared rewrite relations (instances of [RewriteRelation]) *) let is_applied_rewrite_relation env sigma rels t = match kind_of_term t with | App (c, args) when Array.length args >= 2 -> let head = if isApp c then fst (destApp c) else c in - if eq_constr (Lazy.force coq_eq) head then None + if Globnames.is_global (coq_eq_ref ()) head then None else (try let params, args = Array.chop (Array.length args - 2) args in let env' = Environ.push_rel_context rels env in - let evd, evar = Evarutil.new_evar sigma env' (new_Type ()) in - let inst = mkApp (Lazy.force rewrite_relation_class, [| evar; mkApp (c, params) |]) in - let _ = Typeclasses.resolve_one_typeclass env' evd inst in + let evars, (evar, _) = Evarutil.new_type_evar Evd.univ_flexible sigma env' in + let evars, inst = + app_poly (evars,Evar.Set.empty) + TypeGlobal.rewrite_relation_class [| evar; mkApp (c, params) |] in + let _ = Typeclasses.resolve_one_typeclass env' (goalevars evars) inst in Some (it_mkProd_or_LetIn t rels) with e when Errors.noncritical e -> None) | _ -> None -let rec decompose_app_rel env evd t = +(* let _ = *) +(* Hook.set Equality.is_applied_rewrite_relation is_applied_rewrite_relation *) + +let split_head = function + hd :: tl -> hd, tl + | [] -> assert(false) + +let evd_convertible env evd x y = + try ignore(Evarconv.the_conv_x env x y evd); true + with e when Errors.noncritical e -> false + +let convertible env evd x y = + Reductionops.is_conv env evd x y + +type hypinfo = { + cl : clausenv; + prf : constr; + car : constr; + rel : constr; + sort : bool; (* true = Prop; false = Type *) + l2r : bool; + c1 : constr; + c2 : constr; + c : (Tacinterp.interp_sign * Tacexpr.glob_constr_and_expr with_bindings) option; + abs : (constr * types) option; + flags : Unification.unify_flags; +} + +let get_symmetric_proof b = + if b then PropGlobal.get_symmetric_proof else TypeGlobal.get_symmetric_proof + +let rec decompose_app_rel env evd t = match kind_of_term t with - | App (f, args) -> - if Array.length args > 1 then + | App (f, args) -> + if Array.length args > 1 then let fargs, args = Array.chop (Array.length args - 2) args in mkApp (f, fargs), args - else + else let (f', args) = decompose_app_rel env evd args.(0) in let ty = Typing.type_of env evd args.(0) in let f'' = mkLambda (Name (Id.of_string "x"), ty, @@ -235,37 +472,46 @@ let rec decompose_app_rel env evd t = in (f'', args) | _ -> error "The term provided is not an applied relation." -let decompose_applied_relation env sigma orig (c,l) = - let ctype = Typing.type_of env sigma c in +let decompose_applied_relation env origsigma sigma flags orig (c,l) left2right = + let c' = c in + let ctype = Typing.type_of env sigma c' in let find_rel ty = - let eqclause = Clenv.make_clenv_binding_env_apply env sigma None (c, ty) l in + let eqclause = Clenv.make_clenv_binding_env_apply env sigma None (c',ty) l in let (equiv, args) = decompose_app_rel env eqclause.evd (Clenv.clenv_type eqclause) in - let c1 = args.(0) and c2 = args.(1) in + let c1 = args.(0) and c2 = args.(1) in let ty1, ty2 = Typing.type_of env eqclause.evd c1, Typing.type_of env eqclause.evd c2 in if not (evd_convertible env eqclause.evd ty1 ty2) then None else + let sort = sort_of_rel env eqclause.evd equiv in let value = Clenv.clenv_value eqclause in - let ext = Evarutil.evars_of_term value in - Some { cl=eqclause; ext=ext; prf=value; - car=ty1; rel = equiv; c1=c1; c2=c2; c=orig; abs=false; } + let eqclause = { eqclause with evd = Evd.diff eqclause.evd origsigma } in + Some { cl=eqclause; prf=value; + car=ty1; rel = equiv; sort = Sorts.is_prop sort; + l2r=left2right; c1=c1; c2=c2; c=orig; abs=None; + flags = flags } in match find_rel ctype with | Some c -> c | None -> - let ctx,t' = Reductionops.splay_prod_assum env sigma ctype in (* Search for underlying eq *) - match find_rel (it_mkProd_or_LetIn t' ctx) with + let ctx,t' = Reductionops.splay_prod env sigma ctype in (* Search for underlying eq *) + match find_rel (it_mkProd_or_LetIn t' (List.map (fun (n,t) -> n, None, t) ctx)) with | Some c -> c | None -> error "The term does not end with an applied homogeneous relation." -let decompose_applied_relation_expr env sigma (is, (c,l)) = - let sigma, cbl = Tacinterp.interp_open_constr_with_bindings is env sigma (c,l) in - decompose_applied_relation env sigma (Some (is, (c,l))) cbl +let decompose_applied_relation_expr env sigma flags (is, (c,l)) left2right = + let sigma', cbl = Tacinterp.interp_open_constr_with_bindings is env sigma (c,l) in + decompose_applied_relation env sigma sigma' flags (Some (is, (c,l))) cbl left2right + +let rewrite_db = "rewrite" -(** Hint database named "rewrite", now created directly in Auto *) +let conv_transparent_state = (Id.Pred.empty, Cpred.full) -let rewrite_db = Auto.rewrite_db +let _ = + Auto.add_auto_init + (fun () -> + Auto.create_hint_db false rewrite_db conv_transparent_state true) let rewrite_transparent_state () = Auto.Hint_db.transparent_state (Auto.searchtable_map rewrite_db) @@ -288,10 +534,10 @@ let rewrite_unif_flags = { } let rewrite2_unif_flags = - { Unification.modulo_conv_on_closed_terms = Some cst_full_transparent_state; + { Unification.modulo_conv_on_closed_terms = Some conv_transparent_state; Unification.use_metas_eagerly_in_conv_on_closed_terms = true; Unification.modulo_delta = empty_transparent_state; - Unification.modulo_delta_types = cst_full_transparent_state; + Unification.modulo_delta_types = conv_transparent_state; Unification.modulo_delta_in_merge = None; Unification.check_applied_meta_types = true; Unification.resolve_evars = false; @@ -304,7 +550,7 @@ let rewrite2_unif_flags = Unification.allow_K_in_toplevel_higher_order_unification = true } -let general_rewrite_unif_flags () = +let general_rewrite_unif_flags () = let ts = rewrite_transparent_state () in { Unification.modulo_conv_on_closed_terms = Some ts; Unification.use_metas_eagerly_in_conv_on_closed_terms = true; @@ -322,13 +568,14 @@ let general_rewrite_unif_flags () = Unification.allow_K_in_toplevel_higher_order_unification = true } let refresh_hypinfo env sigma hypinfo = - let {c=c} = hypinfo in + if Option.is_empty hypinfo.abs then + let {l2r=l2r; c=c;cl=cl;flags=flags} = hypinfo in match c with | Some c -> (* Refresh the clausenv to not get the same meta twice in the goal. *) - decompose_applied_relation_expr env sigma c + decompose_applied_relation_expr env sigma flags c l2r; | _ -> hypinfo - + else hypinfo let solve_remaining_by by env prf = match by with @@ -336,10 +583,10 @@ let solve_remaining_by by env prf = | Some tac -> let indep = clenv_independent env in let tac = eval_tactic tac in - let evd' = + let evd' = List.fold_right (fun mv evd -> let ty = Clenv.clenv_nf_meta env (meta_type evd mv) in - let c,_ = Pfedit.build_by_tactic env.env ty (Tacticals.New.tclCOMPLETE tac) in + let c,_,_ = Pfedit.build_by_tactic env.env (ty,Univ.ContextSet.empty) (Tacticals.New.tclCOMPLETE tac) in meta_assign mv (c, (Conv,TypeNotProcessed)) evd) indep env.evd in { env with evd = evd' }, prf @@ -352,35 +599,32 @@ let extend_evd sigma ext sigma' = let shrink_evd sigma ext = Evar.Set.fold (fun i acc -> Evd.remove acc i) ext sigma -let no_constraints cstrs = +let no_constraints cstrs = fun ev _ -> not (Evar.Set.mem ev cstrs) -let eq_env x y = x == y +let poly_inverse sort = + if sort then PropGlobal.inverse else TypeGlobal.inverse -let unify_eqn l2r flags env (sigma, cstrs) hypinfo by t = +let unify_eqn env (sigma, cstrs) hypinfo by t = if isEvar t then None else try - let hypinfo = - if hypinfo.abs || eq_env hypinfo.cl.env env then hypinfo - else refresh_hypinfo env sigma hypinfo - in - let {cl=cl; ext=ext; prf=prf; car=car; rel=rel; c1=c1; c2=c2; abs=abs} = - hypinfo in + let {cl=cl; prf=prf; car=car; rel=rel; l2r=l2r; c1=c1; c2=c2; c=c; abs=abs} = + !hypinfo in let left = if l2r then c1 else c2 in - let evd' = Evd.evars_reset_evd ~with_conv_pbs:true sigma cl.evd in - let evd'' = extend_evd evd' ext cl.evd in - let cl = { cl with evd = evd'' } in - let hypinfo, evd', prf, c1, c2, car, rel = - if abs then + let evd' = Evd.merge sigma cl.evd in + let cl = { cl with evd = evd' } in + let evd', prf, c1, c2, car, rel = + match abs with + | Some (absprf, absprfty) -> let env' = clenv_unify ~flags:rewrite_unif_flags CONV left t cl in - hypinfo, env'.evd, prf, c1, c2, car, rel - else - let env' = clenv_unify ~flags CONV left t cl in + env'.evd, prf, c1, c2, car, rel + | None -> + let env' = clenv_unify ~flags:!hypinfo.flags CONV left t cl in let env' = Clenvtac.clenv_pose_dependent_evars true env' in let evd' = Typeclasses.resolve_typeclasses ~filter:(no_constraints cstrs) ~fail:true env'.env env'.evd in let env' = { env' with evd = evd' } in - let env', prf = solve_remaining_by by env' (Clenv.clenv_value env') in + let env', prf = solve_remaining_by by env' (Clenv.clenv_value env') in let nf c = Evarutil.nf_evar env'.evd (Clenv.clenv_nf_meta env' c) in let c1 = nf c1 and c2 = nf c2 and car = nf car and rel = nf rel @@ -388,131 +632,41 @@ let unify_eqn l2r flags env (sigma, cstrs) hypinfo by t = let ty1 = Typing.type_of env'.env env'.evd c1 and ty2 = Typing.type_of env'.env env'.evd c2 in - if convertible env env'.evd ty1 ty2 then + if convertible env env'.evd ty1 ty2 then (if occur_meta_or_existential prf then - let hypinfo = refresh_hypinfo env env'.evd hypinfo in - (hypinfo, env'.evd, prf, c1, c2, car, rel) + (hypinfo := refresh_hypinfo env env'.evd !hypinfo; + env'.evd, prf, c1, c2, car, rel) else (** Evars have been solved, we can go back to the initial evd, but keep the potential refinement of existing evars. *) - let evd' = shrink_evd env'.evd ext in - (hypinfo, evd', prf, c1, c2, car, rel)) + env'.evd, prf, c1, c2, car, rel) else raise Reduction.NotConvertible in - let res = - if l2r then (prf, (car, rel, c1, c2)) + let evars = evd', Evar.Set.empty in + let evd, res = + if l2r then evars, (prf, (car, rel, c1, c2)) else - try (mkApp (get_symmetric_proof env evd' car rel, - [| c1 ; c2 ; prf |]), - (car, rel, c2, c1)) + try + let evars, symprf = get_symmetric_proof !hypinfo.sort env evars car rel in + evars, (mkApp (symprf, [| c1 ; c2 ; prf |]), + (car, rel, c2, c1)) with Not_found -> - (prf, (car, inverse car rel, c2, c1)) - in Some (hypinfo, evd', res) + let evars, rel' = poly_inverse !hypinfo.sort env evars car rel in + evars, (prf, (car, rel', c2, c1)) + in Some (evd, res) with e when Class_tactics.catchable e -> None -let unfold_impl t = - match kind_of_term t with - | App (arrow, [| a; b |])(* when eq_constr arrow (Lazy.force impl) *) -> - mkProd (Anonymous, a, lift 1 b) - | _ -> assert false - -let unfold_all t = - match kind_of_term t with - | App (id, [| a; b |]) (* when eq_constr id (Lazy.force coq_all) *) -> - (match kind_of_term b with - | Lambda (n, ty, b) -> mkProd (n, ty, b) - | _ -> assert false) - | _ -> assert false - -let unfold_forall t = - match kind_of_term t with - | App (id, [| a; b |]) (* when eq_constr id (Lazy.force coq_all) *) -> - (match kind_of_term b with - | Lambda (n, ty, b) -> mkProd (n, ty, b) - | _ -> assert false) - | _ -> assert false - -let arrow_morphism ta tb a b = - let ap = is_Prop ta and bp = is_Prop tb in - if ap && bp then mkApp (Lazy.force impl, [| a; b |]), unfold_impl - else if ap then (* Domain in Prop, CoDomain in Type *) - mkProd (Anonymous, a, b), (fun x -> x) - else if bp then (* Dummy forall *) - mkApp (Lazy.force coq_all, [| a; mkLambda (Anonymous, a, b) |]), unfold_forall - else (* None in Prop, use arrow *) - mkApp (Lazy.force arrow, [| a; b |]), unfold_impl - -let rec decomp_pointwise n c = - if Int.equal n 0 then c - else - match kind_of_term c with - | App (f, [| a; b; relb |]) when eq_constr f (Lazy.force pointwise_relation) -> - decomp_pointwise (pred n) relb - | App (f, [| a; b; arelb |]) when eq_constr f (Lazy.force forall_relation) -> - decomp_pointwise (pred n) (Reductionops.beta_applist (arelb, [mkRel 1])) - | _ -> invalid_arg "decomp_pointwise" - -let rec apply_pointwise rel = function - | arg :: args -> - (match kind_of_term rel with - | App (f, [| a; b; relb |]) when eq_constr f (Lazy.force pointwise_relation) -> - apply_pointwise relb args - | App (f, [| a; b; arelb |]) when eq_constr f (Lazy.force forall_relation) -> - apply_pointwise (Reductionops.beta_applist (arelb, [arg])) args - | _ -> invalid_arg "apply_pointwise") - | [] -> rel - -let pointwise_or_dep_relation n t car rel = - if noccurn 1 car && noccurn 1 rel then - mkApp (Lazy.force pointwise_relation, [| t; lift (-1) car; lift (-1) rel |]) - else - mkApp (Lazy.force forall_relation, - [| t; mkLambda (n, t, car); mkLambda (n, t, rel) |]) - -let lift_cstr env evars (args : constr list) c ty cstr = - let start evars env car = - match cstr with - | None | Some (_, None) -> - new_cstr_evar evars env (mk_relation car) - | Some (ty, Some rel) -> evars, rel - in - let rec aux evars env prod n = - if Int.equal n 0 then start evars env prod - else - match kind_of_term (Reduction.whd_betadeltaiota env prod) with - | Prod (na, ty, b) -> - if noccurn 1 b then - let b' = lift (-1) b in - let evars, rb = aux evars env b' (pred n) in - evars, mkApp (Lazy.force pointwise_relation, [| ty; b'; rb |]) - else - let evars, rb = aux evars (Environ.push_rel (na, None, ty) env) b (pred n) in - evars, mkApp (Lazy.force forall_relation, - [| ty; mkLambda (na, ty, b); mkLambda (na, ty, rb) |]) - | _ -> raise Not_found - in - let rec find env c ty = function - | [] -> None - | arg :: args -> - try let evars, found = aux evars env ty (succ (List.length args)) in - Some (evars, found, c, ty, arg :: args) - with Not_found -> - find env (mkApp (c, [| arg |])) (prod_applist ty [arg]) args - in find env c ty args - -let unlift_cstr env sigma = function - | None -> None - | Some codom -> Some (decomp_pointwise 1 codom) - type rewrite_flags = { under_lambdas : bool; on_morphisms : bool } let default_flags = { under_lambdas = true; on_morphisms = true; } -type evars = evar_map * Evar.Set.t (* goal evars, constraint evars *) - -type rewrite_proof = +type rewrite_proof = | RewPrf of constr * constr | RewCast of cast_kind +let map_rewprf f p = match p with + | RewPrf (x, y) -> RewPrf (f x, f y) + | RewCast _ -> p + let get_opt_rew_rel = function RewPrf (rel, prf) -> Some rel | _ -> None type rewrite_result_info = { @@ -523,34 +677,41 @@ type rewrite_result_info = { rew_evars : evars; } -type 'a rewrite_result = -| Fail -| Same -| Info of 'a +type rewrite_result = rewrite_result_info option -type 'a pure_strategy = 'a -> Environ.env -> Id.t list -> constr -> types -> - constr option -> evars -> 'a * rewrite_result_info rewrite_result +type strategy = Environ.env -> Id.t list -> constr -> types -> + (bool (* prop *) * constr option) -> evars -> rewrite_result option -type strategy = unit pure_strategy +let make_eq () = +(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq ()) +let make_eq_refl () = +(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq_refl ()) + +let get_rew_rel r = match r.rew_prf with + | RewPrf (rel, prf) -> rel + | RewCast c -> mkApp (make_eq (),[| r.rew_car; r.rew_from; r.rew_to |]) let get_rew_prf r = match r.rew_prf with - | RewPrf (rel, prf) -> rel, prf + | RewPrf (rel, prf) -> rel, prf | RewCast c -> - let rel = mkApp (Coqlib.build_coq_eq (), [| r.rew_car |]) in - rel, mkCast (mkApp (Coqlib.build_coq_eq_refl (), [| r.rew_car; r.rew_from |]), + let rel = mkApp (make_eq (), [| r.rew_car |]) in + rel, mkCast (mkApp (make_eq_refl (), [| r.rew_car; r.rew_from |]), c, mkApp (rel, [| r.rew_from; r.rew_to |])) -let resolve_subrelation env avoid car rel prf rel' res = +let poly_subrelation sort = + if sort then PropGlobal.subrelation else TypeGlobal.subrelation + +let resolve_subrelation env avoid car rel sort prf rel' res = if eq_constr rel rel' then res else - let app = mkApp (Lazy.force subrelation, [|car; rel; rel'|]) in - let evars, subrel = new_cstr_evar res.rew_evars env app in + let evars, app = app_poly res.rew_evars (poly_subrelation sort) [|car; rel; rel'|] in + let evars, subrel = new_cstr_evar evars env app in let appsub = mkApp (subrel, [| res.rew_from ; res.rew_to ; prf |]) in { res with rew_prf = RewPrf (rel', appsub); rew_evars = evars } -let resolve_morphism env avoid oldt m ?(fnewt=fun x -> x) args args' cstr evars = +let resolve_morphism env avoid oldt m ?(fnewt=fun x -> x) args args' (b,cstr) evars = let evars, morph_instance, proj, sigargs, m', args, args' = let first = match (Array.findi (fun _ b -> not (Option.is_empty b)) args') with | Some i -> i @@ -559,21 +720,23 @@ let resolve_morphism env avoid oldt m ?(fnewt=fun x -> x) args args' cstr evars let morphargs', morphobjs' = Array.chop first args' in let appm = mkApp(m, morphargs) in let appmtype = Typing.type_of env (goalevars evars) appm in - let cstrs = List.map - (Option.map (fun r -> r.rew_car, get_opt_rew_rel r.rew_prf)) - (Array.to_list morphobjs') + let cstrs = List.map + (Option.map (fun r -> r.rew_car, get_opt_rew_rel r.rew_prf)) + (Array.to_list morphobjs') in (* Desired signature *) - let evars, appmtype', signature, sigargs = - build_signature evars env appmtype cstrs cstr + let evars, appmtype', signature, sigargs = + if b then PropGlobal.build_signature evars env appmtype cstrs cstr + else TypeGlobal.build_signature evars env appmtype cstrs cstr in (* Actual signature found *) let cl_args = [| appmtype' ; signature ; appm |] in - let app = mkApp (Lazy.force proper_type, cl_args) in + let evars, app = app_poly evars (if b then PropGlobal.proper_type else TypeGlobal.proper_type) + cl_args in let env' = Environ.push_named - (Id.of_string "do_subrelation", - Some (Lazy.force do_subrelation), - Lazy.force apply_subrelation) + (Id.of_string "do_subrelation", + Some (snd (app_poly evars PropGlobal.do_subrelation [||])), + snd (app_poly evars PropGlobal.apply_subrelation [||])) env in let evars, morph = new_cstr_evar evars env' app in @@ -589,13 +752,15 @@ let resolve_morphism env avoid oldt m ?(fnewt=fun x -> x) args args' cstr evars and relation = substl subst relation in (match y with | None -> - let evars, proof = proper_proof env evars carrier relation x in + let evars, proof = + (if b then PropGlobal.proper_proof else TypeGlobal.proper_proof) + env evars carrier relation x in [ proof ; x ; x ] @ acc, subst, evars, sigargs, x :: typeargs' | Some r -> - [ snd (get_rew_prf r); r.rew_to; x ] @ acc, subst, evars, + [ snd (get_rew_prf r); r.rew_to; x ] @ acc, subst, evars, sigargs, r.rew_to :: typeargs') | None -> - if not (Option.is_empty y) then + if not (Option.is_empty y) then error "Cannot rewrite the argument of a dependent function"; x :: acc, x :: subst, evars, sigargs, x :: typeargs') ([], [], evars, sigargs, []) args args' @@ -607,66 +772,68 @@ let resolve_morphism env avoid oldt m ?(fnewt=fun x -> x) args args' cstr evars | _ -> assert(false) let apply_constraint env avoid car rel prf cstr res = - match cstr with + match snd cstr with | None -> res - | Some r -> resolve_subrelation env avoid car rel prf r res + | Some r -> resolve_subrelation env avoid car rel (fst cstr) prf r res + +let eq_env x y = x == y -let apply_rule l2r flags by loccs : (hypinfo * int) pure_strategy = +let apply_rule hypinfo by loccs : strategy = let (nowhere_except_in,occs) = convert_occs loccs in let is_occ occ = - if nowhere_except_in - then Int.List.mem occ occs - else not (Int.List.mem occ occs) - in - fun (hypinfo, occ) env avoid t ty cstr evars -> - let unif = unify_eqn l2r flags env evars hypinfo by t in - match unif with - | None -> ((hypinfo, occ), Fail) - | Some (hypinfo, evd', (prf, (car, rel, c1, c2))) -> - let occ = succ occ in - let res = - if not (is_occ occ) then Fail - else if eq_constr t c2 then Same - else - let res = { rew_car = ty; rew_from = c1; - rew_to = c2; rew_prf = RewPrf (rel, prf); - rew_evars = evd', cstrevars evars } - in Info (apply_constraint env avoid car rel prf cstr res) - in - ((hypinfo, occ), res) - -let apply_lemma l2r flags c by loccs : strategy = - fun () env avoid t ty cstr evars -> - let hypinfo = - decompose_applied_relation env (goalevars evars) None c + if nowhere_except_in then List.mem occ occs else not (List.mem occ occs) in + let occ = ref 0 in + fun env avoid t ty cstr evars -> + if not (eq_env !hypinfo.cl.env env) then + hypinfo := refresh_hypinfo env (goalevars evars) !hypinfo; + let unif = unify_eqn env evars hypinfo by t in + if not (Option.is_empty unif) then incr occ; + match unif with + | Some (evars', (prf, (car, rel, c1, c2))) when is_occ !occ -> + begin + if eq_constr t c2 then Some None + else + let res = { rew_car = ty; rew_from = c1; + rew_to = c2; rew_prf = RewPrf (rel, prf); + rew_evars = evars' } + in Some (Some (apply_constraint env avoid car rel prf cstr res)) + end + | _ -> None + +let apply_lemma flags (evm,c) left2right by loccs : strategy = + fun env avoid t ty cstr evars -> + let hypinfo = + let evars' = Evd.merge (goalevars evars) evm in + ref (decompose_applied_relation env (goalevars evars) evars' + flags None c left2right) in - let _, res = apply_rule l2r flags by loccs (hypinfo, 0) env avoid t ty cstr evars in - (), res + apply_rule hypinfo by loccs env avoid t ty cstr evars let make_leibniz_proof c ty r = - let prf = + let evars = ref r.rew_evars in + let prf = match r.rew_prf with - | RewPrf (rel, prf) -> - let rel = mkApp (Lazy.force coq_eq, [| ty |]) in + | RewPrf (rel, prf) -> + let rel = e_app_poly evars coq_eq [| ty |] in let prf = - mkApp (Lazy.force coq_f_equal, + e_app_poly evars coq_f_equal [| r.rew_car; ty; mkLambda (Anonymous, r.rew_car, c); - r.rew_from; r.rew_to; prf |]) + r.rew_from; r.rew_to; prf |] in RewPrf (rel, prf) | RewCast k -> r.rew_prf in - { r with rew_car = ty; + { rew_car = ty; rew_evars = !evars; rew_from = subst1 r.rew_from c; rew_to = subst1 r.rew_to c; rew_prf = prf } let reset_env env = let env' = Global.env_of_context (Environ.named_context_val env) in Environ.push_rel_context (Environ.rel_context env) env' - + let fold_match ?(force=false) env sigma c = let (ci, p, c, brs) = destCase c in let cty = Retyping.get_type_of env sigma c in - let dep, pred, exists, (sk, eff) = + let dep, pred, exists, (sk,eff) = let env', ctx, body = let ctx, pred = decompose_lam_assum p in let env' = Environ.push_rel_context ctx env in @@ -678,7 +845,7 @@ let fold_match ?(force=false) env sigma c = let pred = if dep then p else it_mkProd_or_LetIn (subst1 mkProp body) (List.tl ctx) in - let sk = + let sk = if sortp == InProp then if sortc == InProp then if dep then case_dep_scheme_kind_from_prop @@ -691,7 +858,7 @@ let fold_match ?(force=false) env sigma c = if dep then case_dep_scheme_kind_from_type else case_scheme_kind_from_type) - in + in let exists = Ind_tables.check_scheme sk ci.ci_ind in if exists || force then dep, pred, exists, Ind_tables.find_scheme sk ci.ci_ind @@ -702,108 +869,121 @@ let fold_match ?(force=false) env sigma c = let pars, args = List.chop ci.ci_npar args in let meths = List.map (fun br -> br) (Array.to_list brs) in applist (mkConst sk, pars @ [pred] @ meths @ args @ [c]) - in + in sk, (if exists then env else reset_env env), app, eff let unfold_match env sigma sk app = match kind_of_term app with - | App (f', args) when eq_constr f' (mkConst sk) -> - let v = Environ.constant_value (Global.env ()) sk in + | App (f', args) when eq_constant (fst (destConst f')) sk -> + let v = Environ.constant_value_in (Global.env ()) (sk,Univ.Instance.empty)(*FIXME*) in Reductionops.whd_beta sigma (mkApp (v, args)) | _ -> app let is_rew_cast = function RewCast _ -> true | _ -> false -let coerce env avoid cstr res = +let coerce env avoid cstr res = let rel, prf = get_rew_prf res in apply_constraint env avoid res.rew_car rel prf cstr res -let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = - let rec aux state env avoid t ty cstr evars = +let subterm all flags (s : strategy) : strategy = + let rec aux env avoid t ty (prop, cstr) evars = let cstr' = Option.map (fun c -> (ty, Some c)) cstr in match kind_of_term t with | App (m, args) -> - let rewrite_args state success = - let state, args', evars', progress = + let rewrite_args success = + let args', evars', progress = Array.fold_left - (fun (state, acc, evars, progress) arg -> - if not (Option.is_empty progress) && not all then (state, None :: acc, evars, progress) + (fun (acc, evars, progress) arg -> + if not (Option.is_empty progress) && not all then (None :: acc, evars, progress) else - let state, res = s state env avoid arg (Typing.type_of env (goalevars evars) arg) None evars in + let argty = Typing.type_of env (goalevars evars) arg in + let res = s env avoid arg argty (prop,None) evars in match res with - | Same -> (state, None :: acc, evars, if Option.is_empty progress then Some false else progress) - | Info r -> (state, Some r :: acc, r.rew_evars, Some true) - | Fail -> (state, None :: acc, evars, progress)) - (state, [], evars, success) args + | Some None -> (None :: acc, evars, + if Option.is_empty progress then Some false else progress) + | Some (Some r) -> + (Some r :: acc, r.rew_evars, Some true) + | None -> (None :: acc, evars, progress)) + ([], evars, success) args in - state, match progress with - | None -> Fail - | Some false -> Same + match progress with + | None -> None + | Some false -> Some None | Some true -> let args' = Array.of_list (List.rev args') in if Array.exists - (function - | None -> false + (function + | None -> false | Some r -> not (is_rew_cast r.rew_prf)) args' then - let evars', prf, car, rel, c1, c2 = resolve_morphism env avoid t m args args' cstr' evars' in + let evars', prf, car, rel, c1, c2 = + resolve_morphism env avoid t m args args' (prop, cstr') evars' + in let res = { rew_car = ty; rew_from = c1; rew_to = c2; rew_prf = RewPrf (rel, prf); - rew_evars = evars' } - in Info res - else + rew_evars = evars' } + in Some (Some res) + else let args' = Array.map2 (fun aorig anew -> match anew with None -> aorig - | Some r -> r.rew_to) args args' + | Some r -> r.rew_to) args args' in let res = { rew_car = ty; rew_from = t; rew_to = mkApp (m, args'); rew_prf = RewCast DEFAULTcast; rew_evars = evars' } - in Info res + in Some (Some res) in if flags.on_morphisms then let mty = Typing.type_of env (goalevars evars) m in - let evars, cstr', m, mty, argsl, args = + let evars, cstr', m, mty, argsl, args = let argsl = Array.to_list args in - match lift_cstr env evars argsl m mty None with - | Some (evars, cstr', m, mty, args) -> + let lift = if prop then PropGlobal.lift_cstr else TypeGlobal.lift_cstr in + match lift env evars argsl m mty None with + | Some (evars, cstr', m, mty, args) -> evars, Some cstr', m, mty, args, Array.of_list args | None -> evars, None, m, mty, argsl, args in - let state, m' = s state env avoid m mty cstr' evars in + let m' = s env avoid m mty (prop, cstr') evars in match m' with - | Fail -> rewrite_args state None (* Standard path, try rewrite on arguments *) - | Same -> rewrite_args state (Some false) - | Info r -> + | None -> rewrite_args None (* Standard path, try rewrite on arguments *) + | Some None -> rewrite_args (Some false) + | Some (Some r) -> (* We rewrote the function and get a proof of pointwise rel for the arguments. We just apply it. *) let prf = match r.rew_prf with | RewPrf (rel, prf) -> - RewPrf (apply_pointwise rel argsl, mkApp (prf, args)) + let app = if prop then PropGlobal.apply_pointwise + else TypeGlobal.apply_pointwise + in + RewPrf (app rel argsl, mkApp (prf, args)) | x -> x in let res = { rew_car = prod_appvect r.rew_car args; rew_from = mkApp(r.rew_from, args); rew_to = mkApp(r.rew_to, args); - rew_prf = prf; - rew_evars = r.rew_evars } - in - state, match prf with + rew_prf = prf; rew_evars = r.rew_evars } + in + match prf with | RewPrf (rel, prf) -> - Info (apply_constraint env avoid res.rew_car rel prf cstr res) - | RewCast _ -> Info res - else rewrite_args state None - + Some (Some (apply_constraint env avoid res.rew_car + rel prf (prop,cstr) res)) + | _ -> Some (Some res) + else rewrite_args None + | Prod (n, x, b) when noccurn 1 b -> let b = subst1 mkProp b in - let tx = Typing.type_of env (goalevars evars) x and tb = Typing.type_of env (goalevars evars) b in - let mor, unfold = arrow_morphism tx tb x b in - let state, res = aux state env avoid mor ty cstr evars in - state, (match res with - | Info r -> Info { r with rew_to = unfold r.rew_to } - | Fail | Same -> res) + let tx = Typing.type_of env (goalevars evars) x + and tb = Typing.type_of env (goalevars evars) b in + let arr = if prop then PropGlobal.arrow_morphism + else TypeGlobal.arrow_morphism + in + let (evars', mor), unfold = arr evars tx tb x b in + let res = aux env avoid mor ty (prop,cstr) evars' in + (match res with + | Some (Some r) -> Some (Some { r with rew_to = unfold r.rew_to }) + | _ -> res) (* if x' = None && flags.under_lambdas then *) (* let lam = mkLambda (n, x, b) in *) @@ -821,80 +1001,116 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = | Prod (n, dom, codom) -> let lam = mkLambda (n, dom, codom) in - let app, unfold = + let (evars', app), unfold = if eq_constr ty mkProp then - mkApp (Lazy.force coq_all, [| dom; lam |]), unfold_all - else mkApp (Lazy.force coq_forall, [| dom; lam |]), unfold_forall + (app_poly evars coq_all [| dom; lam |]), TypeGlobal.unfold_all + else + let forall = if prop then PropGlobal.coq_forall else TypeGlobal.coq_forall in + (app_poly evars forall [| dom; lam |]), TypeGlobal.unfold_forall in - let state, res = aux state env avoid app ty cstr evars in - state, (match res with - | Info r -> Info { r with rew_to = unfold r.rew_to } - | Fail | Same -> res) + let res = aux env avoid app ty (prop,cstr) evars' in + (match res with + | Some (Some r) -> Some (Some { r with rew_to = unfold r.rew_to }) + | _ -> res) + +(* TODO: real rewriting under binders: introduce x x' (H : R x x') and rewrite with + H at any occurrence of x. Ask for (R ==> R') for the lambda. Formalize this. + B. Barras' idea is to have a context of relations, of length 1, with Σ for gluing + dependent relations and using projections to get them out. + *) + (* | Lambda (n, t, b) when flags.under_lambdas -> *) + (* let n' = name_app (fun id -> Tactics.fresh_id_in_env avoid id env) n in *) + (* let n'' = name_app (fun id -> Tactics.fresh_id_in_env avoid id env) n' in *) + (* let n''' = name_app (fun id -> Tactics.fresh_id_in_env avoid id env) n'' in *) + (* let rel = new_cstr_evar cstr env (mkApp (Lazy.force coq_relation, [|t|])) in *) + (* let env' = Environ.push_rel_context [(n'',None,lift 2 rel);(n'',None,lift 1 t);(n', None, t)] env in *) + (* let b' = s env' avoid b (Typing.type_of env' (goalevars evars) (lift 2 b)) (unlift_cstr env (goalevars evars) cstr) evars in *) + (* (match b' with *) + (* | Some (Some r) -> *) + (* let prf = match r.rew_prf with *) + (* | RewPrf (rel, prf) -> *) + (* let rel = pointwise_or_dep_relation n' t r.rew_car rel in *) + (* let prf = mkLambda (n', t, prf) in *) + (* RewPrf (rel, prf) *) + (* | x -> x *) + (* in *) + (* Some (Some { r with *) + (* rew_prf = prf; *) + (* rew_car = mkProd (n, t, r.rew_car); *) + (* rew_from = mkLambda(n, t, r.rew_from); *) + (* rew_to = mkLambda (n, t, r.rew_to) }) *) + (* | _ -> b') *) | Lambda (n, t, b) when flags.under_lambdas -> - let n' = name_app (fun id -> Tactics.fresh_id_in_env avoid id env) n in - let env' = Environ.push_rel (n', None, t) env in - let state, b' = s state env' avoid b (Typing.type_of env' (goalevars evars) b) (unlift_cstr env (goalevars evars) cstr) evars in - state, (match b' with - | Info r -> - let prf = match r.rew_prf with - | RewPrf (rel, prf) -> - let rel = pointwise_or_dep_relation n' t r.rew_car rel in - let prf = mkLambda (n', t, prf) in - RewPrf (rel, prf) - | x -> x + let n' = name_app (fun id -> Tactics.fresh_id_in_env avoid id env) n in + let env' = Environ.push_rel (n', None, t) env in + let bty = Typing.type_of env' (goalevars evars) b in + let unlift = if prop then PropGlobal.unlift_cstr else TypeGlobal.unlift_cstr in + let b' = s env' avoid b bty (prop, unlift env evars cstr) evars in + (match b' with + | Some (Some r) -> + let r = match r.rew_prf with + | RewPrf (rel, prf) -> + let point = if prop then PropGlobal.pointwise_or_dep_relation else + TypeGlobal.pointwise_or_dep_relation in - Info { r with - rew_prf = prf; - rew_car = mkProd (n, t, r.rew_car); - rew_from = mkLambda(n, t, r.rew_from); - rew_to = mkLambda (n, t, r.rew_to) } - | Fail | Same -> b') - + let evars, rel = point r.rew_evars n' t r.rew_car rel in + let prf = mkLambda (n', t, prf) in + { r with rew_prf = RewPrf (rel, prf); rew_evars = evars } + | x -> r + in + Some (Some { r with + rew_car = mkProd (n, t, r.rew_car); + rew_from = mkLambda(n, t, r.rew_from); + rew_to = mkLambda (n, t, r.rew_to) }) + | _ -> b') + | Case (ci, p, c, brs) -> - let cty = Typing.type_of env (goalevars evars) c in - let cstr' = Some (mkApp (Lazy.force coq_eq, [| cty |])) in - let state, c' = s state env avoid c cty cstr' evars in - let state, res = - match c' with - | Info r -> - let res = make_leibniz_proof (mkCase (ci, lift 1 p, mkRel 1, Array.map (lift 1) brs)) ty r in - state, Info (coerce env avoid cstr res) - | Same | Fail -> - if Array.for_all (Int.equal 0) ci.ci_cstr_ndecls then - let cstr = Some (mkApp (Lazy.force coq_eq, [| ty |])) in - let state, found, brs' = Array.fold_left - (fun (state, found, acc) br -> - if not (Option.is_empty found) then (state, found, fun x -> lift 1 br :: acc x) - else - let state, res = s state env avoid br ty cstr evars in - match res with - | Info r -> (state, Some r, fun x -> mkRel 1 :: acc x) - | Fail | Same -> (state, None, fun x -> lift 1 br :: acc x)) - (state, None, fun x -> []) brs - in - state, match found with - | Some r -> - let ctxc = mkCase (ci, lift 1 p, lift 1 c, Array.of_list (List.rev (brs' c'))) in - Info (make_leibniz_proof ctxc ty r) - | None -> c' - else - match try Some (fold_match env (goalevars evars) t) with Not_found -> None with - | None -> state, c' - | Some (cst, _, t',_) -> (* eff XXX *) - let state, res = aux state env avoid t' ty cstr evars in - state, match res with - | Info prf -> - Info { prf with - rew_from = t; rew_to = unfold_match env (goalevars evars) cst prf.rew_to } - | x' -> c' - in - state, (match res with - | Info r -> - let rel, prf = get_rew_prf r in - Info (apply_constraint env avoid r.rew_car rel prf cstr r) - | x -> x) - | _ -> state, Fail + let cty = Typing.type_of env (goalevars evars) c in + let evars', eqty = app_poly evars coq_eq [| cty |] in + let cstr' = Some eqty in + let c' = s env avoid c cty (prop, cstr') evars' in + let res = + match c' with + | Some (Some r) -> + let case = mkCase (ci, lift 1 p, mkRel 1, Array.map (lift 1) brs) in + let res = make_leibniz_proof case ty r in + Some (Some (coerce env avoid (prop,cstr) res)) + | x -> + if Array.for_all (Int.equal 0) ci.ci_cstr_ndecls then + let evars', eqty = app_poly evars coq_eq [| ty |] in + let cstr = Some eqty in + let found, brs' = Array.fold_left + (fun (found, acc) br -> + if not (Option.is_empty found) then (found, fun x -> lift 1 br :: acc x) + else + match s env avoid br ty (prop,cstr) evars with + | Some (Some r) -> (Some r, fun x -> mkRel 1 :: acc x) + | _ -> (None, fun x -> lift 1 br :: acc x)) + (None, fun x -> []) brs + in + match found with + | Some r -> + let ctxc = mkCase (ci, lift 1 p, lift 1 c, Array.of_list (List.rev (brs' x))) in + Some (Some (make_leibniz_proof ctxc ty r)) + | None -> x + else + match try Some (fold_match env (goalevars evars) t) with Not_found -> None with + | None -> x + | Some (cst, _, t', eff (*FIXME*)) -> + match aux env avoid t' ty (prop,cstr) evars with + | Some (Some prf) -> + Some (Some { prf with + rew_from = t; + rew_to = unfold_match env (goalevars evars) cst prf.rew_to }) + | x' -> x + in + (match res with + | Some (Some r) -> + let rel, prf = get_rew_prf r in + Some (Some (apply_constraint env avoid r.rew_car rel prf (prop,cstr) r)) + | x -> x) + | _ -> None in aux let all_subterms = subterm true default_flags @@ -903,25 +1119,35 @@ let one_subterm = subterm false default_flags (** Requires transitivity of the rewrite step, if not a reduction. Not tail-recursive. *) -let transitivity state env avoid (res : rewrite_result_info) (next : 'a pure_strategy) : 'a * rewrite_result_info rewrite_result = - let state, res' = next state env avoid res.rew_to res.rew_car (get_opt_rew_rel res.rew_prf) res.rew_evars in - state, match res' with - | Fail -> Fail - | Same -> Info res - | Info res' -> +let transitivity env avoid prop (res : rewrite_result_info) (next : strategy) : + rewrite_result option = + let nextres = + next env avoid res.rew_to res.rew_car + (prop, get_opt_rew_rel res.rew_prf) res.rew_evars + in + match nextres with + | None -> None + | Some None -> Some (Some res) + | Some (Some res') -> match res.rew_prf with - | RewCast c -> Info { res' with rew_from = res.rew_from } + | RewCast c -> Some (Some { res' with rew_from = res.rew_from }) | RewPrf (rew_rel, rew_prf) -> match res'.rew_prf with - | RewCast _ -> Info { res with rew_to = res'.rew_to } + | RewCast _ -> Some (Some ({ res with rew_to = res'.rew_to })) | RewPrf (res'_rel, res'_prf) -> - let prfty = mkApp (Lazy.force transitive_type, [| res.rew_car; rew_rel |]) in - let evars, prf = new_cstr_evar res'.rew_evars env prfty in - let prf = mkApp (prf, [|res.rew_from; res'.rew_from; res'.rew_to; - rew_prf; res'_prf |]) - in Info { res' with rew_from = res.rew_from; - rew_evars = evars; rew_prf = RewPrf (res'_rel, prf) } - + let trans = + if prop then PropGlobal.transitive_type + else TypeGlobal.transitive_type + in + let evars, prfty = + app_poly res'.rew_evars trans [| res.rew_car; rew_rel |] + in + let evars, prf = new_cstr_evar evars env prfty in + let prf = mkApp (prf, [|res.rew_from; res'.rew_from; res'.rew_to; + rew_prf; res'_prf |]) + in Some (Some { res' with rew_from = res.rew_from; + rew_evars = evars; rew_prf = RewPrf (res'_rel, prf) }) + (** Rewriting strategies. Inspired by ELAN's rewriting strategies: @@ -931,103 +1157,129 @@ let transitivity state env avoid (res : rewrite_result_info) (next : 'a pure_str module Strategies = struct - let fail : 'a pure_strategy = - fun s env avoid t ty cstr evars -> (s, Fail) + let fail : strategy = + fun env avoid t ty cstr evars -> None - let id : 'a pure_strategy = - fun s env avoid t ty cstr evars -> (s, Same) + let id : strategy = + fun env avoid t ty cstr evars -> Some None - let refl : 'a pure_strategy = - fun s env avoid t ty cstr evars -> + let refl : strategy = + fun env avoid t ty (prop,cstr) evars -> let evars, rel = match cstr with - | None -> new_cstr_evar evars env (mk_relation ty) + | None -> + let mkr = if prop then PropGlobal.mk_relation else TypeGlobal.mk_relation in + let evars, rty = mkr evars ty in + new_cstr_evar evars env rty | Some r -> evars, r in let evars, proof = - let mty = mkApp (Lazy.force proper_proxy_type, [| ty ; rel; t |]) in + let proxy = + if prop then PropGlobal.proper_proxy_type + else TypeGlobal.proper_proxy_type + in + let evars, mty = app_poly evars proxy [| ty ; rel; t |] in new_cstr_evar evars env mty in - s, Info { rew_car = ty; rew_from = t; rew_to = t; - rew_prf = RewPrf (rel, proof); rew_evars = evars } - - let progress (s : 'a pure_strategy) : 'a pure_strategy = - fun state env avoid t ty cstr evars -> - let state, res = s state env avoid t ty cstr evars in - state, match res with - | Fail -> Fail - | Same -> Fail - | Info _ -> res - - let seq (fst : 'a pure_strategy) (snd : 'a pure_strategy) : 'a pure_strategy = - fun state env avoid t ty cstr evars -> - let state, res = fst state env avoid t ty cstr evars in - match res with - | Fail -> state, Fail - | Same -> snd state env avoid t ty cstr evars - | Info res -> transitivity state env avoid res snd - - let choice fst snd : 'a pure_strategy = - fun state env avoid t ty cstr evars -> - let state, res = fst state env avoid t ty cstr evars in - match res with - | Fail -> snd state env avoid t ty cstr evars - | Same | Info _ -> state, res - - let try_ str : 'a pure_strategy = choice str id - - let fix (f : 'a pure_strategy -> 'a pure_strategy) : 'a pure_strategy = - let rec aux state env avoid t ty cstr evars = - f aux state env avoid t ty cstr evars - in aux - - let any (s : 'a pure_strategy) : 'a pure_strategy = + Some (Some { rew_car = ty; rew_from = t; rew_to = t; + rew_prf = RewPrf (rel, proof); rew_evars = evars }) + + let progress (s : strategy) : strategy = + fun env avoid t ty cstr evars -> + match s env avoid t ty cstr evars with + | None -> None + | Some None -> None + | r -> r + + let seq first snd : strategy = + fun env avoid t ty cstr evars -> + match first env avoid t ty cstr evars with + | None -> None + | Some None -> snd env avoid t ty cstr evars + | Some (Some res) -> transitivity env avoid (fst cstr) res snd + + let choice fst snd : strategy = + fun env avoid t ty cstr evars -> + match fst env avoid t ty cstr evars with + | None -> snd env avoid t ty cstr evars + | res -> res + + let try_ str : strategy = choice str id + + let fix (f : strategy -> strategy) : strategy = + let rec aux env = f (fun env -> aux env) env in aux + + let any (s : strategy) : strategy = fix (fun any -> try_ (seq s any)) - let repeat (s : 'a pure_strategy) : 'a pure_strategy = + let repeat (s : strategy) : strategy = seq s (any s) - let bu (s : 'a pure_strategy) : 'a pure_strategy = + let bu (s : strategy) : strategy = fix (fun s' -> seq (choice (progress (all_subterms s')) s) (try_ s')) - let td (s : 'a pure_strategy) : 'a pure_strategy = + let td (s : strategy) : strategy = fix (fun s' -> seq (choice s (progress (all_subterms s'))) (try_ s')) - let innermost (s : 'a pure_strategy) : 'a pure_strategy = + let innermost (s : strategy) : strategy = fix (fun ins -> choice (one_subterm ins) s) - let outermost (s : 'a pure_strategy) : 'a pure_strategy = + let outermost (s : strategy) : strategy = fix (fun out -> choice s (one_subterm out)) - let lemmas flags cs : 'a pure_strategy = + let lemmas flags cs : strategy = List.fold_left (fun tac (l,l2r,by) -> - choice tac (apply_lemma l2r flags l by AllOccurrences)) + choice tac (apply_lemma flags l l2r by AllOccurrences)) fail cs - let old_hints (db : string) : 'a pure_strategy = + let inj_open hint = + (Evd.from_env ~ctx:hint.Autorewrite.rew_ctx (Global.env()), + (hint.Autorewrite.rew_lemma, NoBindings)) + + let old_hints (db : string) : strategy = let rules = Autorewrite.find_rewrites db in lemmas rewrite_unif_flags - (List.map (fun hint -> ((hint.Autorewrite.rew_lemma, NoBindings), hint.Autorewrite.rew_l2r, hint.Autorewrite.rew_tac)) rules) + (List.map (fun hint -> (inj_open hint, hint.Autorewrite.rew_l2r, + hint.Autorewrite.rew_tac)) rules) - let hints (db : string) : 'a pure_strategy = - fun state env avoid t ty cstr evars -> + let hints (db : string) : strategy = + fun env avoid t ty cstr evars -> let rules = Autorewrite.find_matches db t in - let lemma hint = ((hint.Autorewrite.rew_lemma, NoBindings), hint.Autorewrite.rew_l2r, + let lemma hint = (inj_open hint, hint.Autorewrite.rew_l2r, hint.Autorewrite.rew_tac) in let lems = List.map lemma rules in - lemmas rewrite_unif_flags lems state env avoid t ty cstr evars + lemmas rewrite_unif_flags lems env avoid t ty cstr evars - let reduce (r : Redexpr.red_expr) : 'a pure_strategy = - fun state env avoid t ty cstr evars -> - let rfn, ckind = Redexpr.reduction_of_red_expr env r in + let reduce (r : Redexpr.red_expr) : strategy = + fun env avoid t ty cstr evars -> + let rfn, ckind = Redexpr.reduction_of_red_expr env r in let t' = rfn env (goalevars evars) t in if eq_constr t' t then - state, Same + Some None else - state, Info { rew_car = ty; rew_from = t; rew_to = t'; - rew_prf = RewCast ckind; rew_evars = evars } + Some (Some { rew_car = ty; rew_from = t; rew_to = t'; + rew_prf = RewCast ckind; rew_evars = evars }) + + let fold c : strategy = + fun env avoid t ty cstr evars -> +(* let sigma, (c,_) = Tacinterp.interp_open_constr_with_bindings is env (goalevars evars) c in *) + let sigma, c = Constrintern.interp_open_constr (goalevars evars) env c in + let unfolded = + try Tacred.try_red_product env sigma c + with e when Errors.noncritical e -> + error "fold: the term is not unfoldable !" + in + try + let sigma = Unification.w_unify env sigma CONV ~flags:(Unification.elim_flags ()) + unfolded t in + let c' = Evarutil.nf_evar sigma c in + Some (Some { rew_car = ty; rew_from = t; rew_to = c'; + rew_prf = RewCast DEFAULTcast; + rew_evars = (sigma, snd evars) }) + with e when Errors.noncritical e -> None - let fold_glob c : 'a pure_strategy = - fun state env avoid t ty cstr evars -> + + let fold_glob c : strategy = + fun env avoid t ty cstr evars -> (* let sigma, (c,_) = Tacinterp.interp_open_constr_with_bindings is env (goalevars evars) c in *) let sigma, c = Pretyping.understand_tcc (goalevars evars) env c in let unfolded = @@ -1036,120 +1288,133 @@ module Strategies = error "fold: the term is not unfoldable !" in try - let sigma = Unification.w_unify env sigma CONV ~flags:Unification.elim_flags unfolded t in + let sigma = Unification.w_unify env sigma CONV ~flags:(Unification.elim_flags ()) unfolded t in let c' = Evarutil.nf_evar sigma c in - state, Info { rew_car = ty; rew_from = t; rew_to = c'; + Some (Some { rew_car = ty; rew_from = t; rew_to = c'; rew_prf = RewCast DEFAULTcast; - rew_evars = sigma, cstrevars evars } - with e when Errors.noncritical e -> state, Fail - + rew_evars = (sigma, snd evars) }) + with e when Errors.noncritical e -> None + end (** The strategy for a single rewrite, dealing with occurences. *) -let rewrite_with l2r flags c occs : strategy = - fun () env avoid t ty cstr evars -> +let rewrite_strat flags occs hyp = + let app = apply_rule hyp None occs in + let rec aux () = + Strategies.choice app (subterm true flags (fun env -> aux () env)) + in aux () + +let get_hypinfo_ids {c = opt} = + match opt with + | None -> [] + | Some (is, gc) -> + let avoid = Option.default [] (TacStore.get is.extra f_avoid_ids) in + Id.Map.fold (fun id _ accu -> id :: accu) is.lfun avoid + +let rewrite_with flags c left2right loccs : strategy = + fun env avoid t ty cstr evars -> let gevars = goalevars evars in - let hypinfo = decompose_applied_relation_expr env gevars c in - let (is, _) = c in - let avoid = match TacStore.get is.extra f_avoid_ids with - | None -> avoid - | Some l -> l @ avoid - in - let avoid = Id.Map.fold (fun id _ accu -> id :: accu) is.lfun avoid in - let app = apply_rule l2r flags None occs in - let strat = Strategies.fix (fun aux -> Strategies.choice app (subterm true default_flags aux)) in - let _, res = strat (hypinfo, 0) env avoid t ty cstr (gevars, cstrevars evars) in - ((), res) - -let apply_strategy (s : strategy) env avoid concl cstr evars = - let _, res = - s () env avoid concl (Typing.type_of env (goalevars evars) concl) - (Option.map snd cstr) evars + let hypinfo = ref (decompose_applied_relation_expr env gevars flags c left2right) in + let avoid = get_hypinfo_ids !hypinfo @ avoid in + rewrite_strat default_flags loccs hypinfo env avoid t ty cstr (gevars, cstrevars evars) + +let apply_strategy (s : strategy) env avoid concl (prop, cstr) evars = + let res = + s env avoid concl (Typing.type_of env (goalevars evars) concl) + (prop, Some cstr) evars in match res with - | Fail -> Fail - | Same -> Same - | Info res -> - Info (res.rew_prf, res.rew_evars, res.rew_car, res.rew_from, res.rew_to) + | None -> None + | Some None -> Some None + | Some (Some res) -> + Some (Some (res.rew_prf, res.rew_evars, res.rew_car, res.rew_from, res.rew_to)) -let solve_constraints env evars = +let solve_constraints env (evars,cstrs) = Typeclasses.resolve_typeclasses env ~split:false ~fail:true evars let nf_zeta = Reductionops.clos_norm_flags (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA]) -exception RewriteFailure of std_ppcmds +exception RewriteFailure of Pp.std_ppcmds -type result = (evar_map * constr option * types) rewrite_result +type result = (evar_map * constr option * types) option option let cl_rewrite_clause_aux ?(abs=None) strat env avoid sigma concl is_hyp : result = - let cstr = - let sort = mkProp in - let impl = Lazy.force impl in + let evars = (sigma, Evar.Set.empty) in + let evars, cstr = + let sort = Typing.sort_of env (goalevars evars) concl in + let prop, (evars, arrow) = + if is_prop_sort sort then true, app_poly evars impl [||] + else false, app_poly evars arrow [||] + in match is_hyp with - | None -> (sort, inverse sort impl) - | Some _ -> (sort, impl) + | None -> + let evars, t = poly_inverse prop env evars (mkSort sort) arrow in + evars, (prop, t) + | Some _ -> evars, (prop, arrow) in - let evars = (sigma, Evar.Set.empty) in - let eq = apply_strategy strat env avoid concl (Some cstr) evars in + let eq = apply_strategy strat env avoid concl cstr evars in match eq with - | Fail -> Fail - | Same -> Same - | Info (p, (evars, cstrs), car, oldt, newt) -> - let evars' = solve_constraints env evars in + | Some (Some (p, (evars, cstrs), car, oldt, newt)) -> + let evars' = solve_constraints env (evars, cstrs) in + let p = map_rewprf (fun p -> nf_zeta env evars' (Evarutil.nf_evar evars' p)) p in let newt = Evarutil.nf_evar evars' newt in + let abs = Option.map (fun (x, y) -> + Evarutil.nf_evar evars' x, Evarutil.nf_evar evars' y) abs in let evars = (* Keep only original evars (potentially instantiated) and goal evars, the rest has been defined and substituted already. *) - Evd.fold (fun ev evi acc -> - if Evar.Set.mem ev cstrs then Evd.remove acc ev - else acc) evars' evars' + Evar.Set.fold (fun ev acc -> Evd.remove acc ev) cstrs evars' in - match p with - | RewCast c -> Info (evars, None, newt) - | RewPrf (_, p) -> - let p = nf_zeta env evars' (Evarutil.nf_evar evars' p) in - let term = match abs with - | None -> p - | Some (t, ty) -> - let t = Evarutil.nf_evar evars' t in - let ty = Evarutil.nf_evar evars' ty in - mkApp (mkLambda (Name (Id.of_string "lemma"), ty, p), [| t |]) - in - let proof = match is_hyp with - | None -> term - | Some id -> mkApp (term, [| mkVar id |]) - in - Info (evars, Some proof, newt) - -(** ppedrot: this is a workaround. The current implementation of rewrite leaks - evar maps. We know that we should not produce effects in here, so we reput - them after computing... *) -let tclEFFECT (tac : tactic) : tactic = fun gl -> - let eff = Evd.eval_side_effects gl.sigma in - let gls = tac gl in - let sigma = Evd.emit_side_effects eff (Evd.drop_side_effects gls.sigma) in - { gls with sigma; } - -let cl_rewrite_clause_tac ?abs strat clause gl = - let evartac evd = Refiner.tclEVARS evd in + let res = + match is_hyp with + | Some id -> + (match p with + | RewPrf (rel, p) -> + let term = + match abs with + | None -> p + | Some (t, ty) -> + mkApp (mkLambda (Name (Id.of_string "lemma"), ty, p), [| t |]) + in + Some (evars, Some (mkApp (term, [| mkVar id |])), newt) + | RewCast c -> + Some (evars, None, newt)) + + | None -> + (match p with + | RewPrf (rel, p) -> + (match abs with + | None -> Some (evars, Some p, newt) + | Some (t, ty) -> + let proof = mkApp (mkLambda (Name (Id.of_string "lemma"), ty, p), [| t |]) in + Some (evars, Some proof, newt)) + | RewCast c -> Some (evars, None, newt)) + in Some res + | Some None -> Some None + | None -> None + +let rewrite_refine (evd,c) = + Tacmach.refine c + +let cl_rewrite_clause_tac ?abs strat meta clause gl = + let evartac evd = Refiner.tclEVARS (Evd.clear_metas evd) in let treat res = match res with - | Fail -> tclFAIL 0 (str "Nothing to rewrite") - | Same -> - tclFAIL 0 (str"No progress made") - | Info (undef, p, newt) -> - let tac = + | None -> tclFAIL 0 (str "Nothing to rewrite") + | Some None -> tclIDTAC + | Some (Some (undef, p, newt)) -> + let tac = match clause, p with | Some id, Some p -> cut_replacing id newt (Tacmach.refine p) - | Some id, None -> + | Some id, None -> change_in_hyp None newt (id, InHypTypeOnly) | None, Some p -> let name = next_name_away_with_default "H" Anonymous (pf_ids_of_hyps gl) in tclTHENLAST - (Tacmach.internal_cut_no_check false name newt) + (Tacmach.internal_cut false name newt) (tclTHEN (Tactics.revert [name]) (Tacmach.refine p)) | None, None -> change_in_concl None newt in tclTHEN (evartac undef) tac @@ -1162,7 +1427,7 @@ let cl_rewrite_clause_tac ?abs strat clause gl = | None -> pf_concl gl, None in let sigma = project gl in - let concl = Evarutil.nf_evar sigma concl in + let concl = Evarutil.nf_evar sigma concl in let res = cl_rewrite_clause_aux ?abs strat (pf_env gl) [] sigma concl is_hyp in treat res with @@ -1170,35 +1435,35 @@ let cl_rewrite_clause_tac ?abs strat clause gl = Refiner.tclFAIL 0 (str"Unable to satisfy the rewriting constraints." ++ fnl () ++ Himsg.explain_typeclass_error env e) - in tclEFFECT tac gl + in tac gl let bind_gl_info f = - bind concl (fun c -> bind env (fun v -> bind defs (fun ev -> f c v ev))) + bind concl (fun c -> bind env (fun v -> bind defs (fun ev -> f c v ev))) let new_refine c : Goal.subgoals Goal.sensitive = let refable = Goal.Refinable.make - (fun handle -> Goal.Refinable.constr_of_open_constr handle true c) + (fun handle -> Goal.Refinable.constr_of_open_constr handle true c) in Goal.bind refable Goal.refine -let assert_replacing id newt tac = - let sens = bind_gl_info +let assert_replacing id newt tac = + let sens = bind_gl_info (fun concl env sigma -> - let nc' = + let nc' = Environ.fold_named_context (fun _ (n, b, t as decl) nc' -> if Id.equal n id then (n, b, newt) :: nc' else decl :: nc') env ~init:[] in - let reft = Refinable.make - (fun h -> + let reft = Refinable.make + (fun h -> Goal.bind (Refinable.mkEvar h (Environ.reset_with_named_context (val_of_named_context nc') env) concl) - (fun ev -> + (fun ev -> Goal.bind (Refinable.mkEvar h env newt) (fun ev' -> - let inst = + let inst = fold_named_context (fun _ (n, b, t) inst -> if Id.equal n id then ev' :: inst @@ -1206,34 +1471,32 @@ let assert_replacing id newt tac = env ~init:[] in let (e, args) = destEvar ev in - Goal.return - (mkEvar (e, Array.of_list inst))))) + Goal.return (mkEvar (e, Array.of_list inst))))) in Goal.bind reft Goal.refine) - in Tacticals.New.tclTHEN (Proofview.tclSENSITIVE sens) + in Proofview.tclTHEN (Proofview.tclSENSITIVE sens) (Proofview.tclFOCUS 2 2 tac) -let newfail n s = +let newfail n s = Proofview.tclZERO (Refiner.FailError (n, lazy s)) let cl_rewrite_clause_newtac ?abs strat clause = - let treat (res, is_hyp) = + let treat (res, is_hyp) = match res with - | Fail -> newfail 0 (str "Nothing to rewrite") - | Same -> - newfail 0 (str"No progress made") - | Info res -> + | None -> newfail 0 (str "Nothing to rewrite") + | Some None -> Proofview.tclUNIT () + | Some (Some res) -> match is_hyp, res with | Some id, (undef, Some p, newt) -> assert_replacing id newt (Proofview.tclSENSITIVE (new_refine (undef, p))) - | Some id, (undef, None, newt) -> + | Some id, (undef, None, newt) -> Proofview.tclSENSITIVE (Goal.convert_hyp false (id, None, newt)) | None, (undef, Some p, newt) -> let refable = Goal.Refinable.make - (fun handle -> + (fun handle -> Goal.bind env (fun env -> Goal.bind (Refinable.mkEvar handle env newt) (fun ev -> - Goal.Refinable.constr_of_open_constr handle true + Goal.Refinable.constr_of_open_constr handle true (undef, mkApp (p, [| ev |]))))) in Proofview.tclSENSITIVE (Goal.bind refable Goal.refine) @@ -1248,9 +1511,9 @@ let cl_rewrite_clause_newtac ?abs strat clause = | Some id -> Environ.named_type id env, Some id | None -> concl, None in - try - let res = - cl_rewrite_clause_aux ?abs strat env [] sigma ty is_hyp + try + let res = + cl_rewrite_clause_aux ?abs strat env [] sigma ty is_hyp in return (res, is_hyp) with | TypeClassError (env, (UnsatisfiableConstraints _ as e)) -> @@ -1262,52 +1525,73 @@ let newtactic_init_setoid () = try init_setoid (); Proofview.tclUNIT () with e when Errors.noncritical e -> Proofview.tclZERO e -let tactic_init_setoid () = +let tactic_init_setoid () = init_setoid (); tclIDTAC - + let cl_rewrite_clause_new_strat ?abs strat clause = - Tacticals.New.tclTHEN (newtactic_init_setoid ()) + Proofview.tclTHEN (newtactic_init_setoid ()) (try cl_rewrite_clause_newtac ?abs strat clause with RewriteFailure s -> newfail 0 (str"setoid rewrite failed: " ++ s)) -let cl_rewrite_clause_newtac' l left2right occs clause = - Proofview.tclFOCUS 1 1 - (cl_rewrite_clause_new_strat (rewrite_with left2right rewrite_unif_flags l occs) clause) +(* let cl_rewrite_clause_newtac' l left2right occs clause = *) +(* Proof_global.run_tactic *) +(* (Proofview.tclFOCUS 1 1 *) +(* (cl_rewrite_clause_new_strat (rewrite_with rewrite_unif_flags l left2right occs) clause)) *) let cl_rewrite_clause_strat strat clause = tclTHEN (tactic_init_setoid ()) - (fun gl -> + (fun gl -> + let meta = Evarutil.new_meta() in (* let gl = { gl with sigma = Typeclasses.mark_unresolvables gl.sigma } in *) - try cl_rewrite_clause_tac strat clause gl + try cl_rewrite_clause_tac strat (mkMeta meta) clause gl with RewriteFailure e -> tclFAIL 0 (str"setoid rewrite failed: " ++ e) gl - | Refiner.FailError (n, pp) -> + | Refiner.FailError (n, pp) -> tclFAIL n (str"setoid rewrite failed: " ++ Lazy.force pp) gl) let cl_rewrite_clause l left2right occs clause gl = - cl_rewrite_clause_strat (rewrite_with left2right (general_rewrite_unif_flags ()) l occs) clause gl + cl_rewrite_clause_strat (rewrite_with (general_rewrite_unif_flags ()) l left2right occs) clause gl + +let occurrences_of = function + | n::_ as nl when n < 0 -> (false,List.map abs nl) + | nl -> + if List.exists (fun n -> n < 0) nl then + error "Illegal negative occurrence number."; + (true,nl) + +open Extraargs + +let apply_constr_expr c l2r occs = fun env avoid t ty cstr evars -> + let evd, c = Constrintern.interp_open_constr (goalevars evars) env c in + apply_lemma (general_rewrite_unif_flags ()) (Evd.empty, (c, NoBindings)) + l2r None occs env avoid t ty cstr (evd, cstrevars evars) -let apply_glob_constr c l2r occs = fun () env avoid t ty cstr evars -> +let apply_glob_constr c l2r occs = fun env avoid t ty cstr evars -> let evd, c = (Pretyping.understand_tcc (goalevars evars) env c) in - apply_lemma l2r (general_rewrite_unif_flags ()) (c, NoBindings) - None occs () env avoid t ty cstr (evd, cstrevars evars) + apply_lemma (general_rewrite_unif_flags ()) (Evd.empty, (c, NoBindings)) + l2r None occs env avoid t ty cstr (evd, cstrevars evars) -let interp_glob_constr_list env sigma cl = - let understand sigma (c, _) = - let sigma, c = Pretyping.understand_tcc sigma env c in - (sigma, ((c, NoBindings), true, None)) - in - List.fold_map understand sigma cl +let interp_constr_list env sigma = + List.map (fun c -> + let evd, c = Constrintern.interp_open_constr sigma env c in + (evd, (c, NoBindings)), true, None) + +let interp_glob_constr_list env sigma = + List.map (fun c -> + let evd, c = Pretyping.understand_tcc sigma env c in + (evd, (c, NoBindings)), true, None) -type ('constr,'redexpr) strategy_ast = +(* Syntax for rewriting with strategies *) + +type ('constr,'redexpr) strategy_ast = | StratId | StratFail | StratRefl | StratUnary of string * ('constr,'redexpr) strategy_ast | StratBinary of string * ('constr,'redexpr) strategy_ast * ('constr,'redexpr) strategy_ast | StratConstr of 'constr * bool | StratTerms of 'constr list | StratHints of bool * string - | StratEval of 'redexpr + | StratEval of 'redexpr | StratFold of 'constr let rec map_strategy (f : 'a -> 'a2) (g : 'b -> 'b2) : ('a,'b) strategy_ast -> ('a2,'b2) strategy_ast = function @@ -1324,7 +1608,7 @@ let rec strategy_of_ast = function | StratId -> Strategies.id | StratFail -> Strategies.fail | StratRefl -> Strategies.refl - | StratUnary (f, s) -> + | StratUnary (f, s) -> let s' = strategy_of_ast s in let f' = match f with | "subterms" -> all_subterms @@ -1349,28 +1633,31 @@ let rec strategy_of_ast = function in f' s' t' | StratConstr (c, b) -> apply_glob_constr (fst c) b AllOccurrences | StratHints (old, id) -> if old then Strategies.old_hints id else Strategies.hints id - | StratTerms l -> - (fun () env avoid t ty cstr (evars, cstrs) -> - let evars, cl = interp_glob_constr_list env evars l in - Strategies.lemmas rewrite_unif_flags cl () env avoid t ty cstr (evars, cstrs)) - | StratEval r -> - (fun () env avoid t ty cstr evars -> + | StratTerms l -> + (fun env avoid t ty cstr evars -> + let l' = interp_glob_constr_list env (goalevars evars) (List.map fst l) in + Strategies.lemmas rewrite_unif_flags l' env avoid t ty cstr evars) + | StratEval r -> + (fun env avoid t ty cstr evars -> let (sigma,r_interp) = Tacinterp.interp_redexp env (goalevars evars) r in - Strategies.reduce r_interp () env avoid t ty cstr (sigma,cstrevars evars)) + Strategies.reduce r_interp env avoid t ty cstr (sigma,cstrevars evars)) | StratFold c -> Strategies.fold_glob (fst c) -let mkappc s l = CAppExpl (Loc.ghost,(None,(Libnames.Ident (Loc.ghost,Id.of_string s))),l) +(* By default the strategy for "rewrite_db" is top-down *) + +let mkappc s l = CAppExpl (Loc.ghost,(None,(Libnames.Ident (Loc.ghost,Id.of_string s)),None),l) let declare_an_instance n s args = ((Loc.ghost,Name n), Explicit, - CAppExpl (Loc.ghost, (None, Qualid (Loc.ghost, qualid_of_string s)), + CAppExpl (Loc.ghost, (None, Qualid (Loc.ghost, qualid_of_string s),None), args)) let declare_instance a aeq n s = declare_an_instance n s [a;aeq] let anew_instance global binders instance fields = - new_instance binders instance (Some (CRecord (Loc.ghost,None,fields))) + new_instance (Flags.is_universe_polymorphism ()) + binders instance (Some (CRecord (Loc.ghost,None,fields))) ~global ~generalize:false None let declare_instance_refl global binders a aeq n lemma = @@ -1437,51 +1724,49 @@ let proper_projection r ty = let ctx, inst = decompose_prod_assum ty in let mor, args = destApp inst in let instarg = mkApp (r, rel_vect 0 (List.length ctx)) in - let app = mkApp (Lazy.force proper_proj, + let app = mkApp (Lazy.force PropGlobal.proper_proj, Array.append args [| instarg |]) in it_mkLambda_or_LetIn app ctx let declare_projection n instance_id r = - let ty = Global.type_of_global r in - let c = constr_of_global r in + let c,uctx = Universes.fresh_global_instance (Global.env()) r in + let poly = Global.is_polymorphic r in + let ty = Retyping.get_type_of (Global.env ()) Evd.empty c in let term = proper_projection c ty in - let env = Global.env() in - let typ = Typing.type_of env Evd.empty term in + let typ = Typing.type_of (Global.env ()) Evd.empty term in let ctx, typ = decompose_prod_assum typ in let typ = let n = let rec aux t = match kind_of_term t with - App (f, [| a ; a' ; rel; rel' |]) when eq_constr f (Lazy.force respectful) -> - succ (aux rel') - | _ -> 0 + | App (f, [| a ; a' ; rel; rel' |]) + when Globnames.is_global (PropGlobal.respectful_ref ()) f -> + succ (aux rel') + | _ -> 0 in let init = match kind_of_term typ with - App (f, args) when eq_constr f (Lazy.force respectful) -> + App (f, args) when Globnames.is_global (PropGlobal.respectful_ref ()) f -> mkApp (f, fst (Array.chop (Array.length args - 2) args)) | _ -> typ in aux init in - let ctx,ccl = Reductionops.splay_prod_n env Evd.empty (3 * n) typ + let ctx,ccl = Reductionops.splay_prod_n (Global.env()) Evd.empty (3 * n) typ in it_mkProd_or_LetIn ccl ctx in let typ = it_mkProd_or_LetIn typ ctx in - let cst = - { const_entry_body = Future.from_val (term,Declareops.no_seff); - const_entry_secctx = None; - const_entry_type = Some typ; - const_entry_opaque = false; - const_entry_inline_code = false; - const_entry_feedback = None; - } in - ignore(Declare.declare_constant n (Entries.DefinitionEntry cst, Decl_kinds.IsDefinition Decl_kinds.Definition)) + let cst = + Declare.definition_entry ~types:typ ~poly ~univs:(Univ.ContextSet.to_context uctx) + term + in + ignore(Declare.declare_constant n + (Entries.DefinitionEntry cst, Decl_kinds.IsDefinition Decl_kinds.Definition)) let build_morphism_signature m = let env = Global.env () in - let m = Constrintern.interp_constr Evd.empty env m in - let t = Typing.type_of env Evd.empty m in - let evdref = ref (Evd.empty, Evar.Set.empty) in + let m,ctx = Constrintern.interp_constr Evd.empty env m in + let sigma = Evd.from_env ~ctx env in + let t = Typing.type_of env sigma m in let cstrs = let rec aux t = match kind_of_term t with @@ -1490,21 +1775,19 @@ let build_morphism_signature m = | _ -> [] in aux t in - let evars, t', sig_, cstrs = build_signature !evdref env t cstrs None in - let _ = evdref := evars in + let evars, t', sig_, cstrs = + PropGlobal.build_signature (Evd.empty, Evar.Set.empty) env t cstrs None in + let evd = ref evars in let _ = List.iter (fun (ty, rel) -> Option.iter (fun rel -> - let default = mkApp (Lazy.force default_relation, [| ty; rel |]) in - let evars,c = new_cstr_evar !evdref env default in - evdref := evars) + let default = e_app_poly evd PropGlobal.default_relation [| ty; rel |] in + ignore(e_new_cstr_evar evd env default)) rel) cstrs in - let morph = - mkApp (Lazy.force proper_type, [| t; sig_; m |]) - in - let evd = solve_constraints env (goalevars !evdref) in + let morph = e_app_poly evd PropGlobal.proper_type [| t; sig_; m |] in + let evd = solve_constraints env !evd in let m = Evarutil.nf_evar evd morph in Evarutil.check_evars env Evd.empty evd m; m @@ -1512,12 +1795,10 @@ let default_morphism sign m = let env = Global.env () in let t = Typing.type_of env Evd.empty m in let evars, _, sign, cstrs = - build_signature (Evd.empty, Evar.Set.empty) env t (fst sign) (snd sign) + PropGlobal.build_signature (Evd.empty, Evar.Set.empty) env t (fst sign) (snd sign) in - let morph = - mkApp (Lazy.force proper_type, [| t; sign; m |]) - in - let evars, mor = resolve_one_typeclass env (fst evars) morph in + let evars, morph = app_poly evars PropGlobal.proper_type [| t; sign; m |] in + let evars, mor = resolve_one_typeclass env (goalevars evars) morph in mor, proper_projection mor morph let add_setoid global binders a aeq t n = @@ -1532,6 +1813,7 @@ let add_setoid global binders a aeq t n = (Ident (Loc.ghost,Id.of_string "Equivalence_Symmetric"), mkappc "Seq_sym" [a;aeq;t]); (Ident (Loc.ghost,Id.of_string "Equivalence_Transitive"), mkappc "Seq_trans" [a;aeq;t])]) + let make_tactic name = let open Tacexpr in let loc = Loc.ghost in @@ -1541,39 +1823,50 @@ let make_tactic name = let add_morphism_infer glob m n = init_setoid (); + let poly = Flags.is_universe_polymorphism () in let instance_id = add_suffix n "_Proper" in let instance = build_morphism_signature m in + let ctx = Univ.ContextSet.empty (*FIXME *) in if Lib.is_modtype () then let cst = Declare.declare_constant ~internal:Declare.KernelSilent instance_id - (Entries.ParameterEntry (None,instance,None), Decl_kinds.IsAssumption Decl_kinds.Logical) + (Entries.ParameterEntry + (None,poly,(instance,Univ.UContext.empty),None), + Decl_kinds.IsAssumption Decl_kinds.Logical) in - add_instance (Typeclasses.new_instance (Lazy.force proper_class) None glob (ConstRef cst)); + add_instance (Typeclasses.new_instance + (Lazy.force PropGlobal.proper_class) None glob + poly (ConstRef cst)); declare_projection n instance_id (ConstRef cst) else - let kind = Decl_kinds.Global, Decl_kinds.DefinitionBody Decl_kinds.Instance in + let kind = Decl_kinds.Global, poly, + Decl_kinds.DefinitionBody Decl_kinds.Instance + in let tac = make_tactic "Coq.Classes.SetoidTactics.add_morphism_tactic" in + let hook _ = function + | Globnames.ConstRef cst -> + add_instance (Typeclasses.new_instance + (Lazy.force PropGlobal.proper_class) None + glob poly (ConstRef cst)); + declare_projection n instance_id (ConstRef cst) + | _ -> assert false + in Flags.silently (fun () -> - Lemmas.start_proof instance_id kind instance - (fun _ -> function - Globnames.ConstRef cst -> - add_instance (Typeclasses.new_instance (Lazy.force proper_class) None - glob (ConstRef cst)); - declare_projection n instance_id (ConstRef cst) - | _ -> assert false); + Lemmas.start_proof instance_id kind (instance, ctx) hook; ignore (Pfedit.by (Tacinterp.interp tac))) () let add_morphism glob binders m s n = init_setoid (); + let poly = Flags.is_universe_polymorphism () in let instance_id = add_suffix n "_Proper" in let instance = ((Loc.ghost,Name instance_id), Explicit, CAppExpl (Loc.ghost, - (None, Qualid (Loc.ghost, Libnames.qualid_of_string "Coq.Classes.Morphisms.Proper")), + (None, Qualid (Loc.ghost, Libnames.qualid_of_string "Coq.Classes.Morphisms.Proper"),None), [cHole; s; m])) in let tac = Tacinterp.interp (make_tactic "add_morphism_tactic") in - ignore(new_instance ~global:glob binders instance (Some (CRecord (Loc.ghost,None,[]))) + ignore(new_instance ~global:glob poly binders instance (Some (CRecord (Loc.ghost,None,[]))) ~generalize:false ~tac ~hook:(declare_projection n instance_id) None) (** Bind to "rewrite" too *) @@ -1601,22 +1894,24 @@ let check_evar_map_of_evars_defs evd = check_freemetas_is_empty rebus2 freemetas2 ) metas -let unification_rewrite l2r c1 c2 cl car rel but env = +let unification_rewrite flags l2r c1 c2 cl car rel but gl = + let env = pf_env gl in + let evd = Evd.merge (project gl) cl.evd in let (evd',c') = try (* ~flags:(false,true) to allow to mark occurrences that must not be rewritten simply by replacing them with let-defined definitions in the context *) - Unification.w_unify_to_subterm + Unification.w_unify_to_subterm ~flags:{ rewrite_unif_flags with Unification.resolve_evars = true } env - cl.evd ((if l2r then c1 else c2),but) + evd ((if l2r then c1 else c2),but) with Pretype_errors.PretypeError _ -> (* ~flags:(true,true) to make Ring work (since it really exploits conversion) *) - Unification.w_unify_to_subterm - ~flags:{ rewrite2_unif_flags with Unification.resolve_evars = true } - env cl.evd ((if l2r then c1 else c2),but) + Unification.w_unify_to_subterm + ~flags:{ flags with Unification.resolve_evars = true } + env evd ((if l2r then c1 else c2),but) in let cl' = {cl with evd = evd'} in let cl' = Clenvtac.clenv_pose_dependent_evars true cl' in @@ -1626,51 +1921,60 @@ let unification_rewrite l2r c1 c2 cl car rel but env = and car = nf car and rel = nf rel in check_evar_map_of_evars_defs cl'.evd; let prf = nf (Clenv.clenv_value cl') and prfty = nf (Clenv.clenv_type cl') in - let cl' = { cl' with templval = mk_freelisted prf ; templtyp = mk_freelisted prfty } in - let abs = (prf, prfty) in - abs, {cl=cl'; ext=Evar.Set.empty; prf=(mkRel 1); car=car; rel=rel; - c1=c1; c2=c2; c=None; abs=true; } + let sort = sort_of_rel env evd' (pf_concl gl) in + let cl' = { cl' with templval = mk_freelisted prf ; templtyp = mk_freelisted prfty; + evd = Evd.diff cl'.evd (project gl) } + in + {cl=cl'; prf=(mkRel 1); car=car; rel=rel; l2r=l2r; + c1=c1; c2=c2; c=None; abs=Some (prf, prfty); sort = Sorts.is_prop sort; flags = flags} let get_hyp gl evars (c,l) clause l2r = - let env = pf_env gl in - let hi = decompose_applied_relation env evars None (c,l) in + let flags = rewrite2_unif_flags in + let hi = decompose_applied_relation (pf_env gl) evars evars flags None (c,l) l2r in let but = match clause with - | Some id -> pf_get_hyp_typ gl id + | Some id -> pf_get_hyp_typ gl id | None -> Evarutil.nf_evar evars (pf_concl gl) in - unification_rewrite l2r hi.c1 hi.c2 hi.cl hi.car hi.rel but env + let unif = unification_rewrite flags hi.l2r hi.c1 hi.c2 hi.cl hi.car hi.rel but gl in + { unif with flags = rewrite_unif_flags } let general_rewrite_flags = { under_lambdas = false; on_morphisms = true } +let apply_lemma gl (c,l) cl l2r occs = + let sigma = project gl in + let hypinfo = ref (get_hyp gl sigma (c,l) cl l2r) in + let app = apply_rule hypinfo None occs in + let rec aux () = + Strategies.choice app (subterm true general_rewrite_flags (fun env -> aux () env)) + in !hypinfo, aux () + + +let cl_rewrite_clause_tac abs strat meta cl gl = + cl_rewrite_clause_tac ~abs strat meta cl gl + +(* let rewriteclaustac_key = Profile.declare_profile "cl_rewrite_clause_tac";; *) +(* let cl_rewrite_clause_tac = Profile.profile5 rewriteclaustac_key cl_rewrite_clause_tac *) + let general_s_rewrite cl l2r occs (c,l) ~new_goals gl = - let app = apply_rule l2r rewrite_unif_flags None occs in - let recstrat aux = Strategies.choice app (subterm true general_rewrite_flags aux) in - let substrat = Strategies.fix recstrat in - let abs, hypinfo = get_hyp gl (project gl) (c,l) cl l2r in - let strat () env avoid t ty cstr evars = - let _, res = substrat (hypinfo, 0) env avoid t ty cstr evars in - (), res - in + let meta = Evarutil.new_meta() in + let hypinfo, strat = apply_lemma gl (c,l) cl l2r occs in try - (tclWEAK_PROGRESS + tclWEAK_PROGRESS (tclTHEN - (Refiner.tclEVARS hypinfo.cl.evd) - (cl_rewrite_clause_tac ~abs:(Some abs) strat cl))) gl + (Refiner.tclEVARS (Evd.merge (project gl) hypinfo.cl.evd)) + (cl_rewrite_clause_tac hypinfo.abs strat (mkMeta meta) cl)) gl with RewriteFailure e -> - let {c1=x; c2=y} = hypinfo in + let {l2r=l2r; c1=x; c2=y} = hypinfo in raise (Pretype_errors.PretypeError (pf_env gl,project gl, Pretype_errors.NoOccurrenceFound ((if l2r then x else y), cl))) -open Proofview.Notations - let general_s_rewrite_clause x = + init_setoid (); + fun b occs cl ~new_goals -> match x with - | None -> general_s_rewrite None - | Some id -> general_s_rewrite (Some id) -let general_s_rewrite_clause x y z w ~new_goals = - newtactic_init_setoid () <*> - Proofview.V82.tactic (general_s_rewrite_clause x y z w ~new_goals) + | None -> Proofview.V82.tactic (general_s_rewrite None b occs cl ~new_goals) + | Some id -> Proofview.V82.tactic (general_s_rewrite (Some id) b occs cl ~new_goals) let _ = Hook.set Equality.general_rewrite_clause general_s_rewrite_clause @@ -1682,63 +1986,61 @@ let not_declared env ty rel = let setoid_proof ty fn fallback = Proofview.Goal.enter begin fun gl -> - let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in let concl = Proofview.Goal.concl gl in - Proofview.tclORELSE - begin - try - let rel, args = decompose_app_rel env sigma concl in - let evm = sigma in - let car = pi3 (List.hd (fst (Reduction.dest_prod env (Typing.type_of env evm rel)))) in - fn env evm car rel - with e -> Proofview.tclZERO e - end - begin function - | e -> - Proofview.tclORELSE - fallback - begin function - | Hipattern.NoEquationFound -> - (* spiwack: [Errors.push] here is unlikely to do what - it's intended to, or anything meaningful for that - matter. *) - let e = Errors.push e in - begin match e with - | Not_found -> - let rel, args = decompose_app_rel env sigma concl in - not_declared env ty rel - | _ -> Proofview.tclZERO e - end - | e' -> Proofview.tclZERO e' - end - end + try + let rel, args = decompose_app_rel env sigma concl in + let car = pi3 (List.hd (fst (Reduction.dest_prod env (Typing.type_of env sigma rel)))) in + Proofview.V82.tactic (fn env sigma car rel) + with e when Errors.noncritical e -> + Proofview.tclORELSE fallback (function + | Hipattern.NoEquationFound -> + let e = Errors.push e in + begin match e with + | Not_found -> + let rel, args = decompose_app_rel env sigma concl in + not_declared env ty rel + | _ -> raise e + end + | e -> Proofview.tclZERO e) end +let tac_open ((evm,_), c) tac = + tclTHEN (Refiner.tclEVARS evm) (tac c) + +let poly_proof getp gett env evm car rel = + if Sorts.is_prop (sort_of_rel env evm rel) then + getp env (evm,Evar.Set.empty) car rel + else gett env (evm,Evar.Set.empty) car rel + let setoid_reflexivity = setoid_proof "reflexive" - (fun env evm car rel -> Proofview.V82.tactic (apply (get_reflexive_proof env evm car rel))) + (fun env evm car rel -> + tac_open (poly_proof PropGlobal.get_reflexive_proof TypeGlobal.get_reflexive_proof + env evm car rel) apply) (reflexivity_red true) let setoid_symmetry = setoid_proof "symmetric" - (fun env evm car rel -> Proofview.V82.tactic (apply (get_symmetric_proof env evm car rel))) + (fun env evm car rel -> + tac_open (poly_proof PropGlobal.get_symmetric_proof TypeGlobal.get_symmetric_proof + env evm car rel) apply) (symmetry_red true) let setoid_transitivity c = setoid_proof "transitive" (fun env evm car rel -> - Proofview.V82.tactic begin - let proof = get_transitive_proof env evm car rel in - match c with - | None -> eapply proof - | Some c -> apply_with_bindings (proof,ImplicitBindings [ c ]) - end) + let proof = poly_proof PropGlobal.get_transitive_proof TypeGlobal.get_transitive_proof + env evm car rel in + match c with + | None -> tac_open proof eapply + | Some c -> tac_open proof (fun t -> apply_with_bindings (t,ImplicitBindings [ c ]))) (transitivity_red true c) - + let setoid_symmetry_in id = - Proofview.Goal.enter begin fun gl -> - let ctype = Tacmach.New.of_old (fun gl -> pf_type_of gl (mkVar id)) gl in + Proofview.V82.tactic (fun gl -> + let ctype = pf_type_of gl (mkVar id) in let binders,concl = decompose_prod_assum ctype in let (equiv, args) = decompose_app concl in let rec split_last_two = function @@ -1750,12 +2052,81 @@ let setoid_symmetry_in id = let he,c1,c2 = mkApp (equiv, Array.of_list others),c1,c2 in let new_hyp' = mkApp (he, [| c2 ; c1 |]) in let new_hyp = it_mkProd_or_LetIn new_hyp' binders in - Tacticals.New.tclTHENS (Tactics.cut new_hyp) - [ Proofview.V82.tactic (intro_replacing id); - Tacticals.New.tclTHENLIST [ intros; setoid_symmetry; Proofview.V82.tactic (apply (mkVar id)); Tactics.assumption ] ] - end + tclTHENS (Proofview.V82.of_tactic (Tactics.cut new_hyp)) + [ intro_replacing id; + tclTHENLIST [ Proofview.V82.of_tactic intros; Proofview.V82.of_tactic setoid_symmetry; apply (mkVar id); Proofview.V82.of_tactic Tactics.assumption ] ] + gl) let _ = Hook.set Tactics.setoid_reflexivity setoid_reflexivity let _ = Hook.set Tactics.setoid_symmetry setoid_symmetry let _ = Hook.set Tactics.setoid_symmetry_in setoid_symmetry_in let _ = Hook.set Tactics.setoid_transitivity setoid_transitivity + +let implify id gl = + let (_, b, ctype) = pf_get_hyp gl id in + let binders,concl = decompose_prod_assum ctype in + let evm, ctype' = + match binders with + | (_, None, ty as hd) :: tl when noccurn 1 concl -> + let env = Environ.push_rel_context tl (pf_env gl) in + let sigma = project gl in + let tyhd = Typing.type_of env sigma ty + and tyconcl = Typing.type_of (Environ.push_rel hd env) sigma concl in + let ((sigma,_), app), unfold = + PropGlobal.arrow_morphism (sigma, Evar.Set.empty) tyhd + (subst1 mkProp tyconcl) ty (subst1 mkProp concl) + in + sigma, it_mkProd_or_LetIn app tl + | _ -> project gl, ctype + in tclTHEN (Refiner.tclEVARS evm) (Tacmach.convert_hyp (id, b, ctype')) gl + +let rec fold_matches env sigma c = + map_constr_with_full_binders Environ.push_rel + (fun env c -> + match kind_of_term c with + | Case _ -> + let cst, env, c', _eff = fold_match ~force:true env sigma c in + fold_matches env sigma c' + | _ -> fold_matches env sigma c) + env c + +let fold_match_tac c gl = + let _, _, c', eff = fold_match ~force:true (pf_env gl) (project gl) c in + let gl = { gl with sigma = Evd.emit_side_effects eff gl.sigma } in + change (Some (snd (Patternops.pattern_of_constr (project gl) c))) c' onConcl gl + +let fold_matches_tac c gl = + let c' = fold_matches (pf_env gl) (project gl) c in + (* let gl = { gl with sigma = Evd.emit_side_effects eff gl.sigma } in *) + change (Some (snd (Patternops.pattern_of_constr (project gl) c))) c' onConcl gl + +let myapply id l gl = + let gr = id in + let _, impls = List.hd (Impargs.implicits_of_global gr) in + let env = pf_env gl in + let evars = ref (project gl) in + let evd, ty = fresh_global env !evars gr in + let _ = evars := evd in + let app = + let rec aux ty impls args args' = + match impls, kind_of_term ty with + | Some (_, _, (_, _)) :: impls, Prod (n, t, t') -> + let arg = Evarutil.e_new_evar evars env t in + aux (subst1 arg t') impls args (arg :: args') + | None :: impls, Prod (n, t, t') -> + (match args with + | [] -> + if dependent (mkRel 1) t' then + let arg = Evarutil.e_new_evar evars env t in + aux (subst1 arg t') impls args (arg :: args') + else + let arg = Evarutil.mk_new_meta () in + evars := meta_declare (destMeta arg) t !evars; + aux (subst1 arg t') impls args (arg :: args') + | arg :: args -> + aux (subst1 arg t') impls args (arg :: args')) + | _, _ -> mkApp (Universes.constr_of_global gr, Array.of_list (List.rev args')) + in aux ty impls l [] + in + tclTHEN (Refiner.tclEVARS !evars) (apply app) gl + diff --git a/tactics/rewrite.mli b/tactics/rewrite.mli index e2d9a41d8..9bdfc08d2 100644 --- a/tactics/rewrite.mli +++ b/tactics/rewrite.mli @@ -41,10 +41,6 @@ val cl_rewrite_clause : interp_sign * (glob_constr_and_expr * glob_constr_and_expr bindings) -> bool -> Locus.occurrences -> Id.t option -> tactic -val cl_rewrite_clause_newtac' : - interp_sign * (glob_constr_and_expr * glob_constr_and_expr bindings) -> - bool -> Locus.occurrences -> Id.t option -> unit Proofview.tactic - val is_applied_rewrite_relation : env -> evar_map -> Context.rel_context -> constr -> types option @@ -61,12 +57,6 @@ val add_morphism_infer : bool -> constr_expr -> Id.t -> unit val add_morphism : bool -> local_binder list -> constr_expr -> constr_expr -> Id.t -> unit -val get_reflexive_proof : env -> evar_map -> constr -> constr -> constr - -val get_symmetric_proof : env -> evar_map -> constr -> constr -> constr - -val get_transitive_proof : env -> evar_map -> constr -> constr -> constr - val default_morphism : (types * constr option) option list * (types * types option) option -> constr -> constr * constr diff --git a/tactics/taccoerce.ml b/tactics/taccoerce.ml index 2c1de14ea..95c6b6bfb 100644 --- a/tactics/taccoerce.ml +++ b/tactics/taccoerce.ml @@ -157,7 +157,7 @@ let coerce_to_evaluable_ref env v = else fail () else let ev = match Value.to_constr v with - | Some c when isConst c -> EvalConstRef (destConst c) + | Some c when isConst c -> EvalConstRef (Univ.out_punivs (destConst c)) | Some c when isVar c -> EvalVarRef (destVar c) | _ -> fail () in @@ -213,7 +213,7 @@ let coerce_to_reference env v = let coerce_to_inductive v = match Value.to_constr v with - | Some c when isInd c -> destInd c + | Some c when isInd c -> Univ.out_punivs (destInd c) | _ -> raise (CannotCoerceTo "an inductive type") (* Quantified named or numbered hypothesis or hypothesis in context *) diff --git a/tactics/tacintern.ml b/tactics/tacintern.ml index cd2319c01..fa76b2a94 100644 --- a/tactics/tacintern.ml +++ b/tactics/tacintern.ml @@ -138,12 +138,13 @@ let intern_ltac_variable ist = function let intern_constr_reference strict ist = function | Ident (_,id) as r when not strict && find_hyp id ist -> - GVar (dloc,id), Some (CRef r) + GVar (dloc,id), Some (CRef (r,None)) | Ident (_,id) as r when find_ctxvar id ist -> - GVar (dloc,id), if strict then None else Some (CRef r) + GVar (dloc,id), if strict then None else Some (CRef (r,None)) | r -> let loc,_ as lqid = qualid_of_reference r in - GRef (loc,locate_global_with_alias lqid), if strict then None else Some (CRef r) + GRef (loc,locate_global_with_alias lqid,None), + if strict then None else Some (CRef (r,None)) let intern_move_location ist = function | MoveAfter id -> MoveAfter (intern_hyp_or_metaid ist id) @@ -278,7 +279,7 @@ let intern_induction_arg ist = function | ElimOnIdent (loc,id) -> if !strict_check then (* If in a defined tactic, no intros-until *) - match intern_constr ist (CRef (Ident (dloc,id))) with + match intern_constr ist (CRef (Ident (dloc,id), None)) with | GVar (loc,id),_ -> ElimOnIdent (loc,id) | c -> ElimOnConstr (c,NoBindings) else diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index ecd7fce31..128d8ea87 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -295,6 +295,9 @@ let interp_ident = interp_ident_gen false let interp_fresh_ident = interp_ident_gen true let pf_interp_ident id gl = interp_ident_gen false id (pf_env gl) +let interp_global ist gl gr = + Evd.fresh_global (pf_env gl) (project gl) gr + (* Interprets an optional identifier which must be fresh *) let interp_fresh_name ist env = function | Anonymous -> Anonymous @@ -842,7 +845,7 @@ let interp_induction_arg ist gl arg = if Tactics.is_quantified_hypothesis id gl then ElimOnIdent (loc,id) else - let c = (GVar (loc,id),Some (CRef (Ident (loc,id)))) in + let c = (GVar (loc,id),Some (CRef (Ident (loc,id),None))) in let (sigma,c) = interp_constr ist env sigma c in ElimOnConstr (sigma,(c,NoBindings)) @@ -2104,8 +2107,7 @@ let () = Geninterp.register_interp0 wit_intro_pattern interp; let interp ist gl pat = (project gl, interp_clause ist (pf_env gl) pat) in Geninterp.register_interp0 wit_clause_dft_concl interp; - - let interp ist gl s = (project gl, interp_sort s) in + let interp ist gl s = interp_sort (project gl) s in Geninterp.register_interp0 wit_sort interp let () = @@ -2143,7 +2145,8 @@ let _ = if has_type arg (glbwit wit_tactic) then let tac = out_gen (glbwit wit_tactic) arg in let tac = interp_tactic ist tac in - let prf = Proof.start sigma [env, ty] in + let ctx = Evd.get_universe_context_set sigma in + let prf = Proof.start sigma [env, (ty, ctx)] in let (prf, _) = try Proof.run_tactic env tac prf with Proof_errors.TacticFailure e as src -> diff --git a/tactics/tacsubst.ml b/tactics/tacsubst.ml index 997975196..47fa4f942 100644 --- a/tactics/tacsubst.ml +++ b/tactics/tacsubst.ml @@ -74,7 +74,7 @@ open Printer let subst_global_reference subst = let subst_global ref = let ref',t' = subst_global subst ref in - if not (eq_constr (constr_of_global ref') t') then + if not (eq_constr (Universes.constr_of_global ref') t') then msg_warning (strbrk "The reference " ++ pr_global ref ++ str " is not " ++ str " expanded to \"" ++ pr_lconstr t' ++ str "\", but to " ++ pr_global ref') ; @@ -175,7 +175,7 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with | TacDecomposeAnd c -> TacDecomposeAnd (subst_glob_constr subst c) | TacDecomposeOr c -> TacDecomposeOr (subst_glob_constr subst c) | TacDecompose (l,c) -> - let l = List.map (subst_or_var (subst_inductive subst)) l in + let l = List.map (subst_or_var (subst_ind subst)) l in TacDecompose (l,subst_glob_constr subst c) | TacSpecialize (n,l) -> TacSpecialize (n,subst_glob_with_bindings subst l) | TacLApply c -> TacLApply (subst_glob_constr subst c) diff --git a/tactics/tacticMatching.ml b/tactics/tacticMatching.ml index b11841a65..cb54263bb 100644 --- a/tactics/tacticMatching.ml +++ b/tactics/tacticMatching.ml @@ -232,7 +232,7 @@ module PatternMatching (E:StaticEnvironment) = struct matchings of [term] with the pattern [pat => lhs]. If refresh is true, refreshes the universes of [term]. *) let pattern_match_term refresh pat term lhs = - let term = if refresh then Termops.refresh_universes_strict term else term in +(* let term = if refresh then Termops.refresh_universes_strict term else term in *) match pat with | Term p -> begin diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index bd33e5146..f647ac510 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -145,7 +145,7 @@ let ifOnHyp pred tac1 tac2 id gl = the elimination. *) type branch_args = { - ity : inductive; (* the type we were eliminating on *) + ity : pinductive; (* the type we were eliminating on *) largs : constr list; (* its arguments *) branchnum : int; (* the branch number *) pred : constr; (* the predicate we used *) @@ -185,7 +185,7 @@ let compute_induction_names n = function | Some (loc,_) -> user_err_loc (loc,"",str "Disjunctive/conjunctive introduction pattern expected.") -let compute_construtor_signatures isrec (_,k as ity) = +let compute_construtor_signatures isrec ((_,k as ity),u) = let rec analrec c recargs = match kind_of_term c, recargs with | Prod (_,_,c), recarg::rest -> @@ -214,10 +214,19 @@ let elimination_sort_of_clause = function | None -> elimination_sort_of_goal | Some id -> elimination_sort_of_hyp id + +let pf_with_evars glsev k gls = + let evd, a = glsev gls in + tclTHEN (Refiner.tclEVARS evd) (k a) gls + +let pf_constr_of_global gr k = + pf_with_evars (fun gls -> pf_apply Evd.fresh_global gls gr) k + (* computing the case/elim combinators *) let gl_make_elim ind gl = - Indrec.lookup_eliminator ind (elimination_sort_of_goal gl) + let gr = Indrec.lookup_eliminator (fst ind) (elimination_sort_of_goal gl) in + pf_apply Evd.fresh_global gl gr let gl_make_case_dep ind gl = pf_apply Indrec.build_case_analysis_scheme gl ind true @@ -535,7 +544,8 @@ module New = struct isrec allnames tac predicate ind (c, t) = Proofview.Goal.enter begin fun gl -> let indclause = Tacmach.New.of_old (fun gl -> mk_clenv_from gl (c, t)) gl in - let elim = Tacmach.New.of_old (mk_elim ind) gl in + (** FIXME: evar leak. *) + let sigma, elim = Tacmach.New.of_old (mk_elim ind) gl in (* applying elimination_scheme just a little modified *) let elimclause = Tacmach.New.of_old (fun gls -> mk_clenv_from gls (elim,Tacmach.New.pf_type_of gl elim)) gl in let indmv = @@ -550,7 +560,7 @@ module New = struct | _ -> let name_elim = match kind_of_term elim with - | Const kn -> string_of_con kn + | Const (kn, _) -> string_of_con kn | Var id -> string_of_id id | _ -> "\b" in @@ -559,7 +569,7 @@ module New = struct let elimclause' = clenv_fchain indmv elimclause indclause in let branchsigns = compute_construtor_signatures isrec ind in let brnames = compute_induction_names (Array.length branchsigns) allnames in - let flags = Unification.elim_flags in + let flags = Unification.elim_flags () in let elimclause' = match predicate with | None -> elimclause' @@ -591,9 +601,9 @@ module New = struct Proofview.Goal.enter begin fun gl -> let (ind,t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in let isrec,mkelim = - if (Global.lookup_mind (fst ind)).mind_record - then false,gl_make_case_dep - else true,gl_make_elim + match (Global.lookup_mind (fst (fst ind))).mind_record with + | None -> true,gl_make_elim + | Some _ -> false,gl_make_case_dep in general_elim_then_using mkelim isrec None tac None ind (c, t) end @@ -630,4 +640,12 @@ module New = struct | None -> elimination_sort_of_goal gl | Some id -> elimination_sort_of_hyp id gl + let pf_constr_of_global ref tac = + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + let (sigma, c) = Evd.fresh_global env sigma ref in + Proofview.V82.tclEVARS sigma <*> (tac c) + end + end diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index fcc23df22..cc1528797 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -101,7 +101,7 @@ val onClauseLR : (Id.t option -> tactic) -> clause -> tactic (** {6 Elimination tacticals. } *) type branch_args = { - ity : inductive; (** the type we were eliminating on *) + ity : pinductive; (** the type we were eliminating on *) largs : constr list; (** its arguments *) branchnum : int; (** the branch number *) pred : constr; (** the predicate we used *) @@ -132,6 +132,9 @@ val elimination_sort_of_goal : goal sigma -> sorts_family val elimination_sort_of_hyp : Id.t -> goal sigma -> sorts_family val elimination_sort_of_clause : Id.t option -> goal sigma -> sorts_family +val pf_with_evars : (goal sigma -> Evd.evar_map * 'a) -> ('a -> tactic) -> tactic +val pf_constr_of_global : Globnames.global_reference -> (constr -> tactic) -> tactic + val elim_on_ba : (branch_assumptions -> tactic) -> branch_args -> tactic val case_on_ba : (branch_assumptions -> tactic) -> branch_args -> tactic @@ -237,12 +240,14 @@ module New : sig val case_then_using : intro_pattern_expr located option -> (branch_args -> unit Proofview.tactic) -> - constr option -> inductive -> Term.constr * Term.types -> unit Proofview.tactic + constr option -> pinductive -> Term.constr * Term.types -> unit Proofview.tactic val case_nodep_then_using : intro_pattern_expr located option -> (branch_args -> unit Proofview.tactic) -> - constr option -> inductive -> Term.constr * Term.types -> unit Proofview.tactic + constr option -> pinductive -> Term.constr * Term.types -> unit Proofview.tactic val elim_on_ba : (branch_assumptions -> unit Proofview.tactic) -> branch_args -> unit Proofview.tactic val case_on_ba : (branch_assumptions -> unit Proofview.tactic) -> branch_args -> unit Proofview.tactic + + val pf_constr_of_global : Globnames.global_reference -> (constr -> unit Proofview.tactic) -> unit Proofview.tactic end diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 151c5b2ce..280950600 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -97,7 +97,7 @@ let tactic_infer_flags = { let finish_evar_resolution env initial_sigma (sigma,c) = let sigma = Pretyping.solve_remaining_evars tactic_infer_flags env initial_sigma sigma - in nf_evar sigma c + in Evd.evar_universe_context sigma, nf_evar sigma c (*********************************************) (* Tactics *) @@ -112,7 +112,8 @@ let head_constr_bound t = let _,ccl = decompose_prod_assum t in let hd,args = decompose_app ccl in match kind_of_term hd with - | Const _ | Ind _ | Construct _ | Var _ -> (hd,args) + | Const _ | Ind _ | Construct _ | Var _ -> hd + | Proj (p, _) -> mkConst p | _ -> raise Bound let head_constr c = @@ -128,6 +129,19 @@ let convert_concl = Tacmach.convert_concl let convert_hyp = Tacmach.convert_hyp let thin_body = Tacmach.thin_body +let convert_gen pb x y gl = + try tclEVARS (pf_apply Evd.conversion gl pb x y) gl + with Reduction.NotConvertible -> + tclFAIL_lazy 0 (lazy (str"Not convertible")) + (* Adding more information in this message, even under the lazy, can result in huge *) + (* blowups, time and spacewise... (see autos used in DoubleCyclic.) 2.3s against 15s. *) + (* ++ Printer.pr_constr_env env x ++ *) + (* str" and " ++ Printer.pr_constr_env env y)) *) + gl + +let convert = convert_gen Reduction.CONV +let convert_leq = convert_gen Reduction.CUMUL + let error_clear_dependency env id = function | Evarutil.OccurHypInSimpleClause None -> errorlabstrm "" (pr_id id ++ str " is used in conclusion.") @@ -302,25 +316,54 @@ let reduct_option redfun = function | Some id -> reduct_in_hyp (fst redfun) id | None -> reduct_in_concl (revert_cast redfun) +(** Versions with evars to maintain the unification of universes resulting + from conversions. *) + +let tclWITHEVARS f k gl = + let evm, c' = pf_apply f gl in + tclTHEN (tclEVARS evm) (k c') gl + +let e_reduct_in_concl (redfun,sty) gl = + tclWITHEVARS + (fun env sigma -> redfun env sigma (pf_concl gl)) + (fun c -> convert_concl_no_check c sty) gl + +let e_pf_reduce_decl (redfun : e_reduction_function) where (id,c,ty) env sigma = + match c with + | None -> + if where == InHypValueOnly then + errorlabstrm "" (pr_id id ++ str "has no value."); + let sigma',ty' = redfun env sigma ty in + sigma', (id,None,ty') + | Some b -> + let sigma',b' = if where != InHypTypeOnly then redfun env sigma b else sigma, b in + let sigma',ty' = if where != InHypValueOnly then redfun env sigma ty else sigma', ty in + sigma', (id,Some b',ty') + +let e_reduct_in_hyp redfun (id,where) gl = + tclWITHEVARS + (e_pf_reduce_decl redfun where (pf_get_hyp gl id)) + convert_hyp_no_check gl + (* Now we introduce different instances of the previous tacticals *) let change_and_check cv_pb t env sigma c = - if is_fconv cv_pb env sigma t c then - t - else - errorlabstrm "convert-check-hyp" (str "Not convertible.") + let evd, b = infer_conv ~pb:cv_pb env sigma t c in + if b then evd, t + else + errorlabstrm "convert-check-hyp" (str "Not convertible.") (* Use cumulativity only if changing the conclusion not a subterm *) let change_on_subterm cv_pb t = function | None -> change_and_check cv_pb t | Some occl -> - contextually false occl + e_contextually false occl (fun subst -> change_and_check Reduction.CONV (replace_vars (Id.Map.bindings subst) t)) let change_in_concl occl t = - reduct_in_concl ((change_on_subterm Reduction.CUMUL t occl),DEFAULTcast) + e_reduct_in_concl ((change_on_subterm Reduction.CUMUL t occl),DEFAULTcast) let change_in_hyp occl t id = - with_check (reduct_in_hyp (change_on_subterm Reduction.CONV t occl) id) + with_check (e_reduct_in_hyp (change_on_subterm Reduction.CONV t occl) id) let change_option occl t = function | Some id -> change_in_hyp occl t id @@ -785,7 +828,7 @@ let index_of_ind_arg t = | None -> error "Could not find inductive argument of elimination scheme." in aux None 0 t -let elimination_clause_scheme with_evars ?(flags=elim_flags) i elimclause indclause gl = +let elimination_clause_scheme with_evars ?(flags=elim_flags ()) i elimclause indclause gl = let indmv = (match kind_of_term (nth_arg i elimclause.templval.rebus) with | Meta mv -> mv @@ -830,13 +873,14 @@ let general_elim with_evars c e = let general_case_analysis_in_context with_evars (c,lbindc) gl = let (mind,_) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in let sort = elimination_sort_of_goal gl in - let elim = + let sigma, elim = if occur_term c (pf_concl gl) then pf_apply build_case_analysis_scheme gl mind true sort else pf_apply build_case_analysis_scheme_default gl mind sort in - general_elim with_evars (c,lbindc) - {elimindex = None; elimbody = (elim,NoBindings)} gl + tclTHEN (tclEVARS sigma) + (general_elim with_evars (c,lbindc) + {elimindex = None; elimbody = (elim,NoBindings)}) gl let general_case_analysis with_evars (c,lbindc as cx) = match kind_of_term c with @@ -855,17 +899,22 @@ exception IsRecord let is_record mind = (Global.lookup_mind (fst mind)).mind_record +let find_ind_eliminator ind s gl = + let gr = lookup_eliminator ind s in + let evd, c = pf_apply Evd.fresh_global gl gr in + evd, c + let find_eliminator c gl = - let (ind,t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in - if is_record ind then raise IsRecord; - let c = lookup_eliminator ind (elimination_sort_of_goal gl) in - {elimindex = None; elimbody = (c,NoBindings)} + let ((ind,u),t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in + if is_record ind <> None then raise IsRecord; + let evd, c = find_ind_eliminator ind (elimination_sort_of_goal gl) gl in + evd, {elimindex = None; elimbody = (c,NoBindings)} let default_elim with_evars (c,_ as cx) = Proofview.tclORELSE (Proofview.Goal.enter begin fun gl -> - let elim = Tacmach.New.of_old (find_eliminator c) gl in - Proofview.V82.tactic (general_elim with_evars cx elim) + let evd, elim = Tacmach.New.of_old (find_eliminator c) gl in + Proofview.V82.tactic (tclTHEN (tclEVARS evd) (general_elim with_evars cx elim)) end) begin function | IsRecord -> @@ -902,13 +951,13 @@ let simplest_elim c = default_elim false (c,NoBindings) (e.g. it could replace id:A->B->C by id:C, knowing A/\B) *) -let clenv_fchain_in id ?(flags=elim_flags) mv elimclause hypclause = +let clenv_fchain_in id ?(flags=elim_flags ()) mv elimclause hypclause = try clenv_fchain ~flags mv elimclause hypclause with PretypeError (env,evd,NoOccurrenceFound (op,_)) -> (* Set the hypothesis name in the message *) raise (PretypeError (env,evd,NoOccurrenceFound (op,Some id))) -let elimination_in_clause_scheme with_evars ?(flags=elim_flags) id i elimclause indclause gl = +let elimination_in_clause_scheme with_evars ?(flags=elim_flags ()) id i elimclause indclause gl = let indmv = destMeta (nth_arg i elimclause.templval.rebus) in let hypmv = try match List.remove Int.equal indmv (clenv_independent elimclause) with @@ -933,7 +982,7 @@ type conjunction_status = | DefinedRecord of constant option list | NotADefinedRecordUseScheme of constr -let make_projection sigma params cstr sign elim i n c = +let make_projection env sigma params cstr sign elim i n c u = let elim = match elim with | NotADefinedRecordUseScheme elim -> (* bugs: goes from right to left when i increases! *) @@ -947,24 +996,32 @@ let make_projection sigma params cstr sign elim i n c = && not (isEvar (fst (whd_betaiota_stack sigma t))) then let t = lift (i+1-n) t in - Some (beta_applist (elim,params@[t;branch]),t) + let abselim = beta_applist (elim,params@[t;branch]) in + let c = beta_applist (abselim, [mkApp (c, extended_rel_vect 0 sign)]) in + Some (it_mkLambda_or_LetIn c sign, it_mkProd_or_LetIn t sign) else None | DefinedRecord l -> (* goes from left to right when i increases! *) match List.nth l i with | Some proj -> - let t = Typeops.type_of_constant (Global.env()) proj in let args = extended_rel_vect 0 sign in - Some (beta_applist (mkConst proj,params),prod_applist t (params@[mkApp (c,args)])) + let proj = + if Environ.is_projection proj env then + mkProj (proj, mkApp (c, args)) + else + mkApp (mkConstU (proj,u), Array.append (Array.of_list params) + [|mkApp (c, args)|]) + in + let app = it_mkLambda_or_LetIn proj sign in + let t = Retyping.get_type_of env sigma app in + Some (app, t) | None -> None - in Option.map (fun (abselim,elimt) -> - let c = beta_applist (abselim,[mkApp (c,extended_rel_vect 0 sign)]) in - (it_mkLambda_or_LetIn c sign, it_mkProd_or_LetIn elimt sign)) elim + in elim let descend_in_conjunctions tac exit c gl = try - let (ind,t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in + let ((ind,u),t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in let sign,ccl = decompose_prod_assum t in match match_with_tuple ccl with | Some (_,_,isrec) -> @@ -972,18 +1029,18 @@ let descend_in_conjunctions tac exit c gl = let sort = elimination_sort_of_goal gl in let id = fresh_id [] (Id.of_string "H") gl in let IndType (indf,_) = pf_apply find_rectype gl ccl in - let params = snd (dest_ind_family indf) in + let (_,inst), params = dest_ind_family indf in let cstr = (get_constructors (pf_env gl) indf).(0) in let elim = try DefinedRecord (Recordops.lookup_projections ind) with Not_found -> - let elim = pf_apply build_case_analysis_scheme gl ind false sort in - NotADefinedRecordUseScheme elim in + let elim = pf_apply build_case_analysis_scheme gl (ind,u) false sort in + NotADefinedRecordUseScheme (snd elim) in tclFIRST (List.init n (fun i gl -> - match make_projection (project gl) params cstr sign elim i n c with + match pf_apply make_projection gl params cstr sign elim i n c u with | None -> tclFAIL 0 (mt()) gl - | Some (p,pt) -> + | Some (p,pt) -> tclTHENS (internal_cut id pt) [refine p; (* Might be ill-typed due to forbidden elimination. *) @@ -999,7 +1056,7 @@ let descend_in_conjunctions tac exit c gl = let general_apply with_delta with_destruct with_evars (loc,(c,lbind)) gl0 = let flags = - if with_delta then default_unify_flags else default_no_delta_unify_flags in + if with_delta then default_unify_flags () else default_no_delta_unify_flags () in (* The actual type of the theorem. It will be matched against the goal. If this fails, then the head constant will be unfolded step by step. *) @@ -1094,7 +1151,7 @@ let apply_in_once_main flags innerclause (d,lbind) gl = let apply_in_once sidecond_first with_delta with_destruct with_evars id (loc,(d,lbind)) gl0 = - let flags = if with_delta then elim_flags else elim_no_delta_flags in + let flags = if with_delta then elim_flags () else elim_no_delta_flags () in let t' = pf_get_hyp_typ gl0 id in let innerclause = mk_clenv_from_n gl0 (Some 0) (mkVar id,t') in let rec aux with_destruct c gl = @@ -1144,13 +1201,17 @@ let cut_and_apply c = (* Exact tactics *) (********************************************************************) +(* let convert_leqkey = Profile.declare_profile "convert_leq";; *) +(* let convert_leq = Profile.profile3 convert_leqkey convert_leq *) + +(* let refine_no_checkkey = Profile.declare_profile "refine_no_check";; *) +(* let refine_no_check = Profile.profile2 refine_no_checkkey refine_no_check *) + let exact_check c gl = let concl = (pf_concl gl) in let ct = pf_type_of gl c in - if pf_conv_x_leq gl ct concl then - refine_no_check c gl - else - error "Not an exact proof." + try tclTHEN (convert_leq ct concl) (refine_no_check c) gl + with _ -> error "Not an exact proof." (*FIXME error handling here not the best *) let exact_no_check = refine_no_check let new_exact_no_check c = @@ -1162,8 +1223,8 @@ let vm_cast_no_check c gl = let exact_proof c gl = - let c = Constrintern.interp_casted_constr (project gl) (pf_env gl) c (pf_concl gl) - in refine_no_check c gl + let c,ctx = Constrintern.interp_casted_constr (project gl) (pf_env gl) c (pf_concl gl) + in tclPUSHCONTEXT Evd.univ_flexible ctx (refine_no_check c) gl let assumption = let rec arec gl only_eq = function @@ -1174,12 +1235,12 @@ let assumption = else Tacticals.New.tclZEROMSG (str "No such assumption.") | (id, c, t)::rest -> let concl = Proofview.Goal.concl gl in - let is_same_type = - if only_eq then eq_constr t concl + let sigma = Proofview.Goal.sigma gl in + let (sigma, is_same_type) = + if only_eq then (sigma, eq_constr t concl) else - let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in - is_conv_leq env sigma t concl + infer_conv env sigma t concl in if is_same_type then Proofview.Refine.refine (fun h -> (h, mkVar id)) else arec gl only_eq rest @@ -1233,7 +1294,7 @@ let specialize mopt (c,lbind) g = tclEVARS evd, nf_evar evd c else let clause = pf_apply make_clenv_binding g (c,pf_type_of g c) lbind in - let flags = { default_unify_flags with resolve_evars = true } in + let flags = { (default_unify_flags ()) with resolve_evars = true } in let clause = clenv_unify_meta_types ~flags clause in let (thd,tstack) = whd_nored_stack clause.evd (clenv_value clause) in let nargs = List.length tstack in @@ -1299,14 +1360,20 @@ let constructor_tac with_evars expctdnumopt i lbind = let reduce_to_quantified_ind = Tacmach.New.pf_apply Tacred.reduce_to_quantified_ind gl in - let (mind,redcl) = reduce_to_quantified_ind cl in - let nconstr = - Array.length (snd (Global.lookup_inductive mind)).mind_consnames in - check_number_of_constructors expctdnumopt i nconstr; - let cons = mkConstruct (ith_constructor_of_inductive mind i) in - let apply_tac = Proofview.V82.tactic (general_apply true false with_evars (dloc,(cons,lbind))) in - (Tacticals.New.tclTHENLIST - [Proofview.V82.tactic (convert_concl_no_check redcl DEFAULTcast); intros; apply_tac]) + try (* reduce_to_quantified_ind can raise an exception *) + let (mind,redcl) = reduce_to_quantified_ind cl in + let nconstr = + Array.length (snd (Global.lookup_inductive (fst mind))).mind_consnames in + check_number_of_constructors expctdnumopt i nconstr; + + let sigma, cons = Evd.fresh_constructor_instance + (Proofview.Goal.env gl) (Proofview.Goal.sigma gl) (fst mind, i) in + let cons = mkConstructU cons in + + let apply_tac = Proofview.V82.tactic (general_apply true false with_evars (dloc,(cons,lbind))) in + (Tacticals.New.tclTHENLIST + [Proofview.V82.tactic (tclTHEN (tclEVARS sigma) (convert_concl_no_check redcl DEFAULTcast)); intros; apply_tac]) + with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e end let one_constructor i lbind = constructor_tac false None i lbind @@ -1331,7 +1398,7 @@ let any_constructor with_evars tacopt = in let mind = fst (reduce_to_quantified_ind cl) in let nconstr = - Array.length (snd (Global.lookup_inductive mind)).mind_consnames in + Array.length (snd (Global.lookup_inductive (fst mind))).mind_consnames in if Int.equal nconstr 0 then error "The type has no constructors."; tclANY tac (List.interval 1 nconstr) end @@ -1395,7 +1462,7 @@ let intro_decomp_eq loc b l l' thin tac id = let c = mkVar id in let t = Tacmach.New.pf_type_of gl c in let _,t = Tacmach.New.pf_reduce_to_quantified_ind gl t in - let eq,eq_args = my_find_eq_data_decompose gl t in + let eq,u,eq_args = my_find_eq_data_decompose gl t in let eq_clause = Tacmach.New.pf_apply make_clenv_binding gl (c,t) NoBindings in !intro_decomp_eq_function (fun n -> tac ((dloc,id)::thin) (adjust_intro_patterns n l @ l')) @@ -1406,7 +1473,7 @@ let intro_or_and_pattern loc b ll l' thin tac id = Proofview.Goal.raw_enter begin fun gl -> let c = mkVar id in let t = Tacmach.New.pf_type_of gl c in - let (ind,t) = Tacmach.New.pf_reduce_to_quantified_ind gl t in + let ((ind,u),t) = Tacmach.New.pf_reduce_to_quantified_ind gl t in let nv = mis_constr_nargs ind in let bracketed = b || not (List.is_empty l') in let adjust n l = if bracketed then adjust_intro_patterns n l else l in @@ -1660,14 +1727,14 @@ let generalized_name c t ids cl = function constante dont on aurait pu prendre directement le nom *) named_hd (Global.env()) t Anonymous -let generalize_goal gl i ((occs,c,b),na) cl = +let generalize_goal gl i ((occs,c,b),na) (cl,evd) = let t = pf_type_of gl c in let decls,cl = decompose_prod_n_assum i cl in let dummy_prod = it_mkProd_or_LetIn mkProp decls in - let newdecls,_ = decompose_prod_n_assum i (subst_term c dummy_prod) in - let cl' = subst_closed_term_occ occs c (it_mkProd_or_LetIn cl newdecls) in + let newdecls,_ = decompose_prod_n_assum i (subst_term_gen eq_constr_nounivs c dummy_prod) in + let cl',evd' = subst_closed_term_univs_occ evd occs c (it_mkProd_or_LetIn cl newdecls) in let na = generalized_name c t (pf_ids_of_hyps gl) cl' na in - mkProd_or_LetIn (na,b,t) cl' + mkProd_or_LetIn (na,b,t) cl', evd let generalize_dep ?(with_let=false) c gl = let env = pf_env gl in @@ -1697,18 +1764,23 @@ let generalize_dep ?(with_let=false) c gl = | _ -> None else None in - let cl'' = generalize_goal gl 0 ((AllOccurrences,c,body),Anonymous) cl' in + let cl'',evd = generalize_goal gl 0 ((AllOccurrences,c,body),Anonymous) + (cl',project gl) in let args = instance_from_named_context to_quantify_rev in - tclTHEN - (apply_type cl'' (if Option.is_empty body then c::args else args)) - (thin (List.rev tothin')) + tclTHENLIST + [tclPUSHEVARUNIVCONTEXT (Evd.evar_universe_context evd); + apply_type cl'' (if Option.is_empty body then c::args else args); + thin (List.rev tothin')] gl let generalize_gen_let lconstr gl = - let newcl = - List.fold_right_i (generalize_goal gl) 0 lconstr (pf_concl gl) in - apply_type newcl (List.map_filter (fun ((_,c,b),_) -> - if Option.is_empty b then Some c else None) lconstr) gl + let newcl, evd = + List.fold_right_i (generalize_goal gl) 0 lconstr + (pf_concl gl,project gl) + in + tclTHEN (tclPUSHEVARUNIVCONTEXT (Evd.evar_universe_context evd)) + (apply_type newcl (List.map_filter (fun ((_,c,b),_) -> + if Option.is_empty b then Some c else None) lconstr)) gl let generalize_gen lconstr = generalize_gen_let (List.map (fun ((occs,c),na) -> @@ -1804,19 +1876,30 @@ let default_matching_flags sigma = { let make_pattern_test env sigma0 (sigma,c) = let flags = default_matching_flags sigma0 in - let matching_fun t = - try let sigma = w_unify env sigma Reduction.CONV ~flags c t in Some(sigma,t) + let matching_fun _ t = + try let sigma = w_unify env sigma Reduction.CONV ~flags c t in + Some(sigma, t) with e when Errors.noncritical e -> raise NotUnifiable in let merge_fun c1 c2 = match c1, c2 with - | Some (_,c1), Some (_,c2) when not (is_fconv Reduction.CONV env sigma0 c1 c2) -> - raise NotUnifiable - | _ -> c1 in + | Some (evd,c1), Some (_,c2) -> + (try let evd = w_unify env evd Reduction.CONV ~flags c1 c2 in + Some (evd, c1) + with e when Errors.noncritical e -> raise NotUnifiable) + | Some _, None -> c1 + | None, Some _ -> c2 + | None, None -> None + in { match_fun = matching_fun; merge_fun = merge_fun; testing_state = None; last_found = None }, (fun test -> match test.testing_state with - | None -> finish_evar_resolution env sigma0 (sigma,c) - | Some (sigma,_) -> nf_evar sigma c) + | None -> + let ctx, c = finish_evar_resolution env sigma0 (sigma,c) in + Proofview.V82.tactic (tclPUSHEVARUNIVCONTEXT ctx), c + | Some (sigma,_) -> + let univs, subst = nf_univ_variables sigma in + Proofview.V82.tactic (tclPUSHEVARUNIVCONTEXT (Evd.evar_universe_context univs)), + subst_univs_constr subst (nf_evar sigma c)) let letin_abstract id c (test,out) (occs,check_occs) gl = let env = pf_env gl in @@ -1854,13 +1937,13 @@ let letin_tac_gen with_eq name (sigmac,c) test ty occs = if not (mem_named_context x hyps) then x else error ("The variable "^(Id.to_string x)^" is already declared.") in - let (depdecls,lastlhyp,ccl,c) = + let (depdecls,lastlhyp,ccl,(tac,c)) = Tacmach.New.of_old (letin_abstract id c test occs) gl in let t = match ty with Some t -> t | None -> Tacmach.New.pf_apply (fun e s -> typ_of e s c) gl in - let (newcl,eq_tac) = match with_eq with + let (sigma,newcl,eq_tac) = match with_eq with | Some (lr,(loc,ido)) -> let heq = match ido with | IntroAnonymous -> new_fresh_id [id] (add_prefix "Heq" id) gl @@ -1869,26 +1952,34 @@ let letin_tac_gen with_eq name (sigmac,c) test ty occs = | _ -> Errors.error "Expect an introduction pattern naming one hypothesis." in let eqdata = build_coq_eq_data () in let args = if lr then [t;mkVar id;c] else [t;c;mkVar id]in - let eq = applist (eqdata.eq,args) in - let refl = applist (eqdata.refl, [t;mkVar id]) in + let sigma, eq = Evd.fresh_global env (Proofview.Goal.sigma gl) eqdata.eq in + let sigma, refl = Evd.fresh_global env sigma eqdata.refl in + let eq = applist (eq,args) in + let refl = applist (refl, [t;mkVar id]) in + sigma, mkNamedLetIn id c t (mkLetIn (Name heq, refl, eq, ccl)), Tacticals.New.tclTHEN (intro_gen loc (IntroMustBe heq) lastlhyp true false) (Proofview.V82.tactic (thin_body [heq;id])) | None -> - (mkNamedLetIn id c t ccl, Proofview.tclUNIT ()) in + (Proofview.Goal.sigma gl, mkNamedLetIn id c t ccl, Proofview.tclUNIT ()) in Tacticals.New.tclTHENLIST - [ Proofview.V82.tactic (convert_concl_no_check newcl DEFAULTcast); + [ Proofview.V82.tclEVARS sigma; tac; Proofview.V82.tactic (convert_concl_no_check newcl DEFAULTcast); intro_gen dloc (IntroMustBe id) lastlhyp true false; Proofview.V82.tactic (tclMAP convert_hyp_no_check depdecls); eq_tac ] end -let make_eq_test c = (make_eq_test c,fun _ -> c) +let make_eq_test evd c = + let out cstr = + let tac = tclPUSHEVARUNIVCONTEXT (Evd.evar_universe_context cstr.testing_state) in + Proofview.V82.tactic tac, c + in + (Tacred.make_eq_univs_test Evd.empty c, out) let letin_tac with_eq name c ty occs = Proofview.tclEVARMAP >>= fun sigma -> - letin_tac_gen with_eq name (sigma,c) (make_eq_test c) ty (occs,true) + letin_tac_gen with_eq name (sigma,c) (make_eq_test sigma c) ty (occs,true) let letin_pat_tac with_eq name c ty occs = Proofview.Goal.raw_enter begin fun gl -> @@ -2401,25 +2492,28 @@ let error_ind_scheme s = let s = if not (String.is_empty s) then s^" " else s in error ("Cannot recognize "^s^"an induction scheme.") -let coq_eq = Lazy.lazy_from_fun Coqlib.build_coq_eq -let coq_eq_refl = lazy ((Coqlib.build_coq_eq_data ()).Coqlib.refl) +let glob = Universes.constr_of_global + +let coq_eq = lazy (glob (Coqlib.build_coq_eq ())) +let coq_eq_refl = lazy (glob (Coqlib.build_coq_eq_refl ())) let coq_heq = lazy (Coqlib.coq_constant "mkHEq" ["Logic";"JMeq"] "JMeq") let coq_heq_refl = lazy (Coqlib.coq_constant "mkHEq" ["Logic";"JMeq"] "JMeq_refl") + let mkEq t x y = - mkApp (Lazy.force coq_eq, [| refresh_universes_strict t; x; y |]) + mkApp (Lazy.force coq_eq, [| t; x; y |]) let mkRefl t x = - mkApp (Lazy.force coq_eq_refl, [| refresh_universes_strict t; x |]) + mkApp (Lazy.force coq_eq_refl, [| t; x |]) let mkHEq t x u y = mkApp (Lazy.force coq_heq, - [| refresh_universes_strict t; x; refresh_universes_strict u; y |]) + [| t; x; u; y |]) let mkHRefl t x = mkApp (Lazy.force coq_heq_refl, - [| refresh_universes_strict t; x |]) + [| t; x |]) let lift_togethern n l = let l', _ = @@ -2437,8 +2531,8 @@ let ids_of_constr ?(all=false) vars c = | Var id -> Id.Set.add id vars | App (f, args) -> (match kind_of_term f with - | Construct (ind,_) - | Ind ind -> + | Construct ((ind,_),_) + | Ind (ind,_) -> let (mib,mip) = Global.lookup_inductive ind in Array.fold_left_from (if all then 0 else mib.Declarations.mind_nparams) @@ -2449,8 +2543,8 @@ let ids_of_constr ?(all=false) vars c = let decompose_indapp f args = match kind_of_term f with - | Construct (ind,_) - | Ind ind -> + | Construct ((ind,_),_) + | Ind (ind,_) -> let (mib,mip) = Global.lookup_inductive ind in let first = mib.Declarations.mind_nparams_rec in let pars, args = Array.chop first args in @@ -2552,8 +2646,7 @@ let abstract_args gl generalize_vars dep id defined f args = List.hd rel, c in let argty = pf_type_of gl arg in - let argty = refresh_universes_strict argty in - let ty = refresh_universes_strict ty in + let ty = (* refresh_universes_strict *) ty in let lenctx = List.length ctx in let liftargty = lift lenctx argty in let leq = constr_cmp Reduction.CUMUL liftargty ty in @@ -2656,7 +2749,7 @@ let specialize_eqs id gl = match kind_of_term ty with | Prod (na, t, b) -> (match kind_of_term t with - | App (eq, [| eqty; x; y |]) when eq_constr eq (Lazy.force coq_eq) -> + | App (eq, [| eqty; x; y |]) when eq_constr (Lazy.force coq_eq) eq -> let c = if noccur_between 1 (List.length ctx) x then y else x in let pt = mkApp (Lazy.force coq_eq, [| eqty; c; c |]) in let p = mkApp (Lazy.force coq_eq_refl, [| eqty; c |]) in @@ -2691,7 +2784,7 @@ let specialize_eqs id gl = let ty' = Evarutil.nf_evar !evars ty' in if worked then tclTHENFIRST (Tacmach.internal_cut true id ty') - (exact_no_check (refresh_universes_strict acc')) gl + (exact_no_check ((* refresh_universes_strict *) acc')) gl else tclFAIL 0 (str "Nothing to do in hypothesis " ++ pr_id id) gl @@ -2912,7 +3005,7 @@ let compute_scheme_signature scheme names_info ind_type_guess = extra final argument of the form (f x y ...) in the conclusion. In the non standard case, naming of generated hypos is slightly different. *) -let compute_elim_signature ((elimc,elimt),ind_type_guess) names_info = +let compute_elim_signature (evd,(elimc,elimt),ind_type_guess) names_info = let scheme = compute_elim_sig ~elimc:elimc elimt in compute_scheme_signature scheme names_info ind_type_guess, scheme @@ -2920,8 +3013,8 @@ let guess_elim isrec hyp0 gl = let tmptyp0 = pf_get_hyp_typ gl hyp0 in let mind,_ = pf_reduce_to_quantified_ind gl tmptyp0 in let s = elimination_sort_of_goal gl in - let elimc = - if isrec && not (is_record mind) then lookup_eliminator mind s + let evd, elimc = + if isrec && not (is_record (fst mind) <> None) then find_ind_eliminator (fst mind) s gl else if use_dependent_propositions_elimination () && dependent_no_evar (mkVar hyp0) (pf_concl gl) @@ -2930,12 +3023,12 @@ let guess_elim isrec hyp0 gl = else pf_apply build_case_analysis_scheme_default gl mind s in let elimt = pf_type_of gl elimc in - ((elimc, NoBindings), elimt), mkInd mind + evd, ((elimc, NoBindings), elimt), mkIndU mind let given_elim hyp0 (elimc,lbind as e) gl = let tmptyp0 = pf_get_hyp_typ gl hyp0 in let ind_type_guess,_ = decompose_app ((strip_prod tmptyp0)) in - (e, pf_type_of gl elimc), ind_type_guess + project gl, (e, pf_type_of gl elimc), ind_type_guess let find_elim isrec elim hyp0 gl = match elim with @@ -2950,21 +3043,21 @@ type eliminator_source = | ElimOver of bool * Id.t let find_induction_type isrec elim hyp0 gl = - let scheme,elim = + let evd,scheme,elim = match elim with | None -> - let (elimc,elimt),_ = guess_elim isrec hyp0 gl in + let evd, (elimc,elimt),_ = guess_elim isrec hyp0 gl in let scheme = compute_elim_sig ~elimc elimt in (* We drop the scheme waiting to know if it is dependent *) - scheme, ElimOver (isrec,hyp0) + project gl, scheme, ElimOver (isrec,hyp0) | Some e -> - let (elimc,elimt),ind_guess = given_elim hyp0 e gl in + let evd, (elimc,elimt),ind_guess = given_elim hyp0 e gl in let scheme = compute_elim_sig ~elimc elimt in if Option.is_empty scheme.indarg then error "Cannot find induction type"; let indsign = compute_scheme_signature scheme hyp0 ind_guess in let elim = ({elimindex = Some(-1); elimbody = elimc},elimt) in - scheme, ElimUsing (elim,indsign) in - Option.get scheme.indref,scheme.nparams, elim + evd, scheme, ElimUsing (elim,indsign) in + evd,(Option.get scheme.indref,scheme.nparams, elim) let find_elim_signature isrec elim hyp0 gl = compute_elim_signature (find_elim isrec elim hyp0 gl) hyp0 @@ -2984,10 +3077,10 @@ let is_functional_induction elim gl = let get_eliminator elim gl = match elim with | ElimUsing (elim,indsign) -> - (* bugged, should be computed *) true, elim, indsign + Proofview.Goal.sigma gl, (* bugged, should be computed *) true, elim, indsign | ElimOver (isrec,id) -> - let (elimc,elimt),_ as elims = Tacmach.New.of_old (guess_elim isrec id) gl in - isrec, ({elimindex = None; elimbody = elimc}, elimt), + let evd, (elimc,elimt),_ as elims = Tacmach.New.of_old (guess_elim isrec id) gl in + evd, isrec, ({elimindex = None; elimbody = elimc}, elimt), fst (compute_elim_signature elims id) (* Instantiate all meta variables of elimclause using lid, some elts @@ -3041,7 +3134,7 @@ let induction_tac_felim with_evars indvars nparams elim gl = (* elimclause' is built from elimclause by instanciating all args and params. *) let elimclause' = recolle_clenv nparams indvars elimclause gl in (* one last resolution (useless?) *) - let resolved = clenv_unique_resolver ~flags:elim_flags elimclause' gl in + let resolved = clenv_unique_resolver ~flags:(elim_flags ()) elimclause' gl in clenv_refine with_evars resolved gl (* Apply induction "in place" replacing the hypothesis on which @@ -3049,13 +3142,14 @@ let induction_tac_felim with_evars indvars nparams elim gl = let apply_induction_with_discharge induct_tac elim indhyps destopt avoid names tac = Proofview.Goal.enter begin fun gl -> - let (isrec, elim, indsign) = get_eliminator elim gl in + let (sigma, isrec, elim, indsign) = get_eliminator elim gl in let names = compute_induction_names (Array.length indsign) names in - (if isrec then Tacticals.New.tclTHENFIRSTn else Tacticals.New.tclTHENLASTn) + Tacticals.New.tclTHEN (Proofview.V82.tclEVARS sigma) + ((if isrec then Tacticals.New.tclTHENFIRSTn else Tacticals.New.tclTHENLASTn) (Tacticals.New.tclTHEN (induct_tac elim) (Proofview.V82.tactic (tclMAP (fun id -> tclTRY (expand_hyp id)) (List.rev indhyps)))) - (Array.map2 (induct_discharge destopt avoid tac) indsign names) + (Array.map2 (induct_discharge destopt avoid tac) indsign names)) end (* Apply induction "in place" taking into account dependent @@ -3066,7 +3160,7 @@ let apply_induction_in_context hyp0 elim indvars names induct_tac = let env = Proofview.Goal.env gl in let concl = Tacmach.New.pf_nf_concl gl in let statuslists,lhyp0,indhyps,deps = cook_sign hyp0 indvars env in - let deps = List.map (on_pi3 refresh_universes_strict) deps in +(* let deps = List.map (on_pi3 refresh_universes_strict) deps in *) let tmpcl = it_mkNamedProd_or_LetIn concl deps in let dephyps = List.map (fun (id,_,_) -> id) deps in let deps_cstr = @@ -3163,11 +3257,11 @@ let induction_from_context isrec with_evars (indref,nparams,elim) (hyp0,lbind) n let induction_with_atomization_of_ind_arg isrec with_evars elim names (hyp0,lbind) inhyps = Proofview.Goal.enter begin fun gl -> - let elim_info = Tacmach.New.of_old (find_induction_type isrec elim hyp0) gl in - Tacticals.New.tclTHEN - (atomize_param_of_ind elim_info hyp0) + let sigma, elim_info = Tacmach.New.of_old (find_induction_type isrec elim hyp0) gl in + Tacticals.New.tclTHENLIST + [Proofview.V82.tclEVARS sigma; (atomize_param_of_ind elim_info hyp0); (induction_from_context isrec with_evars elim_info - (hyp0,lbind) names inhyps) + (hyp0,lbind) names inhyps)] end (* Induction on a list of induction arguments. Analyse the elim @@ -3319,9 +3413,10 @@ let induct_destruct isrec with_evars (lc,elim,names,cls) = str "Example: induction x1 x2 x3 using my_scheme."); if not (Option.is_empty cls) then error "'in' clause not supported here."; - let finish_evar_resolution = Tacmach.New.pf_apply finish_evar_resolution gl in - let lc = List.map - (map_induction_arg finish_evar_resolution) lc in + let finish_evar_resolution (sigma, c) = + snd (finish_evar_resolution (Proofview.Goal.env gl) (Proofview.Goal.sigma gl) (sigma, c)) + in + let lc = List.map (map_induction_arg finish_evar_resolution) lc in begin match lc with | [_] -> (* Hook to recover standard induction on non-standard induction schemes *) @@ -3398,20 +3493,22 @@ let elim_scheme_type elim t gl = | Meta mv -> let clause' = (* t is inductive, then CUMUL or CONV is irrelevant *) - clenv_unify ~flags:elim_flags Reduction.CUMUL t + clenv_unify ~flags:(elim_flags ()) Reduction.CUMUL t (clenv_meta_type clause mv) clause in - res_pf clause' ~flags:elim_flags gl + res_pf clause' ~flags:(elim_flags ()) gl | _ -> anomaly (Pp.str "elim_scheme_type") let elim_type t gl = let (ind,t) = pf_reduce_to_atomic_ind gl t in - let elimc = lookup_eliminator ind (elimination_sort_of_goal gl) in - elim_scheme_type elimc t gl + let evd, elimc = find_ind_eliminator (fst ind) (elimination_sort_of_goal gl) gl in + tclTHEN (tclEVARS evd) (elim_scheme_type elimc t) gl let case_type t gl = let (ind,t) = pf_reduce_to_atomic_ind gl t in - let elimc = pf_apply build_case_analysis_scheme_default gl ind (elimination_sort_of_goal gl) in - elim_scheme_type elimc t gl + let evd, elimc = + pf_apply build_case_analysis_scheme_default gl ind (elimination_sort_of_goal gl) + in + tclTHEN (tclEVARS evd) (elim_scheme_type elimc t) gl (************************************************) @@ -3492,7 +3589,7 @@ let symmetry_red allowred = Proofview.V82.tactic begin tclTHEN (convert_concl_no_check concl DEFAULTcast) - (apply eq_data.sym) + (pf_constr_of_global eq_data.sym apply) end | None,eq,eq_kind -> prove_symmetry eq eq_kind end @@ -3587,8 +3684,8 @@ let transitivity_red allowred t = tclTHEN (convert_concl_no_check concl DEFAULTcast) (match t with - | None -> eapply eq_data.trans - | Some t -> apply_list [eq_data.trans;t]) + | None -> pf_constr_of_global eq_data.trans eapply + | Some t -> pf_constr_of_global eq_data.trans (fun trans -> apply_list [trans;t])) end | None,eq,eq_kind -> match t with @@ -3613,7 +3710,7 @@ let intros_transitivity n = Tacticals.New.tclTHEN intros (transitivity_gen n) the current goal, abstracted with respect to the local signature, is solved by tac *) -let interpretable_as_section_decl d1 d2 = match d1,d2 with +let interpretable_as_section_decl d1 d2 = match d2,d1 with | (_,Some _,_), (_,None,_) -> false | (_,Some b1,t1), (_,Some b2,t2) -> eq_constr b1 b2 && eq_constr t1 t2 | (_,None,t1), (_,_,t2) -> eq_constr t1 t2 @@ -3639,9 +3736,16 @@ let abstract_subproof id tac = try flush_and_check_evars (Proofview.Goal.sigma gl) concl with Uninstantiated_evar _ -> error "\"abstract\" cannot handle existentials." in + + let evd, ctx, concl = + (* FIXME: should be done only if the tactic succeeds *) + let evd, nf = nf_evars_and_universes (Proofview.Goal.sigma gl) in + let ctx = Evd.get_universe_context_set evd in + evd, ctx, nf concl + in let solve_tac = tclCOMPLETE (tclTHEN (tclDO (List.length sign) intro) tac) in - let (const, safe) = - try Pfedit.build_constant_by_tactic id secsign concl solve_tac + let (const, safe, subst) = + try Pfedit.build_constant_by_tactic id secsign (concl, ctx) solve_tac with Proof_errors.TacticFailure e as src -> (* if the tactic [tac] fails, it reports a [TacticFailure e], which is an error irrelevant to the proof system (in fact it @@ -3655,12 +3759,13 @@ let abstract_subproof id tac = let decl = (cd, IsProof Lemma) in (** ppedrot: seems legit to have abstracted subproofs as local*) let cst = Declare.declare_constant ~internal:Declare.KernelSilent ~local:true id decl in - let lem = mkConst cst in + let evd, lem = Evd.fresh_global (Global.env ()) evd (ConstRef cst) in let open Declareops in let eff = Safe_typing.sideff_of_con (Global.safe_env ()) cst in let effs = cons_side_effects eff no_seff in let args = List.rev (instance_from_named_context sign) in - let solve = Proofview.tclEFFECTS effs <*> new_exact_no_check (applist (lem, args)) in + let solve = Proofview.V82.tactic (tclEVARS evd) <*> + Proofview.tclEFFECTS effs <*> new_exact_no_check (applist (lem, args)) in if not safe then Proofview.mark_as_unsafe <*> solve else solve end @@ -3682,12 +3787,53 @@ let admit_as_an_axiom = simplest_case (Coqlib.build_coq_proof_admitted ()) <*> Proofview.mark_as_unsafe +(* let current_sign = Global.named_context() *) +(* and global_sign = pf_hyps gl in *) +(* let poly = Flags.is_universe_polymorphism () in (\*FIXME*\) *) +(* let sign,secsign = *) +(* List.fold_right *) +(* (fun (id,_,_ as d) (s1,s2) -> *) +(* if mem_named_context id current_sign & *) +(* interpretable_as_section_decl (Context.lookup_named id current_sign) d *) +(* then (s1,add_named_decl d s2) *) +(* else (add_named_decl d s1,s2)) *) +(* global_sign (empty_named_context,empty_named_context) in *) +(* let name = add_suffix (get_current_proof_name ()) "_admitted" in *) +(* let na = next_global_ident_away name (pf_ids_of_hyps gl) in *) +(* let evd, nf = nf_evars_and_universes (project gl) in *) +(* let ctx = Evd.universe_context evd in *) +(* let newconcl = nf (pf_concl gl) in *) +(* let newsign = Context.map_named_context nf sign in *) +(* let concl = it_mkNamedProd_or_LetIn newconcl newsign in *) +(* if occur_existential concl then error"\"admit\" cannot handle existentials."; *) +(* let entry = *) +(* (Pfedit.get_used_variables(),poly,(concl,ctx),None) *) +(* in *) +(* let cd = Entries.ParameterEntry entry in *) +(* let decl = (cd, IsAssumption Logical) in *) +(* (\** ppedrot: seems legit to have admitted subproofs as local*\) *) +(* let con = Declare.declare_constant ~internal:Declare.KernelSilent ~local:true na decl in *) +(* let evd, axiom = evd, (mkConstU (con, Univ.UContext.instance ctx)) in *) +(* (\* let evd, axiom = Evd.fresh_global (pf_env gl) (project gl) (ConstRef con) in *\) *) +(* let gl = tclTHEN (tclEVARS evd) *) +(* (tclTHEN (convert_concl_no_check newconcl DEFAULTcast) *) +(* (exact_check *) +(* (applist (axiom, *) +(* List.rev (Array.to_list (instance_from_named_context sign)))))) *) +(* gl *) +(* in *) +(* Pp.feedback Interface.AddedAxiom; *) +(* gl *) +(* >>>>>>> .merge_file_iUuzZK *) + let unify ?(state=full_transparent_state) x y gl = try let flags = - {default_unify_flags with - modulo_delta = state; - modulo_conv_on_closed_terms = Some state} + {(default_unify_flags ()) with + modulo_delta = state; + modulo_delta_types = state; + modulo_delta_in_merge = Some state; + modulo_conv_on_closed_terms = Some state} in let evd = w_unify (pf_env gl) (project gl) Reduction.CONV ~flags x y in tclEVARS evd gl diff --git a/tactics/tactics.mli b/tactics/tactics.mli index 9a2af0835..937efdae1 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -26,8 +26,8 @@ open Locus (** {6 General functions. } *) -val head_constr : constr -> constr * constr list -val head_constr_bound : constr -> constr * constr list +val head_constr : constr -> constr +val head_constr_bound : constr -> constr val is_quantified_hypothesis : Id.t -> goal sigma -> bool exception Bound @@ -45,6 +45,9 @@ val fix : Id.t option -> int -> tactic val mutual_cofix : Id.t -> (Id.t * constr) list -> int -> tactic val cofix : Id.t option -> tactic +val convert : constr -> constr -> tactic +val convert_leq : constr -> constr -> tactic + (** {6 Introduction tactics. } *) val fresh_id_in_env : Id.t list -> Id.t -> env -> Id.t diff --git a/tactics/tauto.ml4 b/tactics/tauto.ml4 index 2a35e32d9..8d3d33510 100644 --- a/tactics/tauto.ml4 +++ b/tactics/tauto.ml4 @@ -97,16 +97,16 @@ let is_unit_or_eq flags ist = let is_record t = let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with - | Ind ind -> + | Ind (ind,u) -> let (mib,mip) = Global.lookup_inductive ind in - mib.Declarations.mind_record + mib.Declarations.mind_record <> None | _ -> false let bugged_is_binary t = isApp t && let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with - | Ind ind -> + | Ind (ind,u) -> let (mib,mip) = Global.lookup_inductive ind in Int.equal mib.Declarations.mind_nparams 2 | _ -> false @@ -319,7 +319,7 @@ let tauto_gen flags = Proofview.tclBIND (Proofview.tclUNIT ()) begin fun () -> try - let nnpp = constr_of_global (Nametab.global_of_path coq_nnpp_path) in + let nnpp = Universes.constr_of_global (Nametab.global_of_path coq_nnpp_path) in (* try intuitionistic version first to avoid an axiom if possible *) Tacticals.New.tclORELSE (tauto_intuitionistic flags) (tauto_classical flags nnpp) with Not_found -> diff --git a/tactics/termdn.ml b/tactics/termdn.ml new file mode 100644 index 000000000..1c4c4b648 --- /dev/null +++ b/tactics/termdn.ml @@ -0,0 +1,136 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Util +open Names +open Term +open Pattern +open Patternops +open Globnames + +(* Discrimination nets of terms. + See the module dn.ml for further explanations. + Eduardo (5/8/97) *) +module Make = + functor (Z : Map.OrderedType) -> +struct + + module X = struct + type t = constr_pattern + let compare = Pervasives.compare (** FIXME *) + end + + type term_label = + | GRLabel of global_reference + | ProdLabel + | LambdaLabel + | SortLabel + + module Y = struct + type t = term_label + let compare x y = + let make_name n = + match n with + | GRLabel(ConstRef con) -> + GRLabel(ConstRef(constant_of_kn(canonical_con con))) + | GRLabel(IndRef (kn,i)) -> + GRLabel(IndRef(mind_of_kn(canonical_mind kn),i)) + | GRLabel(ConstructRef ((kn,i),j ))-> + GRLabel(ConstructRef((mind_of_kn(canonical_mind kn),i),j)) + | k -> k + in + Pervasives.compare (make_name x) (make_name y) + end + + + module Dn = Dn.Make(X)(Y)(Z) + + type t = Dn.t + + type 'a lookup_res = 'a Dn.lookup_res + +(*If we have: f a b c ..., decomp gives: (f,[a;b;c;...])*) + +let decomp = + let rec decrec acc c = match kind_of_term c with + | App (f,l) -> decrec (Array.fold_right (fun a l -> a::l) l acc) f + | Cast (c1,_,_) -> decrec acc c1 + | Proj (p, c) -> decrec (c :: acc) (mkConst p) + | _ -> (c,acc) + in + decrec [] + +let decomp_pat = + let rec decrec acc = function + | PApp (f,args) -> decrec (Array.to_list args @ acc) f + | c -> (c,acc) + in + decrec [] + +let constr_pat_discr t = + if not (occur_meta_pattern t) then + None + else + match decomp_pat t with + | PRef ((IndRef _) as ref), args + | PRef ((ConstructRef _ ) as ref), args -> Some (GRLabel ref,args) + | PRef ((VarRef v) as ref), args -> Some(GRLabel ref,args) + | _ -> None + +let constr_pat_discr_st (idpred,cpred) t = + match decomp_pat t with + | PRef ((IndRef _) as ref), args + | PRef ((ConstructRef _ ) as ref), args -> Some (GRLabel ref,args) + | PRef ((VarRef v) as ref), args when not (Id.Pred.mem v idpred) -> + Some(GRLabel ref,args) + | PVar v, args when not (Id.Pred.mem v idpred) -> + Some(GRLabel (VarRef v),args) + | PRef ((ConstRef c) as ref), args when not (Cpred.mem c cpred) -> + Some (GRLabel ref, args) + | PProd (_, d, c), [] -> Some (ProdLabel, [d ; c]) + | PLambda (_, d, c), l -> Some (LambdaLabel, [d ; c] @ l) + | PSort s, [] -> Some (SortLabel, []) + | _ -> None + +open Dn + +let constr_val_discr t = + let c, l = decomp t in + match kind_of_term c with + | Ind (ind_sp,u) -> Label(GRLabel (IndRef ind_sp),l) + | Construct (cstr_sp,u) -> Label(GRLabel (ConstructRef cstr_sp),l) + | Var id -> Label(GRLabel (VarRef id),l) + | Const _ -> Everything + | Proj _ -> Everything + | _ -> Nothing + +let constr_val_discr_st (idpred,cpred) t = + let c, l = decomp t in + match kind_of_term c with + | Const (c,_) -> if Cpred.mem c cpred then Everything else Label(GRLabel (ConstRef c),l) + | Ind (ind_sp,_) -> Label(GRLabel (IndRef ind_sp),l) + | Construct (cstr_sp,_) -> Label(GRLabel (ConstructRef cstr_sp),l) + | Proj (p,c) -> if Cpred.mem p cpred then Everything else Label(GRLabel (ConstRef p),c::l) + | Var id when not (Id.Pred.mem id idpred) -> Label(GRLabel (VarRef id),l) + | Prod (n, d, c) -> Label(ProdLabel, [d; c]) + | Lambda (n, d, c) -> Label(LambdaLabel, [d; c] @ l) + | Sort _ -> Label (SortLabel, []) + | Evar _ -> Everything + | _ -> Nothing + +let create = Dn.create + +let add dn st = Dn.add dn (constr_pat_discr_st st) + +let rmv dn st = Dn.rmv dn (constr_pat_discr_st st) + +let lookup dn st t = Dn.lookup dn (constr_val_discr_st st) t + +let app f dn = Dn.app f dn + +end diff --git a/test-suite/success/Projection.v b/test-suite/success/Projection.v index d8faa88a7..3ffd41ea0 100644 --- a/test-suite/success/Projection.v +++ b/test-suite/success/Projection.v @@ -1,3 +1,9 @@ +Record foo (A : Type) := { B :> Type }. + +Lemma bar (f : foo nat) (x : f) : x = x. + destruct f. simpl B. simpl B in x. +Abort. + Structure S : Type := {Dom : Type; Op : Dom -> Dom -> Dom}. Check (fun s : S => Dom s). diff --git a/test-suite/success/indelim.v b/test-suite/success/indelim.v new file mode 100644 index 000000000..91b6dee2e --- /dev/null +++ b/test-suite/success/indelim.v @@ -0,0 +1,61 @@ +Inductive boolP : Prop := +| trueP : boolP +| falseP : boolP. + +Fail Check boolP_rect. + + +Inductive True : Prop := I : True. + +Inductive False : Prop :=. + +Inductive Empty_set : Set :=. + +Fail Inductive Large_set : Set := + large_constr : forall A : Set, A -> Large_set. + +Inductive smallunitProp : Prop := +| onlyProps : True -> smallunitProp. + +Check smallunitProp_rect. + +Inductive nonsmallunitProp : Prop := +| notonlyProps : nat -> nonsmallunitProp. + +Fail Check nonsmallunitProp_rect. +Set Printing Universes. +Inductive inferProp := +| hasonlyProps : True -> nonsmallunitProp -> inferProp. + +Check (inferProp : Prop). + +Inductive inferSet := +| hasaset : nat -> True -> nonsmallunitProp -> inferSet. + +Fail Check (inferSet : Prop). + +Check (inferSet : Set). + +Inductive inferLargeSet := +| hasalargeset : Set -> True -> nonsmallunitProp -> inferLargeSet. + +Fail Check (inferLargeSet : Set). + +Inductive largeProp : Prop := somelargeprop : Set -> largeProp. + + +Inductive comparison : Set := + | Eq : comparison + | Lt : comparison + | Gt : comparison. + +Inductive CompareSpecT (Peq Plt Pgt : Prop) : comparison -> Type := + | CompEqT : Peq -> CompareSpecT Peq Plt Pgt Eq + | CompLtT : Plt -> CompareSpecT Peq Plt Pgt Lt + | CompGtT : Pgt -> CompareSpecT Peq Plt Pgt Gt. + +Inductive color := Red | Black. + +Inductive option (A : Type) : Type := +| None : option A +| Some : A -> option A.
\ No newline at end of file diff --git a/test-suite/success/polymorphism.v b/test-suite/success/polymorphism.v index 56cab0f68..7c1166c4c 100644 --- a/test-suite/success/polymorphism.v +++ b/test-suite/success/polymorphism.v @@ -1,12 +1,249 @@ +Set Universe Polymorphism. + +Inductive empty :=. +Inductive emptyt : Type :=. +Inductive singleton : Type := + single. +Inductive singletoninfo : Type := + singleinfo : unit -> singletoninfo. +Inductive singletonset : Set := + singleset. + +Inductive singletonnoninfo : Type := + singlenoninfo : empty -> singletonnoninfo. + +Inductive singletoninfononinfo : Prop := + singleinfononinfo : unit -> singletoninfononinfo. + +Inductive bool : Type := + | true | false. + +Inductive smashedbool : Prop := + | trueP | falseP. + +Section foo. + Let T := Type. + Inductive polybool : T := + | trueT | falseT. +End foo. + +Inductive list (A: Type) : Type := +| nil : list A +| cons : A -> list A -> list A. + +Module ftypSetSet. +Inductive ftyp : Type := + | Funit : ftyp + | Ffun : list ftyp -> ftyp + | Fref : area -> ftyp +with area : Type := + | Stored : ftyp -> area +. +End ftypSetSet. + + +Module ftypSetProp. +Inductive ftyp : Type := + | Funit : ftyp + | Ffun : list ftyp -> ftyp + | Fref : area -> ftyp +with area : Type := + | Stored : (* ftyp -> *)area +. +End ftypSetProp. + +Module ftypSetSetForced. +Inductive ftyp : Type := + | Funit : ftyp + | Ffun : list ftyp -> ftyp + | Fref : area -> ftyp +with area : Set (* Type *) := + | Stored : (* ftyp -> *)area +. +End ftypSetSetForced. + +Unset Universe Polymorphism. + +Set Printing Universes. +Module Easy. + + Polymorphic Inductive prod (A : Type) (B : Type) : Type := + pair : A -> B -> prod A B. + + Check prod nat nat. + Print Universes. + + + Polymorphic Inductive sum (A B:Type) : Type := + | inl : A -> sum A B + | inr : B -> sum A B. + Print sum. + Check (sum nat nat). + +End Easy. + +Section Hierarchy. + +Definition Type3 := Type. +Definition Type2 := Type : Type3. +Definition Type1 := Type : Type2. + +Definition id1 := ((forall A : Type1, A) : Type2). +Definition id2 := ((forall A : Type2, A) : Type3). +Definition id1' := ((forall A : Type1, A) : Type3). +Fail Definition id1impred := ((forall A : Type1, A) : Type1). + +End Hierarchy. + +Section structures. + +Record hypo : Type := mkhypo { + hypo_type : Type; + hypo_proof : hypo_type + }. + +Definition typehypo (A : Type) : hypo := {| hypo_proof := A |}. + +Polymorphic Record dyn : Type := + mkdyn { + dyn_type : Type; + dyn_proof : dyn_type + }. + +Definition monotypedyn (A : Type) : dyn := {| dyn_proof := A |}. +Polymorphic Definition typedyn (A : Type) : dyn := {| dyn_proof := A |}. + +Definition atypedyn : dyn := typedyn Type. + +Definition projdyn := dyn_type atypedyn. + +Definition nested := {| dyn_type := dyn; dyn_proof := atypedyn |}. + +Definition nested2 := {| dyn_type := dyn; dyn_proof := nested |}. + +Definition projnested2 := dyn_type nested2. + +Polymorphic Definition nest (d : dyn) := {| dyn_proof := d |}. + +Polymorphic Definition twoprojs (d : dyn) := dyn_proof d = dyn_proof d. + +End structures. + +Section cats. + Local Set Universe Polymorphism. + Require Import Utf8. + Definition fibration (A : Type) := A -> Type. + Definition Hom (A : Type) := A -> A -> Type. + + Record sigma (A : Type) (P : fibration A) := + { proj1 : A; proj2 : P proj1} . + + Class Identity {A} (M : Hom A) := + identity : ∀ x, M x x. + + Class Inverse {A} (M : Hom A) := + inverse : ∀ x y:A, M x y -> M y x. + + Class Composition {A} (M : Hom A) := + composition : ∀ {x y z:A}, M x y -> M y z -> M x z. + + Notation "g ° f" := (composition f g) (at level 50). + + Class Equivalence T (Eq : Hom T):= + { + Equivalence_Identity :> Identity Eq ; + Equivalence_Inverse :> Inverse Eq ; + Equivalence_Composition :> Composition Eq + }. + + Class EquivalenceType (T : Type) : Type := + { + m2: Hom T; + equiv_struct :> Equivalence T m2 }. + + Polymorphic Record cat (T : Type) := + { cat_hom : Hom T; + cat_equiv : forall x y, EquivalenceType (cat_hom x y) }. + + Definition catType := sigma Type cat. + + Notation "[ T ]" := (proj1 T). + + Require Import Program. + + Program Definition small_cat : cat Empty_set := + {| cat_hom x y := unit |}. + Next Obligation. + refine ({|m2:=fun x y => True|}). + constructor; red; intros; trivial. + Defined. + + Record iso (T U : Set) := + { f : T -> U; + g : U -> T }. + + Program Definition Set_cat : cat Set := + {| cat_hom := iso |}. + Next Obligation. + refine ({|m2:=fun x y => True|}). + constructor; red; intros; trivial. + Defined. + + Record isoT (T U : Type) := + { isoT_f : T -> U; + isoT_g : U -> T }. + + Program Definition Type_cat : cat Type := + {| cat_hom := isoT |}. + Next Obligation. + refine ({|m2:=fun x y => True|}). + constructor; red; intros; trivial. + Defined. + + Polymorphic Record cat1 (T : Type) := + { cat1_car : Type; + cat1_hom : Hom cat1_car; + cat1_hom_cat : forall x y, cat (cat1_hom x y) }. +End cats. + +Polymorphic Definition id {A : Type} (a : A) : A := a. + +Definition typeid := (@id Type). + + + + (* Some tests of sort-polymorphisme *) Section S. -Variable A:Type. +Polymorphic Variable A:Type. (* Definition f (B:Type) := (A * B)%type. *) -Inductive I (B:Type) : Type := prod : A->B->I B. +Polymorphic Inductive I (B:Type) : Type := prod : A->B->I B. + +Check I nat. + End S. (* Check f nat nat : Set. *) -Check I nat nat : Set.
\ No newline at end of file +Definition foo:= I nat nat : Set. +Print Universes. Print foo. Set Printing Universes. Print foo. + +(* Polymorphic axioms: *) +Polymorphic Axiom funext : forall (A B : Type) (f g : A -> B), + (forall x, f x = g x) -> f = g. + +(* Check @funext. *) +(* Check funext. *) + +Polymorphic Definition fun_ext (A B : Type) := + forall (f g : A -> B), + (forall x, f x = g x) -> f = g. + +Polymorphic Class Funext A B := extensional : fun_ext A B. + +Section foo. + Context `{forall A B, Funext A B}. + Print Universes. +End foo. diff --git a/theories/Arith/Compare_dec.v b/theories/Arith/Compare_dec.v index a90a9ce99..76132aed0 100644 --- a/theories/Arith/Compare_dec.v +++ b/theories/Arith/Compare_dec.v @@ -201,7 +201,7 @@ Qed. Lemma nat_compare_spec : forall x y, CompareSpec (x=y) (x<y) (y<x) (nat_compare x y). Proof. - intros. + intros. destruct (nat_compare x y) eqn:?; constructor. apply nat_compare_eq; auto. apply <- nat_compare_lt; auto. diff --git a/theories/Arith/Le.v b/theories/Arith/Le.v index 1febb76b6..c3386787d 100644 --- a/theories/Arith/Le.v +++ b/theories/Arith/Le.v @@ -54,7 +54,7 @@ Hint Resolve le_0_n le_Sn_0: arith v62. Theorem le_n_0_eq : forall n, n <= 0 -> 0 = n. Proof. - induction n; auto with arith. + induction n. auto with arith. idtac. auto with arith. intro; contradiction le_Sn_0 with n. Qed. Hint Immediate le_n_0_eq: arith v62. diff --git a/theories/Classes/CEquivalence.v b/theories/Classes/CEquivalence.v new file mode 100644 index 000000000..68a6dcd63 --- /dev/null +++ b/theories/Classes/CEquivalence.v @@ -0,0 +1,139 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** * Typeclass-based setoids. Definitions on [Equivalence]. + + Author: Matthieu Sozeau + Institution: LRI, CNRS UMR 8623 - University Paris Sud +*) + +Require Import Coq.Program.Basics. +Require Import Coq.Program.Tactics. + +Require Import Coq.Classes.Init. +Require Import Relation_Definitions. +Require Export Coq.Classes.RelationClasses. +Require Import Coq.Classes.Morphisms. + +Set Implicit Arguments. +Unset Strict Implicit. + +Generalizable Variables A R eqA B S eqB. +Local Obligation Tactic := try solve [simpl_crelation]. + +Local Open Scope signature_scope. + +Definition equiv `{Equivalence A R} : crelation A := R. + +(** Overloaded notations for setoid equivalence and inequivalence. + Not to be confused with [eq] and [=]. *) + +Notation " x === y " := (equiv x y) (at level 70, no associativity) : equiv_scope. + +Notation " x =/= y " := (complement equiv x y) (at level 70, no associativity) : equiv_scope. + +Local Open Scope equiv_scope. + +(** Overloading for [PER]. *) + +Definition pequiv `{PER A R} : crelation A := R. + +(** Overloaded notation for partial equivalence. *) + +Infix "=~=" := pequiv (at level 70, no associativity) : equiv_scope. + +(** Shortcuts to make proof search easier. *) + +Program Instance equiv_reflexive `(sa : Equivalence A) : Reflexive equiv. + +Program Instance equiv_symmetric `(sa : Equivalence A) : Symmetric equiv. + +Program Instance equiv_transitive `(sa : Equivalence A) : Transitive equiv. + + Next Obligation. + Proof. intros A R sa x y z Hxy Hyz. + now transitivity y. + Qed. + +(** Use the [substitute] command which substitutes an equivalence in every hypothesis. *) + +Ltac setoid_subst H := + match type of H with + ?x === ?y => substitute H ; clear H x + end. + +Ltac setoid_subst_nofail := + match goal with + | [ H : ?x === ?y |- _ ] => setoid_subst H ; setoid_subst_nofail + | _ => idtac + end. + +(** [subst*] will try its best at substituting every equality in the goal. *) + +Tactic Notation "subst" "*" := subst_no_fail ; setoid_subst_nofail. + +(** Simplify the goal w.r.t. equivalence. *) + +Ltac equiv_simplify_one := + match goal with + | [ H : ?x === ?x |- _ ] => clear H + | [ H : ?x === ?y |- _ ] => setoid_subst H + | [ |- ?x =/= ?y ] => let name:=fresh "Hneq" in intro name + | [ |- ~ ?x === ?y ] => let name:=fresh "Hneq" in intro name + end. + +Ltac equiv_simplify := repeat equiv_simplify_one. + +(** "reify" relations which are equivalences to applications of the overloaded [equiv] method + for easy recognition in tactics. *) + +Ltac equivify_tac := + match goal with + | [ s : Equivalence ?A ?R, H : ?R ?x ?y |- _ ] => change R with (@equiv A R s) in H + | [ s : Equivalence ?A ?R |- context C [ ?R ?x ?y ] ] => change (R x y) with (@equiv A R s x y) + end. + +Ltac equivify := repeat equivify_tac. + +Section Respecting. + + (** Here we build an equivalence instance for functions which relates respectful ones only, + we do not export it. *) + + Definition respecting `(eqa : Equivalence A (R : crelation A), + eqb : Equivalence B (R' : crelation B)) : Type := + { morph : A -> B | respectful R R' morph morph }. + + Program Instance respecting_equiv `(eqa : Equivalence A R, eqb : Equivalence B R') : + Equivalence (fun (f g : respecting eqa eqb) => + forall (x y : A), R x y -> R' (proj1_sig f x) (proj1_sig g y)). + + Solve Obligations with unfold respecting in * ; simpl_crelation ; program_simpl. + + Next Obligation. + Proof. + intros. intros f g h H H' x y Rxy. + unfold respecting in *. program_simpl. transitivity (g y); auto. firstorder. + Qed. + +End Respecting. + +(** The default equivalence on function spaces, with higher-priority than [eq]. *) + +Instance pointwise_reflexive {A} `(reflb : Reflexive B eqB) : + Reflexive (pointwise_relation A eqB) | 9. +Proof. firstorder. Qed. +Instance pointwise_symmetric {A} `(symb : Symmetric B eqB) : + Symmetric (pointwise_relation A eqB) | 9. +Proof. firstorder. Qed. +Instance pointwise_transitive {A} `(transb : Transitive B eqB) : + Transitive (pointwise_relation A eqB) | 9. +Proof. firstorder. Qed. +Instance pointwise_equivalence {A} `(eqb : Equivalence B eqB) : + Equivalence (pointwise_relation A eqB) | 9. +Proof. split; apply _. Qed. diff --git a/theories/Classes/CMorphisms.v b/theories/Classes/CMorphisms.v new file mode 100644 index 000000000..5737c88b5 --- /dev/null +++ b/theories/Classes/CMorphisms.v @@ -0,0 +1,799 @@ +(* -*- coding: utf-8 -*- *) +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** * Typeclass-based morphism definition and standard, minimal instances + + Author: Matthieu Sozeau + Institution: LRI, CNRS UMR 8623 - University Paris Sud +*) + +Require Import Coq.Program.Basics. +Require Import Coq.Program.Tactics. +Require Export Coq.Classes.RelationClasses. + +Generalizable Variables A eqA B C D R RA RB RC m f x y. +Local Obligation Tactic := simpl_crelation. + +Set Universe Polymorphism. + +(** * Morphisms. + + We now turn to the definition of [Proper] and declare standard instances. + These will be used by the [setoid_rewrite] tactic later. *) + +(** A morphism for a relation [R] is a proper element of the relation. + The relation [R] will be instantiated by [respectful] and [A] by an arrow + type for usual morphisms. *) +Section Proper. + Let U := Type. + Context {A B : U}. + + Class Proper (R : crelation A) (m : A) := + proper_prf : R m m. + + (** Every element in the carrier of a reflexive relation is a morphism + for this relation. We use a proxy class for this case which is used + internally to discharge reflexivity constraints. The [Reflexive] + instance will almost always be used, but it won't apply in general to + any kind of [Proper (A -> B) _ _] goal, making proof-search much + slower. A cleaner solution would be to be able to set different + priorities in different hint bases and select a particular hint + database for resolution of a type class constraint. *) + + Class ProperProxy (R : crelation A) (m : A) := + proper_proxy : R m m. + + Lemma eq_proper_proxy (x : A) : ProperProxy (@eq A) x. + Proof. firstorder. Qed. + + Lemma reflexive_proper_proxy `(Reflexive A R) (x : A) : ProperProxy R x. + Proof. firstorder. Qed. + + Lemma proper_proper_proxy x `(Proper R x) : ProperProxy R x. + Proof. firstorder. Qed. + + (** Respectful morphisms. *) + + (** The fully dependent version, not used yet. *) + + Definition respectful_hetero + (A B : Type) + (C : A -> Type) (D : B -> Type) + (R : A -> B -> Type) + (R' : forall (x : A) (y : B), C x -> D y -> Type) : + (forall x : A, C x) -> (forall x : B, D x) -> Type := + fun f g => forall x y, R x y -> R' x y (f x) (g y). + + (** The non-dependent version is an instance where we forget dependencies. *) + + Definition respectful (R : crelation A) (R' : crelation B) : crelation (A -> B) := + Eval compute in @respectful_hetero A A (fun _ => B) (fun _ => B) R (fun _ _ => R'). + +End Proper. + +(** We favor the use of Leibniz equality or a declared reflexive crelation + when resolving [ProperProxy], otherwise, if the crelation is given (not an evar), + we fall back to [Proper]. *) +Hint Extern 1 (ProperProxy _ _) => + class_apply @eq_proper_proxy || class_apply @reflexive_proper_proxy : typeclass_instances. + +Hint Extern 2 (ProperProxy ?R _) => + not_evar R; class_apply @proper_proper_proxy : typeclass_instances. + +(** Notations reminiscent of the old syntax for declaring morphisms. *) +Delimit Scope signature_scope with signature. + +Module ProperNotations. + + Notation " R ++> R' " := (@respectful _ _ (R%signature) (R'%signature)) + (right associativity, at level 55) : signature_scope. + + Notation " R ==> R' " := (@respectful _ _ (R%signature) (R'%signature)) + (right associativity, at level 55) : signature_scope. + + Notation " R --> R' " := (@respectful _ _ (flip (R%signature)) (R'%signature)) + (right associativity, at level 55) : signature_scope. + +End ProperNotations. + +Arguments Proper {A}%type R%signature m. +Arguments respectful {A B}%type (R R')%signature _ _. + +Export ProperNotations. + +Local Open Scope signature_scope. + +(** [solve_proper] try to solve the goal [Proper (?==> ... ==>?) f] + by repeated introductions and setoid rewrites. It should work + fine when [f] is a combination of already known morphisms and + quantifiers. *) + +Ltac solve_respectful t := + match goal with + | |- respectful _ _ _ _ => + let H := fresh "H" in + intros ? ? H; solve_respectful ltac:(setoid_rewrite H; t) + | _ => t; reflexivity + end. + +Ltac solve_proper := unfold Proper; solve_respectful ltac:(idtac). + +(** [f_equiv] is a clone of [f_equal] that handles setoid equivalences. + For example, if we know that [f] is a morphism for [E1==>E2==>E], + then the goal [E (f x y) (f x' y')] will be transformed by [f_equiv] + into the subgoals [E1 x x'] and [E2 y y']. +*) + +Ltac f_equiv := + match goal with + | |- ?R (?f ?x) (?f' _) => + let T := type of x in + let Rx := fresh "R" in + evar (Rx : crelation T); + let H := fresh in + assert (H : (Rx==>R)%signature f f'); + unfold Rx in *; clear Rx; [ f_equiv | apply H; clear H; try reflexivity ] + | |- ?R ?f ?f' => + solve [change (Proper R f); eauto with typeclass_instances | reflexivity ] + | _ => idtac + end. + +Section Relations. + Let U := Type. + Context {A B : U}. + + (** [forall_def] reifies the dependent product as a definition. *) + + Definition forall_def (P : A -> U) : Type := forall x : A, P x. + + (** Dependent pointwise lifting of a crelation on the range. *) + + Definition forall_relation (P : A -> U) + (sig : forall a, crelation (P a)) : crelation (forall x, P x) := + fun f g => forall a, sig a (f a) (g a). + + (** Non-dependent pointwise lifting *) + Definition pointwise_relation (R : crelation B) : crelation (A -> B) := + fun f g => forall a, R (f a) (g a). + + Lemma pointwise_pointwise (R : crelation B) : + relation_equivalence (pointwise_relation R) (@eq A ==> R). + Proof. intros. split. simpl_crelation. firstorder. Qed. + + (** Subcrelations induce a morphism on the identity. *) + + Global Instance subrelation_id_proper `(subrelation A RA RA') : Proper (RA ==> RA') id. + Proof. firstorder. Qed. + + (** The subrelation property goes through products as usual. *) + + Lemma subrelation_respectful `(subl : subrelation A RA' RA, subr : subrelation B RB RB') : + subrelation (RA ==> RB) (RA' ==> RB'). + Proof. simpl_crelation. Qed. + + (** And of course it is reflexive. *) + + Lemma subrelation_refl R : @subrelation A R R. + Proof. simpl_crelation. Qed. + + (** [Proper] is itself a covariant morphism for [subrelation]. + We use an unconvertible premise to avoid looping. + *) + + Lemma subrelation_proper `(mor : Proper A R' m) + `(unc : Unconvertible (crelation A) R R') + `(sub : subrelation A R' R) : Proper R m. + Proof. + intros. apply sub. apply mor. + Qed. + + Global Instance proper_subrelation_proper : + Proper (subrelation ++> eq ==> impl) (@Proper A). + Proof. reduce. subst. firstorder. Qed. + + Global Instance proper_subrelation_proper_arrow : + Proper (subrelation ++> eq ==> arrow) (@Proper A). + Proof. reduce. subst. firstorder. Qed. + + Global Instance pointwise_subrelation `(sub : subrelation B R R') : + subrelation (pointwise_relation R) (pointwise_relation R') | 4. + Proof. reduce. unfold pointwise_relation in *. apply sub. auto. Qed. + + (** For dependent function types. *) + Lemma forall_subrelation (P : A -> U) (R S : forall x : A, crelation (P x)) : + (forall a, subrelation (R a) (S a)) -> + subrelation (forall_relation P R) (forall_relation P S). + Proof. reduce. firstorder. Qed. +End Relations. + +Typeclasses Opaque respectful pointwise_relation forall_relation. +Arguments forall_relation {A P}%type sig%signature _ _. +Arguments pointwise_relation A%type {B}%type R%signature _ _. + +Hint Unfold Reflexive : core. +Hint Unfold Symmetric : core. +Hint Unfold Transitive : core. + +(** Resolution with subrelation: favor decomposing products over applying reflexivity + for unconstrained goals. *) +Ltac subrelation_tac T U := + (is_ground T ; is_ground U ; class_apply @subrelation_refl) || + class_apply @subrelation_respectful || class_apply @subrelation_refl. + +Hint Extern 3 (@subrelation _ ?T ?U) => subrelation_tac T U : typeclass_instances. + +CoInductive apply_subrelation : Prop := do_subrelation. + +Ltac proper_subrelation := + match goal with + [ H : apply_subrelation |- _ ] => clear H ; class_apply @subrelation_proper + end. + +Hint Extern 5 (@Proper _ ?H _) => proper_subrelation : typeclass_instances. + +(** Essential subrelation instances for [iff], [impl] and [pointwise_relation]. *) + +Instance iff_impl_subrelation : subrelation iff impl | 2. +Proof. firstorder. Qed. + +Instance iff_flip_impl_subrelation : subrelation iff (flip impl) | 2. +Proof. firstorder. Qed. + +(** Essential subrelation instances for [iffT] and [arrow]. *) + +Instance iffT_arrow_subrelation : subrelation iffT arrow | 2. +Proof. firstorder. Qed. + +Instance iffT_flip_arrow_subrelation : subrelation iffT (flip arrow) | 2. +Proof. firstorder. Qed. + +(** We use an extern hint to help unification. *) + +Hint Extern 4 (subrelation (@forall_relation ?A ?B ?R) (@forall_relation _ _ ?S)) => + apply (@forall_subrelation A B R S) ; intro : typeclass_instances. + +Section GenericInstances. + (* Share universes *) + Let U := Type. + Context {A B C : U}. + + (** We can build a PER on the Coq function space if we have PERs on the domain and + codomain. *) + + Program Instance respectful_per `(PER A R, PER B R') : PER (R ==> R'). + + Next Obligation. + Proof with auto. + assert(R x0 x0). + transitivity y0... symmetry... + transitivity (y x0)... + Qed. + + (** The complement of a crelation conserves its proper elements. *) + + Program Definition complement_proper + `(mR : Proper (A -> A -> Prop) (RA ==> RA ==> iff) R) : + Proper (RA ==> RA ==> iff) (complement R) := _. + + Next Obligation. + Proof. + unfold complement. + pose (mR x y X x0 y0 X0). + intuition. + Qed. + + (** The [flip] too, actually the [flip] instance is a bit more general. *) + + Program Definition flip_proper + `(mor : Proper (A -> B -> C) (RA ==> RB ==> RC) f) : + Proper (RB ==> RA ==> RC) (flip f) := _. + + Next Obligation. + Proof. + apply mor ; auto. + Qed. + + + (** Every Transitive crelation gives rise to a binary morphism on [impl], + contravariant in the first argument, covariant in the second. *) + + Global Program + Instance trans_contra_co_morphism + `(Transitive A R) : Proper (R --> R ++> impl) R. + + Next Obligation. + Proof with auto. + transitivity x... + transitivity x0... + Qed. + + Global Program + Instance trans_contra_co_type_morphism + `(Transitive A R) : Proper (R --> R ++> arrow) R. + + Next Obligation. + Proof with auto. + transitivity x... + transitivity x0... + Qed. + + (** Proper declarations for partial applications. *) + + Global Program + Instance trans_contra_inv_impl_morphism + `(Transitive A R) : Proper (R --> flip impl) (R x) | 3. + + Next Obligation. + Proof with auto. + transitivity y... + Qed. + + Global Program + Instance trans_contra_inv_impl_type_morphism + `(Transitive A R) : Proper (R --> flip arrow) (R x) | 3. + + Next Obligation. + Proof with auto. + transitivity y... + Qed. + + Global Program + Instance trans_co_impl_morphism + `(Transitive A R) : Proper (R ++> impl) (R x) | 3. + + Next Obligation. + Proof with auto. + transitivity x0... + Qed. + + Global Program + Instance trans_co_impl_type_morphism + `(Transitive A R) : Proper (R ++> arrow) (R x) | 3. + + Next Obligation. + Proof with auto. + transitivity x0... + Qed. + + Global Program + Instance trans_sym_co_inv_impl_morphism + `(PER A R) : Proper (R ++> flip impl) (R x) | 3. + + Next Obligation. + Proof with auto. + transitivity y... symmetry... + Qed. + + Global Program + Instance trans_sym_co_inv_impl_type_morphism + `(PER A R) : Proper (R ++> flip arrow) (R x) | 3. + + Next Obligation. + Proof with auto. + transitivity y... symmetry... + Qed. + + Global Program Instance trans_sym_contra_impl_morphism + `(PER A R) : Proper (R --> impl) (R x) | 3. + + Next Obligation. + Proof with auto. + transitivity x0... symmetry... + Qed. + + Global Program Instance trans_sym_contra_arrow_morphism + `(PER A R) : Proper (R --> arrow) (R x) | 3. + + Next Obligation. + Proof with auto. + transitivity x0... symmetry... + Qed. + + Global Program Instance per_partial_app_morphism + `(PER A R) : Proper (R ==> iff) (R x) | 2. + + Next Obligation. + Proof with auto. + split. intros ; transitivity x0... + intros. + transitivity y... + symmetry... + Qed. + + Global Program Instance per_partial_app_type_morphism + `(PER A R) : Proper (R ==> iffT) (R x) | 2. + + Next Obligation. + Proof with auto. + split. intros ; transitivity x0... + intros. + transitivity y... + symmetry... + Qed. + + (** Every Transitive crelation induces a morphism by "pushing" an [R x y] on the left of an [R x z] proof to get an [R y z] goal. *) + + Global Program + Instance trans_co_eq_inv_impl_morphism + `(Transitive A R) : Proper (R ==> (@eq A) ==> flip impl) R | 2. + + Next Obligation. + Proof with auto. + transitivity y... + Qed. + + Global Program + Instance trans_co_eq_inv_arrow_morphism + `(Transitive A R) : Proper (R ==> (@eq A) ==> flip arrow) R | 2. + + Next Obligation. + Proof with auto. + transitivity y... + Qed. + + (** Every Symmetric and Transitive crelation gives rise to an equivariant morphism. *) + + Global Program + Instance PER_morphism `(PER A R) : Proper (R ==> R ==> iff) R | 1. + + Next Obligation. + Proof with auto. + split ; intros. + transitivity x0... transitivity x... symmetry... + + transitivity y... transitivity y0... symmetry... + Qed. + + (** Every Symmetric and Transitive crelation gives rise to an equivariant morphism. *) + + Global Program + Instance PER_type_morphism `(PER A R) : Proper (R ==> R ==> iffT) R | 1. + + Next Obligation. + Proof with auto. + split ; intros. + transitivity x0... transitivity x... symmetry... + + transitivity y... transitivity y0... symmetry... + Qed. + + Lemma symmetric_equiv_flip `(Symmetric A R) : relation_equivalence R (flip R). + Proof. firstorder. Qed. + + Global Program Instance compose_proper RA RB RC : + Proper ((RB ==> RC) ==> (RA ==> RB) ==> (RA ==> RC)) (@compose A B C). + + Next Obligation. + Proof. + simpl_crelation. + unfold compose. firstorder. + Qed. + + (** Coq functions are morphisms for Leibniz equality, + applied only if really needed. *) + + Global Instance reflexive_eq_dom_reflexive `(Reflexive B R') : + Reflexive (@Logic.eq A ==> R'). + Proof. simpl_crelation. Qed. + + (** [respectful] is a morphism for crelation equivalence. *) + + Global Instance respectful_morphism : + Proper (relation_equivalence ++> relation_equivalence ++> relation_equivalence) + (@respectful A B). + Proof. + intros R R' HRR' S S' HSS' f g. + unfold respectful, relation_equivalence in * ; simpl in *. + split ; intros H x y Hxy. + setoid_rewrite <- HSS'. apply H. now rewrite HRR'. + rewrite HSS'. apply H. now rewrite <- HRR'. + Qed. + + (** [R] is Reflexive, hence we can build the needed proof. *) + + Lemma Reflexive_partial_app_morphism `(Proper (A -> B) (R ==> R') m, ProperProxy A R x) : + Proper R' (m x). + Proof. simpl_crelation. Qed. + + Class Params (of : A) (arity : nat). + + Lemma flip_respectful (R : crelation A) (R' : crelation B) : + relation_equivalence (flip (R ==> R')) (flip R ==> flip R'). + Proof. + intros. + unfold flip, respectful. + split ; intros ; intuition. + Qed. + + + (** Treating flip: can't make them direct instances as we + need at least a [flip] present in the goal. *) + + Lemma flip1 `(subrelation A R' R) : subrelation (flip (flip R')) R. + Proof. firstorder. Qed. + + Lemma flip2 `(subrelation A R R') : subrelation R (flip (flip R')). + Proof. firstorder. Qed. + + (** That's if and only if *) + + Lemma eq_subrelation `(Reflexive A R) : subrelation (@eq A) R. + Proof. simpl_crelation. Qed. + + (** Once we have normalized, we will apply this instance to simplify the problem. *) + + Definition proper_flip_proper `(mor : Proper A R m) : Proper (flip R) m := mor. + + (** Every reflexive crelation gives rise to a morphism, + only for immediately solving goals without variables. *) + + Lemma reflexive_proper `{Reflexive A R} (x : A) : Proper R x. + Proof. firstorder. Qed. + + Lemma proper_eq (x : A) : Proper (@eq A) x. + Proof. intros. apply reflexive_proper. Qed. + +End GenericInstances. + +Class PartialApplication. + +CoInductive normalization_done : Prop := did_normalization. + +Ltac partial_application_tactic := + let rec do_partial_apps H m cont := + match m with + | ?m' ?x => class_apply @Reflexive_partial_app_morphism ; + [(do_partial_apps H m' ltac:idtac)|clear H] + | _ => cont + end + in + let rec do_partial H ar m := + match ar with + | 0%nat => do_partial_apps H m ltac:(fail 1) + | S ?n' => + match m with + ?m' ?x => do_partial H n' m' + end + end + in + let params m sk fk := + (let m' := fresh in head_of_constr m' m ; + let n := fresh in evar (n:nat) ; + let v := eval compute in n in clear n ; + let H := fresh in + assert(H:Params m' v) by typeclasses eauto ; + let v' := eval compute in v in subst m'; + (sk H v' || fail 1)) + || fk + in + let on_morphism m cont := + params m ltac:(fun H n => do_partial H n m) + ltac:(cont) + in + match goal with + | [ _ : normalization_done |- _ ] => fail 1 + | [ _ : @Params _ _ _ |- _ ] => fail 1 + | [ |- @Proper ?T _ (?m ?x) ] => + match goal with + | [ H : PartialApplication |- _ ] => + class_apply @Reflexive_partial_app_morphism; [|clear H] + | _ => on_morphism (m x) + ltac:(class_apply @Reflexive_partial_app_morphism) + end + end. + +(** Bootstrap !!! *) + +Instance proper_proper : Proper (relation_equivalence ==> eq ==> iffT) (@Proper A). +Proof. + intros A R R' HRR' x y <-. red in HRR'. + split ; red ; intros. + now setoid_rewrite <- HRR'. + now setoid_rewrite HRR'. +Qed. + +Ltac proper_reflexive := + match goal with + | [ _ : normalization_done |- _ ] => fail 1 + | _ => class_apply proper_eq || class_apply @reflexive_proper + end. + + +Hint Extern 1 (subrelation (flip _) _) => class_apply @flip1 : typeclass_instances. +Hint Extern 1 (subrelation _ (flip _)) => class_apply @flip2 : typeclass_instances. + +Hint Extern 1 (Proper _ (complement _)) => apply @complement_proper + : typeclass_instances. +Hint Extern 1 (Proper _ (flip _)) => apply @flip_proper + : typeclass_instances. +Hint Extern 2 (@Proper _ (flip _) _) => class_apply @proper_flip_proper + : typeclass_instances. +Hint Extern 4 (@Proper _ _ _) => partial_application_tactic + : typeclass_instances. +Hint Extern 7 (@Proper _ _ _) => proper_reflexive + : typeclass_instances. + +(** Special-purpose class to do normalization of signatures w.r.t. flip. *) + +Section Normalize. + Context (A : Type). + + Class Normalizes (m : crelation A) (m' : crelation A) : Prop := + normalizes : relation_equivalence m m'. + + (** Current strategy: add [flip] everywhere and reduce using [subrelation] + afterwards. *) + + Lemma proper_normalizes_proper `(Normalizes R0 R1, Proper A R1 m) : Proper R0 m. + Proof. + red in H, H0. red in H. + setoid_rewrite H. + assumption. + Qed. + + Lemma flip_atom R : Normalizes R (flip (flip R)). + Proof. + firstorder. + Qed. + +End Normalize. + +Lemma flip_arrow `(NA : Normalizes A R (flip R'''), NB : Normalizes B R' (flip R'')) : + Normalizes (A -> B) (R ==> R') (flip (R''' ==> R'')%signature). +Proof. + unfold Normalizes in *. intros. + rewrite NA, NB. firstorder. +Qed. + +Ltac normalizes := + match goal with + | [ |- Normalizes _ (respectful _ _) _ ] => class_apply @flip_arrow + | _ => class_apply @flip_atom + end. + +Ltac proper_normalization := + match goal with + | [ _ : normalization_done |- _ ] => fail 1 + | [ _ : apply_subrelation |- @Proper _ ?R _ ] => + let H := fresh "H" in + set(H:=did_normalization) ; class_apply @proper_normalizes_proper + end. + +Hint Extern 1 (Normalizes _ _ _) => normalizes : typeclass_instances. +Hint Extern 6 (@Proper _ _ _) => proper_normalization + : typeclass_instances. + +(** When the crelation on the domain is symmetric, we can + flip the crelation on the codomain. Same for binary functions. *) + +Lemma proper_sym_flip : + forall `(Symmetric A R1)`(Proper (A->B) (R1==>R2) f), + Proper (R1==>flip R2) f. +Proof. +intros A R1 Sym B R2 f Hf. +intros x x' Hxx'. apply Hf, Sym, Hxx'. +Qed. + +Lemma proper_sym_flip_2 : + forall `(Symmetric A R1)`(Symmetric B R2)`(Proper (A->B->C) (R1==>R2==>R3) f), + Proper (R1==>R2==>flip R3) f. +Proof. +intros A R1 Sym1 B R2 Sym2 C R3 f Hf. +intros x x' Hxx' y y' Hyy'. apply Hf; auto. +Qed. + +(** When the crelation on the domain is symmetric, a predicate is + compatible with [iff] as soon as it is compatible with [impl]. + Same with a binary crelation. *) + +Lemma proper_sym_impl_iff : forall `(Symmetric A R)`(Proper _ (R==>impl) f), + Proper (R==>iff) f. +Proof. +intros A R Sym f Hf x x' Hxx'. repeat red in Hf. split; eauto. +Qed. + +Lemma proper_sym_arrow_iffT : forall `(Symmetric A R)`(Proper _ (R==>arrow) f), + Proper (R==>iffT) f. +Proof. +intros A R Sym f Hf x x' Hxx'. repeat red in Hf. split; eauto. +Qed. + +Lemma proper_sym_impl_iff_2 : + forall `(Symmetric A R)`(Symmetric B R')`(Proper _ (R==>R'==>impl) f), + Proper (R==>R'==>iff) f. +Proof. +intros A R Sym B R' Sym' f Hf x x' Hxx' y y' Hyy'. +repeat red in Hf. split; eauto. +Qed. + +Lemma proper_sym_arrow_iffT_2 : + forall `(Symmetric A R)`(Symmetric B R')`(Proper _ (R==>R'==>arrow) f), + Proper (R==>R'==>iffT) f. +Proof. +intros A R Sym B R' Sym' f Hf x x' Hxx' y y' Hyy'. +repeat red in Hf. split; eauto. +Qed. + +(** A [PartialOrder] is compatible with its underlying equivalence. *) +Require Import Relation_Definitions. +Instance PartialOrder_proper `(PartialOrder A eqA (R : relation A)) : + Proper (eqA==>eqA==>iff) R. +Proof. +intros. +apply proper_sym_impl_iff_2; auto with *. +intros x x' Hx y y' Hy Hr. +transitivity x. +generalize (partial_order_equivalence x x'); compute; intuition. +transitivity y; auto. +generalize (partial_order_equivalence y y'); compute; intuition. +Qed. + +Instance PartialOrder_proper_type `(PartialOrder A eqA R) : + Proper (eqA==>eqA==>iffT) R. +Proof. +intros. +apply proper_sym_arrow_iffT_2; auto with *. +intros x x' Hx y y' Hy Hr. +transitivity x. +generalize (partial_order_equivalence x x'); compute; intuition. +transitivity y; auto. +generalize (partial_order_equivalence y y'); compute; intuition. +Qed. + +(** From a [PartialOrder] to the corresponding [StrictOrder]: + [lt = le /\ ~eq]. + If the order is total, we could also say [gt = ~le]. *) + +Lemma PartialOrder_StrictOrder `(PartialOrder A eqA R) : + StrictOrder (relation_conjunction R (complement eqA)). +Proof. +split; compute. +intros x (_,Hx). apply Hx, Equivalence_Reflexive. +intros x y z (Hxy,Hxy') (Hyz,Hyz'). split. +apply PreOrder_Transitive with y; assumption. +intro Hxz. +apply Hxy'. +apply partial_order_antisym; auto. +rewrite Hxz. auto. +Qed. + +(** From a [StrictOrder] to the corresponding [PartialOrder]: + [le = lt \/ eq]. + If the order is total, we could also say [ge = ~lt]. *) + +Lemma StrictOrder_PreOrder + `(Equivalence A eqA, StrictOrder A R, Proper _ (eqA==>eqA==>iffT) R) : + PreOrder (relation_disjunction R eqA). +Proof. +split. +intros x. right. reflexivity. +intros x y z [Hxy|Hxy] [Hyz|Hyz]. +left. transitivity y; auto. +left. rewrite <- Hyz; auto. +left. rewrite Hxy; auto. +right. transitivity y; auto. +Qed. + +Hint Extern 4 (PreOrder (relation_disjunction _ _)) => + class_apply StrictOrder_PreOrder : typeclass_instances. + +Lemma StrictOrder_PartialOrder + `(Equivalence A eqA, StrictOrder A R, Proper _ (eqA==>eqA==>iffT) R) : + PartialOrder eqA (relation_disjunction R eqA). +Proof. +intros. intros x y. compute. intuition. +elim (StrictOrder_Irreflexive x). +transitivity y; auto. +Qed. + +Hint Extern 4 (StrictOrder (relation_conjunction _ _)) => + class_apply PartialOrder_StrictOrder : typeclass_instances. + +Hint Extern 4 (PartialOrder _ (relation_disjunction _ _)) => + class_apply StrictOrder_PartialOrder : typeclass_instances. diff --git a/theories/Classes/CRelationClasses.v b/theories/Classes/CRelationClasses.v new file mode 100644 index 000000000..ca38ac5b4 --- /dev/null +++ b/theories/Classes/CRelationClasses.v @@ -0,0 +1,354 @@ +(* -*- coding: utf-8 -*- *) +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** * Typeclass-based relations, tactics and standard instances + + This is the basic theory needed to formalize morphisms and setoids. + + Author: Matthieu Sozeau + Institution: LRI, CNRS UMR 8623 - University Paris Sud +*) + +Require Export Coq.Classes.Init. +Require Import Coq.Program.Basics. +Require Import Coq.Program.Tactics. + +Generalizable Variables A B C D R S T U l eqA eqB eqC eqD. + +Set Universe Polymorphism. + +Definition crelation (A : Type) := A -> A -> Type. + +Definition iffT (A B : Type) := ((A -> B) * (B -> A))%type. + +(** We allow to unfold the [crelation] definition while doing morphism search. *) + +Section Defs. + Context {A : Type}. + + (** We rebind crelational properties in separate classes to be able to overload each proof. *) + + Class Reflexive (R : crelation A) := + reflexivity : forall x : A, R x x. + + Definition complement (R : crelation A) : crelation A := + fun x y => R x y -> False. + + (** Opaque for proof-search. *) + Typeclasses Opaque complement iffT. + + (** These are convertible. *) + Lemma complement_inverse R : complement (flip R) = flip (complement R). + Proof. reflexivity. Qed. + + Class Irreflexive (R : crelation A) := + irreflexivity : Reflexive (complement R). + + Class Symmetric (R : crelation A) := + symmetry : forall {x y}, R x y -> R y x. + + Class Asymmetric (R : crelation A) := + asymmetry : forall {x y}, R x y -> (complement R y x : Type). + + Class Transitive (R : crelation A) := + transitivity : forall {x y z}, R x y -> R y z -> R x z. + + (** Various combinations of reflexivity, symmetry and transitivity. *) + + (** A [PreOrder] is both Reflexive and Transitive. *) + + Class PreOrder (R : crelation A) := { + PreOrder_Reflexive :> Reflexive R | 2 ; + PreOrder_Transitive :> Transitive R | 2 }. + + (** A [StrictOrder] is both Irreflexive and Transitive. *) + + Class StrictOrder (R : crelation A) := { + StrictOrder_Irreflexive :> Irreflexive R ; + StrictOrder_Transitive :> Transitive R }. + + (** By definition, a strict order is also asymmetric *) + Global Instance StrictOrder_Asymmetric `(StrictOrder R) : Asymmetric R. + Proof. firstorder. Qed. + + (** A partial equivalence crelation is Symmetric and Transitive. *) + + Class PER (R : crelation A) := { + PER_Symmetric :> Symmetric R | 3 ; + PER_Transitive :> Transitive R | 3 }. + + (** Equivalence crelations. *) + + Class Equivalence (R : crelation A) := { + Equivalence_Reflexive :> Reflexive R ; + Equivalence_Symmetric :> Symmetric R ; + Equivalence_Transitive :> Transitive R }. + + (** An Equivalence is a PER plus reflexivity. *) + + Global Instance Equivalence_PER {R} `(Equivalence R) : PER R | 10 := + { PER_Symmetric := Equivalence_Symmetric ; + PER_Transitive := Equivalence_Transitive }. + + (** We can now define antisymmetry w.r.t. an equivalence crelation on the carrier. *) + + Class Antisymmetric eqA `{equ : Equivalence eqA} (R : crelation A) := + antisymmetry : forall {x y}, R x y -> R y x -> eqA x y. + + Class subrelation (R R' : crelation A) := + is_subrelation : forall {x y}, R x y -> R' x y. + + (** Any symmetric crelation is equal to its inverse. *) + + Lemma subrelation_symmetric R `(Symmetric R) : subrelation (flip R) R. + Proof. hnf. intros x y H'. red in H'. apply symmetry. assumption. Qed. + + Section flip. + + Lemma flip_Reflexive `{Reflexive R} : Reflexive (flip R). + Proof. tauto. Qed. + + Program Definition flip_Irreflexive `(Irreflexive R) : Irreflexive (flip R) := + irreflexivity (R:=R). + + Program Definition flip_Symmetric `(Symmetric R) : Symmetric (flip R) := + fun x y H => symmetry (R:=R) H. + + Program Definition flip_Asymmetric `(Asymmetric R) : Asymmetric (flip R) := + fun x y H H' => asymmetry (R:=R) H H'. + + Program Definition flip_Transitive `(Transitive R) : Transitive (flip R) := + fun x y z H H' => transitivity (R:=R) H' H. + + Program Definition flip_Antisymmetric `(Antisymmetric eqA R) : + Antisymmetric eqA (flip R). + Proof. firstorder. Qed. + + (** Inversing the larger structures *) + + Lemma flip_PreOrder `(PreOrder R) : PreOrder (flip R). + Proof. firstorder. Qed. + + Lemma flip_StrictOrder `(StrictOrder R) : StrictOrder (flip R). + Proof. firstorder. Qed. + + Lemma flip_PER `(PER R) : PER (flip R). + Proof. firstorder. Qed. + + Lemma flip_Equivalence `(Equivalence R) : Equivalence (flip R). + Proof. firstorder. Qed. + + End flip. + + Section complement. + + Definition complement_Irreflexive `(Reflexive R) + : Irreflexive (complement R). + Proof. firstorder. Qed. + + Definition complement_Symmetric `(Symmetric R) : Symmetric (complement R). + Proof. firstorder. Qed. + End complement. + + + (** Rewrite crelation on a given support: declares a crelation as a rewrite + crelation for use by the generalized rewriting tactic. + It helps choosing if a rewrite should be handled + by the generalized or the regular rewriting tactic using leibniz equality. + Users can declare an [RewriteRelation A RA] anywhere to declare default + crelations. This is also done automatically by the [Declare Relation A RA] + commands. *) + + Class RewriteRelation (RA : crelation A). + + (** Any [Equivalence] declared in the context is automatically considered + a rewrite crelation. *) + + Global Instance equivalence_rewrite_crelation `(Equivalence eqA) : RewriteRelation eqA. + + (** Leibniz equality. *) + Section Leibniz. + Global Instance eq_Reflexive : Reflexive (@eq A) := @eq_refl A. + Global Instance eq_Symmetric : Symmetric (@eq A) := @eq_sym A. + Global Instance eq_Transitive : Transitive (@eq A) := @eq_trans A. + + (** Leibinz equality [eq] is an equivalence crelation. + The instance has low priority as it is always applicable + if only the type is constrained. *) + + Global Program Instance eq_equivalence : Equivalence (@eq A) | 10. + End Leibniz. + +End Defs. + +(** Default rewrite crelations handled by [setoid_rewrite]. *) +Instance: RewriteRelation impl. +Instance: RewriteRelation iff. + +(** Hints to drive the typeclass resolution avoiding loops + due to the use of full unification. *) +Hint Extern 1 (Reflexive (complement _)) => class_apply @irreflexivity : typeclass_instances. +Hint Extern 3 (Symmetric (complement _)) => class_apply complement_Symmetric : typeclass_instances. +Hint Extern 3 (Irreflexive (complement _)) => class_apply complement_Irreflexive : typeclass_instances. + +Hint Extern 3 (Reflexive (flip _)) => apply flip_Reflexive : typeclass_instances. +Hint Extern 3 (Irreflexive (flip _)) => class_apply flip_Irreflexive : typeclass_instances. +Hint Extern 3 (Symmetric (flip _)) => class_apply flip_Symmetric : typeclass_instances. +Hint Extern 3 (Asymmetric (flip _)) => class_apply flip_Asymmetric : typeclass_instances. +Hint Extern 3 (Antisymmetric (flip _)) => class_apply flip_Antisymmetric : typeclass_instances. +Hint Extern 3 (Transitive (flip _)) => class_apply flip_Transitive : typeclass_instances. +Hint Extern 3 (StrictOrder (flip _)) => class_apply flip_StrictOrder : typeclass_instances. +Hint Extern 3 (PreOrder (flip _)) => class_apply flip_PreOrder : typeclass_instances. + +Hint Extern 4 (subrelation (flip _) _) => + class_apply @subrelation_symmetric : typeclass_instances. + +Hint Resolve irreflexivity : ord. + +Unset Implicit Arguments. + +(** A HintDb for crelations. *) + +Ltac solve_crelation := + match goal with + | [ |- ?R ?x ?x ] => reflexivity + | [ H : ?R ?x ?y |- ?R ?y ?x ] => symmetry ; exact H + end. + +Hint Extern 4 => solve_crelation : crelations. + +(** We can already dualize all these properties. *) + +(** * Standard instances. *) + +Ltac reduce_hyp H := + match type of H with + | context [ _ <-> _ ] => fail 1 + | _ => red in H ; try reduce_hyp H + end. + +Ltac reduce_goal := + match goal with + | [ |- _ <-> _ ] => fail 1 + | _ => red ; intros ; try reduce_goal + end. + +Tactic Notation "reduce" "in" hyp(Hid) := reduce_hyp Hid. + +Ltac reduce := reduce_goal. + +Tactic Notation "apply" "*" constr(t) := + first [ refine t | refine (t _) | refine (t _ _) | refine (t _ _ _) | refine (t _ _ _ _) | + refine (t _ _ _ _ _) | refine (t _ _ _ _ _ _) | refine (t _ _ _ _ _ _ _) ]. + +Ltac simpl_crelation := + unfold flip, impl, arrow ; try reduce ; program_simpl ; + try ( solve [ dintuition ]). + +Local Obligation Tactic := simpl_crelation. + +(** Logical implication. *) + +Program Instance impl_Reflexive : Reflexive impl. +Program Instance impl_Transitive : Transitive impl. + +(** Logical equivalence. *) + +Instance iff_Reflexive : Reflexive iff := iff_refl. +Instance iff_Symmetric : Symmetric iff := iff_sym. +Instance iff_Transitive : Transitive iff := iff_trans. + +(** Logical equivalence [iff] is an equivalence crelation. *) + +Program Instance iff_equivalence : Equivalence iff. + +Program Instance arrow_Reflexive : Reflexive arrow. +Program Instance arrow_Transitive : Transitive arrow. + +Instance iffT_Reflexive : Reflexive iffT. +Proof. firstorder. Defined. +Instance iffT_Symmetric : Symmetric iffT. +Proof. firstorder. Defined. +Instance iffT_Transitive : Transitive iffT. +Proof. firstorder. Defined. + +(** We now develop a generalization of results on crelations for arbitrary predicates. + The resulting theory can be applied to homogeneous binary crelations but also to + arbitrary n-ary predicates. *) + +Local Open Scope list_scope. + +(** A compact representation of non-dependent arities, with the codomain singled-out. *) + +(** We define the various operations which define the algebra on binary crelations *) +Section Binary. + Context {A : Type}. + + Definition relation_equivalence : crelation (crelation A) := + fun R R' => forall x y, iffT (R x y) (R' x y). + + Global Instance: RewriteRelation relation_equivalence. + + Definition relation_conjunction (R : crelation A) (R' : crelation A) : crelation A := + fun x y => prod (R x y) (R' x y). + + Definition relation_disjunction (R : crelation A) (R' : crelation A) : crelation A := + fun x y => sum (R x y) (R' x y). + + (** Relation equivalence is an equivalence, and subrelation defines a partial order. *) + + Set Automatic Introduction. + + Global Instance relation_equivalence_equivalence : + Equivalence relation_equivalence. + Proof. split; red; unfold relation_equivalence, iffT. firstorder. + firstorder. + intros. specialize (X x0 y0). specialize (X0 x0 y0). firstorder. + Qed. + + Global Instance relation_implication_preorder : PreOrder (@subrelation A). + Proof. firstorder. Qed. + + (** *** Partial Order. + A partial order is a preorder which is additionally antisymmetric. + We give an equivalent definition, up-to an equivalence crelation + on the carrier. *) + + Class PartialOrder eqA `{equ : Equivalence A eqA} R `{preo : PreOrder A R} := + partial_order_equivalence : relation_equivalence eqA (relation_conjunction R (flip R)). + + (** The equivalence proof is sufficient for proving that [R] must be a + morphism for equivalence (see Morphisms). It is also sufficient to + show that [R] is antisymmetric w.r.t. [eqA] *) + + Global Instance partial_order_antisym `(PartialOrder eqA R) : ! Antisymmetric A eqA R. + Proof with auto. + reduce_goal. + apply H. firstorder. + Qed. + + Lemma PartialOrder_inverse `(PartialOrder eqA R) : PartialOrder eqA (flip R). + Proof. firstorder. Qed. +End Binary. + +Hint Extern 3 (PartialOrder (flip _)) => class_apply PartialOrder_inverse : typeclass_instances. + +(** The partial order defined by subrelation and crelation equivalence. *) + +Program Instance subrelation_partial_order : + ! PartialOrder (crelation A) relation_equivalence subrelation. + +Next Obligation. +Proof. + unfold relation_equivalence in *. compute; firstorder. +Qed. + +Typeclasses Opaque relation_equivalence. + + diff --git a/theories/Classes/DecidableClass.v b/theories/Classes/DecidableClass.v index 6e6ba68a2..3b4ba786a 100644 --- a/theories/Classes/DecidableClass.v +++ b/theories/Classes/DecidableClass.v @@ -44,7 +44,7 @@ Qed. (** The generic function that should be used to program, together with some useful tactics. *) -Definition decide P {H : Decidable P} := @Decidable_witness P H. +Definition decide P {H : Decidable P} := Decidable_witness (Decidable:=H). Ltac _decide_ P H := let b := fresh "b" in diff --git a/theories/Classes/EquivDec.v b/theories/Classes/EquivDec.v index 39d7cdaa0..dcaf057b0 100644 --- a/theories/Classes/EquivDec.v +++ b/theories/Classes/EquivDec.v @@ -56,6 +56,7 @@ Local Open Scope program_scope. Program Definition nequiv_dec `{EqDec A} (x y : A) : { x =/= y } + { x === y } := swap_sumbool (x == y). + (** Overloaded notation for inequality. *) Infix "<>" := nequiv_dec (no associativity, at level 70) : equiv_scope. diff --git a/theories/Classes/Equivalence.v b/theories/Classes/Equivalence.v index 233e97c19..db04fbe39 100644 --- a/theories/Classes/Equivalence.v +++ b/theories/Classes/Equivalence.v @@ -24,7 +24,7 @@ Set Implicit Arguments. Unset Strict Implicit. Generalizable Variables A R eqA B S eqB. -Local Obligation Tactic := simpl_relation. +Local Obligation Tactic := try solve [simpl_relation]. Local Open Scope signature_scope. @@ -56,8 +56,8 @@ Program Instance equiv_symmetric `(sa : Equivalence A) : Symmetric equiv. Program Instance equiv_transitive `(sa : Equivalence A) : Transitive equiv. Next Obligation. - Proof. - transitivity y ; auto. + Proof. intros A R sa x y z Hxy Hyz. + now transitivity y. Qed. (** Use the [substitute] command which substitutes an equivalence in every hypothesis. *) @@ -116,8 +116,9 @@ Section Respecting. Solve Obligations with unfold respecting in * ; simpl_relation ; program_simpl. Next Obligation. - Proof. - unfold respecting in *. program_simpl. transitivity (y y0); auto. apply H0. reflexivity. + Proof. + intros. intros f g h H H' x y Rxy. + unfold respecting in *. program_simpl. transitivity (g y); auto. firstorder. Qed. End Respecting. diff --git a/theories/Classes/Morphisms.v b/theories/Classes/Morphisms.v index 617ff1906..921f21233 100644 --- a/theories/Classes/Morphisms.v +++ b/theories/Classes/Morphisms.v @@ -18,7 +18,7 @@ Require Import Coq.Program.Tactics. Require Import Coq.Relations.Relation_Definitions. Require Export Coq.Classes.RelationClasses. -Generalizable All Variables. +Generalizable Variables A eqA B C D R RA RB RC m f x y. Local Obligation Tactic := simpl_relation. (** * Morphisms. @@ -29,15 +29,39 @@ Local Obligation Tactic := simpl_relation. (** A morphism for a relation [R] is a proper element of the relation. The relation [R] will be instantiated by [respectful] and [A] by an arrow type for usual morphisms. *) - -Class Proper {A} (R : relation A) (m : A) : Prop := - proper_prf : R m m. - -(** Respectful morphisms. *) - -(** The fully dependent version, not used yet. *) - -Definition respectful_hetero +Section Proper. + Let U := Type. + Context {A B : U}. + + Class Proper (R : relation A) (m : A) : Prop := + proper_prf : R m m. + + (** Every element in the carrier of a reflexive relation is a morphism + for this relation. We use a proxy class for this case which is used + internally to discharge reflexivity constraints. The [Reflexive] + instance will almost always be used, but it won't apply in general to + any kind of [Proper (A -> B) _ _] goal, making proof-search much + slower. A cleaner solution would be to be able to set different + priorities in different hint bases and select a particular hint + database for resolution of a type class constraint. *) + + Class ProperProxy (R : relation A) (m : A) : Prop := + proper_proxy : R m m. + + Lemma eq_proper_proxy (x : A) : ProperProxy (@eq A) x. + Proof. firstorder. Qed. + + Lemma reflexive_proper_proxy `(Reflexive A R) (x : A) : ProperProxy R x. + Proof. firstorder. Qed. + + Lemma proper_proper_proxy x `(Proper R x) : ProperProxy R x. + Proof. firstorder. Qed. + + (** Respectful morphisms. *) + + (** The fully dependent version, not used yet. *) + + Definition respectful_hetero (A B : Type) (C : A -> Type) (D : B -> Type) (R : A -> B -> Prop) @@ -45,18 +69,24 @@ Definition respectful_hetero (forall x : A, C x) -> (forall x : B, D x) -> Prop := fun f g => forall x y, R x y -> R' x y (f x) (g y). -(** The non-dependent version is an instance where we forget dependencies. *) + (** The non-dependent version is an instance where we forget dependencies. *) + + Definition respectful (R : relation A) (R' : relation B) : relation (A -> B) := + Eval compute in @respectful_hetero A A (fun _ => B) (fun _ => B) R (fun _ _ => R'). -Definition respectful {A B : Type} - (R : relation A) (R' : relation B) : relation (A -> B) := - Eval compute in @respectful_hetero A A (fun _ => B) (fun _ => B) R (fun _ _ => R'). +End Proper. -(** Notations reminiscent of the old syntax for declaring morphisms. *) +(** We favor the use of Leibniz equality or a declared reflexive relation + when resolving [ProperProxy], otherwise, if the relation is given (not an evar), + we fall back to [Proper]. *) +Hint Extern 1 (ProperProxy _ _) => + class_apply @eq_proper_proxy || class_apply @reflexive_proper_proxy : typeclass_instances. -Delimit Scope signature_scope with signature. +Hint Extern 2 (ProperProxy ?R _) => + not_evar R; class_apply @proper_proper_proxy : typeclass_instances. -Arguments Proper {A}%type R%signature m. -Arguments respectful {A B}%type (R R')%signature _ _. +(** Notations reminiscent of the old syntax for declaring morphisms. *) +Delimit Scope signature_scope with signature. Module ProperNotations. @@ -66,11 +96,14 @@ Module ProperNotations. Notation " R ==> R' " := (@respectful _ _ (R%signature) (R'%signature)) (right associativity, at level 55) : signature_scope. - Notation " R --> R' " := (@respectful _ _ (inverse (R%signature)) (R'%signature)) + Notation " R --> R' " := (@respectful _ _ (flip (R%signature)) (R'%signature)) (right associativity, at level 55) : signature_scope. End ProperNotations. +Arguments Proper {A}%type R%signature m. +Arguments respectful {A B}%type (R R')%signature _ _. + Export ProperNotations. Local Open Scope signature_scope. @@ -106,80 +139,89 @@ Ltac f_equiv := assert (H : (Rx==>R)%signature f f'); unfold Rx in *; clear Rx; [ f_equiv | apply H; clear H; try reflexivity ] | |- ?R ?f ?f' => - try reflexivity; - change (Proper R f); eauto with typeclass_instances; fail + solve [change (Proper R f); eauto with typeclass_instances | reflexivity ] | _ => idtac end. -(** [forall_def] reifies the dependent product as a definition. *) - -Definition forall_def {A : Type} (B : A -> Type) : Type := forall x : A, B x. - -(** Dependent pointwise lifting of a relation on the range. *) - -Definition forall_relation {A : Type} {B : A -> Type} - (sig : forall a, relation (B a)) : relation (forall x, B x) := - fun f g => forall a, sig a (f a) (g a). - -Arguments forall_relation {A B}%type sig%signature _ _. - -(** Non-dependent pointwise lifting *) - -Definition pointwise_relation (A : Type) {B : Type} (R : relation B) : relation (A -> B) := - Eval compute in forall_relation (B:=fun _ => B) (fun _ => R). +Section Relations. + Let U := Type. + Context {A B : U} (P : A -> U). + + (** [forall_def] reifies the dependent product as a definition. *) + + Definition forall_def : Type := forall x : A, P x. + + (** Dependent pointwise lifting of a relation on the range. *) + + Definition forall_relation + (sig : forall a, relation (P a)) : relation (forall x, P x) := + fun f g => forall a, sig a (f a) (g a). + + (** Non-dependent pointwise lifting *) + Definition pointwise_relation (R : relation B) : relation (A -> B) := + fun f g => forall a, R (f a) (g a). + + Lemma pointwise_pointwise (R : relation B) : + relation_equivalence (pointwise_relation R) (@eq A ==> R). + Proof. intros. split; reduce; subst; firstorder. Qed. + + (** Subrelations induce a morphism on the identity. *) + + Global Instance subrelation_id_proper `(subrelation A RA RA') : Proper (RA ==> RA') id. + Proof. firstorder. Qed. + + (** The subrelation property goes through products as usual. *) + + Lemma subrelation_respectful `(subl : subrelation A RA' RA, subr : subrelation B RB RB') : + subrelation (RA ==> RB) (RA' ==> RB'). + Proof. unfold subrelation in *; firstorder. Qed. + + (** And of course it is reflexive. *) + + Lemma subrelation_refl R : @subrelation A R R. + Proof. unfold subrelation; firstorder. Qed. + + (** [Proper] is itself a covariant morphism for [subrelation]. + We use an unconvertible premise to avoid looping. + *) + + Lemma subrelation_proper `(mor : Proper A R' m) + `(unc : Unconvertible (relation A) R R') + `(sub : subrelation A R' R) : Proper R m. + Proof. + intros. apply sub. apply mor. + Qed. -Lemma pointwise_pointwise A B (R : relation B) : - relation_equivalence (pointwise_relation A R) (@eq A ==> R). -Proof. intros. split. simpl_relation. firstorder. Qed. + Global Instance proper_subrelation_proper : + Proper (subrelation ++> eq ==> impl) (@Proper A). + Proof. reduce. subst. firstorder. Qed. -(** We can build a PER on the Coq function space if we have PERs on the domain and - codomain. *) + Global Instance pointwise_subrelation `(sub : subrelation B R R') : + subrelation (pointwise_relation R) (pointwise_relation R') | 4. + Proof. reduce. unfold pointwise_relation in *. apply sub. apply H. Qed. + + (** For dependent function types. *) + Lemma forall_subrelation (R S : forall x : A, relation (P x)) : + (forall a, subrelation (R a) (S a)) -> subrelation (forall_relation R) (forall_relation S). + Proof. reduce. apply H. apply H0. Qed. +End Relations. +Typeclasses Opaque respectful pointwise_relation forall_relation. +Arguments forall_relation {A P}%type sig%signature _ _. +Arguments pointwise_relation A%type {B}%type R%signature _ _. + Hint Unfold Reflexive : core. Hint Unfold Symmetric : core. Hint Unfold Transitive : core. -Typeclasses Opaque respectful pointwise_relation forall_relation. - -Program Instance respectful_per `(PER A R, PER B R') : PER (R ==> R'). - - Next Obligation. - Proof with auto. - assert(R x0 x0). - transitivity y0... symmetry... - transitivity (y x0)... - Qed. - -(** Subrelations induce a morphism on the identity. *) - -Instance subrelation_id_proper `(subrelation A R₁ R₂) : Proper (R₁ ==> R₂) id. -Proof. firstorder. Qed. - -(** The subrelation property goes through products as usual. *) - -Lemma subrelation_respectful `(subl : subrelation A R₂ R₁, subr : subrelation B S₁ S₂) : - subrelation (R₁ ==> S₁) (R₂ ==> S₂). -Proof. simpl_relation. apply subr. apply H. apply subl. apply H0. Qed. - -(** And of course it is reflexive. *) - -Lemma subrelation_refl A R : @subrelation A R R. -Proof. simpl_relation. Qed. - +(** Resolution with subrelation: favor decomposing products over applying reflexivity + for unconstrained goals. *) Ltac subrelation_tac T U := (is_ground T ; is_ground U ; class_apply @subrelation_refl) || class_apply @subrelation_respectful || class_apply @subrelation_refl. Hint Extern 3 (@subrelation _ ?T ?U) => subrelation_tac T U : typeclass_instances. -(** [Proper] is itself a covariant morphism for [subrelation]. *) - -Lemma subrelation_proper `(mor : Proper A R₁ m, unc : Unconvertible (relation A) R₁ R₂, - sub : subrelation A R₁ R₂) : Proper R₂ m. -Proof. - intros. apply sub. apply mor. -Qed. - CoInductive apply_subrelation : Prop := do_subrelation. Ltac proper_subrelation := @@ -189,117 +231,112 @@ Ltac proper_subrelation := Hint Extern 5 (@Proper _ ?H _) => proper_subrelation : typeclass_instances. -Instance proper_subrelation_proper : - Proper (subrelation ++> eq ==> impl) (@Proper A). -Proof. reduce. subst. firstorder. Qed. - (** Essential subrelation instances for [iff], [impl] and [pointwise_relation]. *) Instance iff_impl_subrelation : subrelation iff impl | 2. Proof. firstorder. Qed. -Instance iff_inverse_impl_subrelation : subrelation iff (inverse impl) | 2. +Instance iff_flip_impl_subrelation : subrelation iff (flip impl) | 2. Proof. firstorder. Qed. -Instance pointwise_subrelation {A} `(sub : subrelation B R R') : - subrelation (pointwise_relation A R) (pointwise_relation A R') | 4. -Proof. reduce. unfold pointwise_relation in *. apply sub. apply H. Qed. - -(** For dependent function types. *) -Lemma forall_subrelation A (B : A -> Type) (R S : forall x : A, relation (B x)) : - (forall a, subrelation (R a) (S a)) -> subrelation (forall_relation R) (forall_relation S). -Proof. reduce. apply H. apply H0. Qed. - (** We use an extern hint to help unification. *) Hint Extern 4 (subrelation (@forall_relation ?A ?B ?R) (@forall_relation _ _ ?S)) => apply (@forall_subrelation A B R S) ; intro : typeclass_instances. -(** Any symmetric relation is equal to its inverse. *) +Section GenericInstances. + (* Share universes *) + Let U := Type. + Context {A B C : U}. -Lemma subrelation_symmetric A R `(Symmetric A R) : subrelation (inverse R) R. -Proof. reduce. red in H0. symmetry. assumption. Qed. - -Hint Extern 4 (subrelation (inverse _) _) => - class_apply @subrelation_symmetric : typeclass_instances. - -(** The complement of a relation conserves its proper elements. *) + (** We can build a PER on the Coq function space if we have PERs on the domain and + codomain. *) + + Program Instance respectful_per `(PER A R, PER B R') : PER (R ==> R'). -Program Definition complement_proper - `(mR : Proper (A -> A -> Prop) (RA ==> RA ==> iff) R) : - Proper (RA ==> RA ==> iff) (complement R) := _. + Next Obligation. + Proof with auto. + assert(R x0 x0). + transitivity y0... symmetry... + transitivity (y x0)... + Qed. - Next Obligation. + (** The complement of a relation conserves its proper elements. *) + + Program Definition complement_proper + `(mR : Proper (A -> A -> Prop) (RA ==> RA ==> iff) R) : + Proper (RA ==> RA ==> iff) (complement R) := _. + + Next Obligation. Proof. unfold complement. pose (mR x y H x0 y0 H0). intuition. Qed. -Hint Extern 1 (Proper _ (complement _)) => - apply @complement_proper : typeclass_instances. - -(** The [inverse] too, actually the [flip] instance is a bit more general. *) - -Program Definition flip_proper - `(mor : Proper (A -> B -> C) (RA ==> RB ==> RC) f) : - Proper (RB ==> RA ==> RC) (flip f) := _. + (** The [flip] too, actually the [flip] instance is a bit more general. *) + Program Definition flip_proper + `(mor : Proper (A -> B -> C) (RA ==> RB ==> RC) f) : + Proper (RB ==> RA ==> RC) (flip f) := _. + Next Obligation. Proof. apply mor ; auto. Qed. -Hint Extern 1 (Proper _ (flip _)) => - apply @flip_proper : typeclass_instances. -(** Every Transitive relation gives rise to a binary morphism on [impl], + (** Every Transitive relation gives rise to a binary morphism on [impl], contravariant in the first argument, covariant in the second. *) - -Program Instance trans_contra_co_morphism - `(Transitive A R) : Proper (R --> R ++> impl) R. - + + Global Program + Instance trans_contra_co_morphism + `(Transitive A R) : Proper (R --> R ++> impl) R. + Next Obligation. Proof with auto. transitivity x... transitivity x0... Qed. -(** Proper declarations for partial applications. *) + (** Proper declarations for partial applications. *) -Program Instance trans_contra_inv_impl_morphism - `(Transitive A R) : Proper (R --> inverse impl) (R x) | 3. + Global Program + Instance trans_contra_inv_impl_morphism + `(Transitive A R) : Proper (R --> flip impl) (R x) | 3. Next Obligation. Proof with auto. transitivity y... Qed. -Program Instance trans_co_impl_morphism - `(Transitive A R) : Proper (R ++> impl) (R x) | 3. + Global Program + Instance trans_co_impl_morphism + `(Transitive A R) : Proper (R ++> impl) (R x) | 3. Next Obligation. Proof with auto. transitivity x0... Qed. -Program Instance trans_sym_co_inv_impl_morphism - `(PER A R) : Proper (R ++> inverse impl) (R x) | 3. + Global Program + Instance trans_sym_co_inv_impl_morphism + `(PER A R) : Proper (R ++> flip impl) (R x) | 3. Next Obligation. Proof with auto. transitivity y... symmetry... Qed. -Program Instance trans_sym_contra_impl_morphism - `(PER A R) : Proper (R --> impl) (R x) | 3. + Global Program Instance trans_sym_contra_impl_morphism + `(PER A R) : Proper (R --> impl) (R x) | 3. Next Obligation. Proof with auto. transitivity x0... symmetry... Qed. -Program Instance per_partial_app_morphism + Global Program Instance per_partial_app_morphism `(PER A R) : Proper (R ==> iff) (R x) | 2. Next Obligation. @@ -310,20 +347,21 @@ Program Instance per_partial_app_morphism symmetry... Qed. -(** Every Transitive relation induces a morphism by "pushing" an [R x y] on the left of an [R x z] proof - to get an [R y z] goal. *) + (** Every Transitive relation induces a morphism by "pushing" an [R x y] on the left of an [R x z] proof to get an [R y z] goal. *) -Program Instance trans_co_eq_inv_impl_morphism - `(Transitive A R) : Proper (R ==> (@eq A) ==> inverse impl) R | 2. + Global Program + Instance trans_co_eq_inv_impl_morphism + `(Transitive A R) : Proper (R ==> (@eq A) ==> flip impl) R | 2. Next Obligation. Proof with auto. transitivity y... Qed. -(** Every Symmetric and Transitive relation gives rise to an equivariant morphism. *) + (** Every Symmetric and Transitive relation gives rise to an equivariant morphism. *) -Program Instance PER_morphism `(PER A R) : Proper (R ==> R ==> iff) R | 1. + Global Program + Instance PER_morphism `(PER A R) : Proper (R ==> R ==> iff) R | 1. Next Obligation. Proof with auto. @@ -333,11 +371,11 @@ Program Instance PER_morphism `(PER A R) : Proper (R ==> R ==> iff) R | 1. transitivity y... transitivity y0... symmetry... Qed. -Lemma symmetric_equiv_inverse `(Symmetric A R) : relation_equivalence R (flip R). -Proof. firstorder. Qed. + Lemma symmetric_equiv_flip `(Symmetric A R) : relation_equivalence R (flip R). + Proof. firstorder. Qed. -Program Instance compose_proper A B C R₀ R₁ R₂ : - Proper ((R₁ ==> R₂) ==> (R₀ ==> R₁) ==> (R₀ ==> R₂)) (@compose A B C). + Global Program Instance compose_proper RA RB RC : + Proper ((RB ==> RC) ==> (RA ==> RB) ==> (RA ==> RC)) (@compose A B C). Next Obligation. Proof. @@ -345,63 +383,79 @@ Program Instance compose_proper A B C R₀ R₁ R₂ : unfold compose. apply H. apply H0. apply H1. Qed. -(** Coq functions are morphisms for Leibniz equality, - applied only if really needed. *) + (** Coq functions are morphisms for Leibniz equality, + applied only if really needed. *) -Instance reflexive_eq_dom_reflexive (A : Type) `(Reflexive B R') : - Reflexive (@Logic.eq A ==> R'). -Proof. simpl_relation. Qed. - -(** [respectful] is a morphism for relation equivalence. *) - -Instance respectful_morphism : - Proper (relation_equivalence ++> relation_equivalence ++> relation_equivalence) (@respectful A B). -Proof. - reduce. - unfold respectful, relation_equivalence, predicate_equivalence in * ; simpl in *. - split ; intros. + Global Instance reflexive_eq_dom_reflexive `(Reflexive B R') : + Reflexive (@Logic.eq A ==> R'). + Proof. simpl_relation. Qed. + (** [respectful] is a morphism for relation equivalence. *) + + Global Instance respectful_morphism : + Proper (relation_equivalence ++> relation_equivalence ++> relation_equivalence) + (@respectful A B). + Proof. + reduce. + unfold respectful, relation_equivalence, predicate_equivalence in * ; simpl in *. + split ; intros. + rewrite <- H0. apply H1. rewrite H. assumption. - + rewrite H0. apply H1. rewrite <- H. assumption. -Qed. - -(** Every element in the carrier of a reflexive relation is a morphism for this relation. - We use a proxy class for this case which is used internally to discharge reflexivity constraints. - The [Reflexive] instance will almost always be used, but it won't apply in general to any kind of - [Proper (A -> B) _ _] goal, making proof-search much slower. A cleaner solution would be to be able - to set different priorities in different hint bases and select a particular hint database for - resolution of a type class constraint.*) - -Class ProperProxy {A} (R : relation A) (m : A) : Prop := - proper_proxy : R m m. - -Lemma eq_proper_proxy A (x : A) : ProperProxy (@eq A) x. -Proof. firstorder. Qed. - -Lemma reflexive_proper_proxy `(Reflexive A R) (x : A) : ProperProxy R x. -Proof. firstorder. Qed. - -Lemma proper_proper_proxy `(Proper A R x) : ProperProxy R x. -Proof. firstorder. Qed. - -Hint Extern 1 (ProperProxy _ _) => - class_apply @eq_proper_proxy || class_apply @reflexive_proper_proxy : typeclass_instances. -Hint Extern 2 (ProperProxy ?R _) => not_evar R; class_apply @proper_proper_proxy : typeclass_instances. + Qed. -(** [R] is Reflexive, hence we can build the needed proof. *) + (** [R] is Reflexive, hence we can build the needed proof. *) -Lemma Reflexive_partial_app_morphism `(Proper (A -> B) (R ==> R') m, ProperProxy A R x) : - Proper R' (m x). -Proof. simpl_relation. Qed. + Lemma Reflexive_partial_app_morphism `(Proper (A -> B) (R ==> R') m, ProperProxy A R x) : + Proper R' (m x). + Proof. simpl_relation. Qed. + + Class Params (of : A) (arity : nat). + + Lemma flip_respectful (R : relation A) (R' : relation B) : + relation_equivalence (flip (R ==> R')) (flip R ==> flip R'). + Proof. + intros. + unfold flip, respectful. + split ; intros ; intuition. + Qed. -Class Params {A : Type} (of : A) (arity : nat). + + (** Treating flip: can't make them direct instances as we + need at least a [flip] present in the goal. *) + + Lemma flip1 `(subrelation A R' R) : subrelation (flip (flip R')) R. + Proof. firstorder. Qed. + + Lemma flip2 `(subrelation A R R') : subrelation R (flip (flip R')). + Proof. firstorder. Qed. + + (** That's if and only if *) + + Lemma eq_subrelation `(Reflexive A R) : subrelation (@eq A) R. + Proof. simpl_relation. Qed. + + (** Once we have normalized, we will apply this instance to simplify the problem. *) + + Definition proper_flip_proper `(mor : Proper A R m) : Proper (flip R) m := mor. + + (** Every reflexive relation gives rise to a morphism, + only for immediately solving goals without variables. *) + + Lemma reflexive_proper `{Reflexive A R} (x : A) : Proper R x. + Proof. firstorder. Qed. + + Lemma proper_eq (x : A) : Proper (@eq A) x. + Proof. intros. apply reflexive_proper. Qed. + +End GenericInstances. Class PartialApplication. @@ -450,68 +504,6 @@ Ltac partial_application_tactic := end end. -Hint Extern 4 (@Proper _ _ _) => partial_application_tactic : typeclass_instances. - -Lemma inverse_respectful : forall (A : Type) (R : relation A) (B : Type) (R' : relation B), - relation_equivalence (inverse (R ==> R')) (inverse R ==> inverse R'). -Proof. - intros. - unfold flip, respectful. - split ; intros ; intuition. -Qed. - -(** Special-purpose class to do normalization of signatures w.r.t. inverse. *) - -Class Normalizes (A : Type) (m : relation A) (m' : relation A) : Prop := - normalizes : relation_equivalence m m'. - -(** Current strategy: add [inverse] everywhere and reduce using [subrelation] - afterwards. *) - -Lemma inverse_atom A R : Normalizes A R (inverse (inverse R)). -Proof. - firstorder. -Qed. - -Lemma inverse_arrow `(NA : Normalizes A R (inverse R'''), NB : Normalizes B R' (inverse R'')) : - Normalizes (A -> B) (R ==> R') (inverse (R''' ==> R'')%signature). -Proof. unfold Normalizes in *. intros. - rewrite NA, NB. firstorder. -Qed. - -Ltac inverse := - match goal with - | [ |- Normalizes _ (respectful _ _) _ ] => class_apply @inverse_arrow - | _ => class_apply @inverse_atom - end. - -Hint Extern 1 (Normalizes _ _ _) => inverse : typeclass_instances. - -(** Treating inverse: can't make them direct instances as we - need at least a [flip] present in the goal. *) - -Lemma inverse1 `(subrelation A R' R) : subrelation (inverse (inverse R')) R. -Proof. firstorder. Qed. - -Lemma inverse2 `(subrelation A R R') : subrelation R (inverse (inverse R')). -Proof. firstorder. Qed. - -Hint Extern 1 (subrelation (flip _) _) => class_apply @inverse1 : typeclass_instances. -Hint Extern 1 (subrelation _ (flip _)) => class_apply @inverse2 : typeclass_instances. - -(** That's if and only if *) - -Lemma eq_subrelation `(Reflexive A R) : subrelation (@eq A) R. -Proof. simpl_relation. Qed. - -(* Hint Extern 3 (subrelation eq ?R) => not_evar R ; class_apply eq_subrelation : typeclass_instances. *) - -(** Once we have normalized, we will apply this instance to simplify the problem. *) - -Definition proper_inverse_proper `(mor : Proper A R m) : Proper (inverse R) m := mor. - -Hint Extern 2 (@Proper _ (flip _) _) => class_apply @proper_inverse_proper : typeclass_instances. - (** Bootstrap !!! *) Instance proper_proper : Proper (relation_equivalence ==> eq ==> iff) (@Proper A). @@ -525,46 +517,83 @@ Proof. apply H0. Qed. -Lemma proper_normalizes_proper `(Normalizes A R0 R1, Proper A R1 m) : Proper R0 m. -Proof. - red in H, H0. - setoid_rewrite H. - assumption. -Qed. - -Ltac proper_normalization := +Ltac proper_reflexive := match goal with | [ _ : normalization_done |- _ ] => fail 1 - | [ _ : apply_subrelation |- @Proper _ ?R _ ] => let H := fresh "H" in - set(H:=did_normalization) ; class_apply @proper_normalizes_proper + | _ => class_apply proper_eq || class_apply @reflexive_proper end. -Hint Extern 6 (@Proper _ _ _) => proper_normalization : typeclass_instances. -(** Every reflexive relation gives rise to a morphism, only for immediately solving goals without variables. *) +Hint Extern 1 (subrelation (flip _) _) => class_apply @flip1 : typeclass_instances. +Hint Extern 1 (subrelation _ (flip _)) => class_apply @flip2 : typeclass_instances. -Lemma reflexive_proper `{Reflexive A R} (x : A) - : Proper R x. -Proof. firstorder. Qed. +Hint Extern 1 (Proper _ (complement _)) => apply @complement_proper + : typeclass_instances. +Hint Extern 1 (Proper _ (flip _)) => apply @flip_proper + : typeclass_instances. +Hint Extern 2 (@Proper _ (flip _) _) => class_apply @proper_flip_proper + : typeclass_instances. +Hint Extern 4 (@Proper _ _ _) => partial_application_tactic + : typeclass_instances. +Hint Extern 7 (@Proper _ _ _) => proper_reflexive + : typeclass_instances. -Lemma proper_eq A (x : A) : Proper (@eq A) x. -Proof. intros. apply reflexive_proper. Qed. +(** Special-purpose class to do normalization of signatures w.r.t. flip. *) -Ltac proper_reflexive := +Section Normalize. + Context (A : Type). + + Class Normalizes (m : relation A) (m' : relation A) : Prop := + normalizes : relation_equivalence m m'. + + (** Current strategy: add [flip] everywhere and reduce using [subrelation] + afterwards. *) + + Lemma proper_normalizes_proper `(Normalizes R0 R1, Proper A R1 m) : Proper R0 m. + Proof. + red in H, H0. + rewrite H. + assumption. + Qed. + + Lemma flip_atom R : Normalizes R (flip (flip R)). + Proof. + firstorder. + Qed. + +End Normalize. + +Lemma flip_arrow `(NA : Normalizes A R (flip R'''), NB : Normalizes B R' (flip R'')) : + Normalizes (A -> B) (R ==> R') (flip (R''' ==> R'')%signature). +Proof. + unfold Normalizes in *. intros. + rewrite NA, NB. firstorder. +Qed. + +Ltac normalizes := match goal with - | [ _ : normalization_done |- _ ] => fail 1 - | _ => class_apply proper_eq || class_apply @reflexive_proper + | [ |- Normalizes _ (respectful _ _) _ ] => class_apply @flip_arrow + | _ => class_apply @flip_atom end. -Hint Extern 7 (@Proper _ _ _) => proper_reflexive : typeclass_instances. +Ltac proper_normalization := + match goal with + | [ _ : normalization_done |- _ ] => fail 1 + | [ _ : apply_subrelation |- @Proper _ ?R _ ] => + let H := fresh "H" in + set(H:=did_normalization) ; class_apply @proper_normalizes_proper + end. +Hint Extern 1 (Normalizes _ _ _) => normalizes : typeclass_instances. +Hint Extern 6 (@Proper _ _ _) => proper_normalization + : typeclass_instances. (** When the relation on the domain is symmetric, we can - inverse the relation on the codomain. Same for binary functions. *) + flip the relation on the codomain. Same for binary functions. *) Lemma proper_sym_flip : forall `(Symmetric A R1)`(Proper (A->B) (R1==>R2) f), - Proper (R1==>inverse R2) f. + Proper (R1==>flip R2) f. Proof. intros A R1 Sym B R2 f Hf. intros x x' Hxx'. apply Hf, Sym, Hxx'. @@ -572,7 +601,7 @@ Qed. Lemma proper_sym_flip_2 : forall `(Symmetric A R1)`(Symmetric B R2)`(Proper (A->B->C) (R1==>R2==>R3) f), - Proper (R1==>R2==>inverse R3) f. + Proper (R1==>R2==>flip R3) f. Proof. intros A R1 Sym1 B R2 Sym2 C R3 f Hf. intros x x' Hxx' y y' Hyy'. apply Hf; auto. @@ -627,8 +656,6 @@ apply partial_order_antisym; auto. rewrite Hxz; auto. Qed. -Hint Extern 4 (StrictOrder (relation_conjunction _ _)) => - class_apply PartialOrder_StrictOrder : typeclass_instances. (** From a [StrictOrder] to the corresponding [PartialOrder]: [le = lt \/ eq]. @@ -659,5 +686,8 @@ elim (StrictOrder_Irreflexive x). transitivity y; auto. Qed. +Hint Extern 4 (StrictOrder (relation_conjunction _ _)) => + class_apply PartialOrder_StrictOrder : typeclass_instances. + Hint Extern 4 (PartialOrder _ (relation_disjunction _ _)) => class_apply StrictOrder_PartialOrder : typeclass_instances. diff --git a/theories/Classes/Morphisms_Prop.v b/theories/Classes/Morphisms_Prop.v index 6f02ac9f5..4f80a67ae 100644 --- a/theories/Classes/Morphisms_Prop.v +++ b/theories/Classes/Morphisms_Prop.v @@ -16,7 +16,7 @@ Require Import Coq.Classes.Morphisms. Require Import Coq.Program.Basics. Require Import Coq.Program.Tactics. -Local Obligation Tactic := simpl_relation. +Local Obligation Tactic := try solve [simpl_relation | firstorder auto]. (** Standard instances for [not], [iff] and [impl]. *) @@ -52,49 +52,20 @@ Program Instance iff_iff_iff_impl_morphism : Proper (iff ==> iff ==> iff) impl. Program Instance ex_iff_morphism {A : Type} : Proper (pointwise_relation A iff ==> iff) (@ex A). - Next Obligation. - Proof. - unfold pointwise_relation in H. - split ; intros. - destruct H0 as [x1 H1]. - exists x1. rewrite H in H1. assumption. - - destruct H0 as [x1 H1]. - exists x1. rewrite H. assumption. - Qed. - Program Instance ex_impl_morphism {A : Type} : Proper (pointwise_relation A impl ==> impl) (@ex A) | 1. - Next Obligation. - Proof. - unfold pointwise_relation in H. - exists H0. apply H. assumption. - Qed. - -Program Instance ex_inverse_impl_morphism {A : Type} : - Proper (pointwise_relation A (inverse impl) ==> inverse impl) (@ex A) | 1. - - Next Obligation. - Proof. - unfold pointwise_relation in H. - exists H0. apply H. assumption. - Qed. +Program Instance ex_flip_impl_morphism {A : Type} : + Proper (pointwise_relation A (flip impl) ==> flip impl) (@ex A) | 1. Program Instance all_iff_morphism {A : Type} : Proper (pointwise_relation A iff ==> iff) (@all A). - Next Obligation. - Proof. - unfold pointwise_relation, all in *. - intuition ; specialize (H x0) ; intuition. - Qed. - Program Instance all_impl_morphism {A : Type} : Proper (pointwise_relation A impl ==> impl) (@all A) | 1. -Program Instance all_inverse_impl_morphism {A : Type} : - Proper (pointwise_relation A (inverse impl) ==> inverse impl) (@all A) | 1. +Program Instance all_flip_impl_morphism {A : Type} : + Proper (pointwise_relation A (flip impl) ==> flip impl) (@all A) | 1. (** Equivalent points are simultaneously accessible or not *) @@ -104,13 +75,13 @@ Instance Acc_pt_morphism {A:Type}(E R : A->A->Prop) Proof. apply proper_sym_impl_iff; auto with *. intros x y EQ WF. apply Acc_intro; intros z Hz. - rewrite <- EQ in Hz. now apply Acc_inv with x. +rewrite <- EQ in Hz. now apply Acc_inv with x. Qed. (** Equivalent relations have the same accessible points *) Instance Acc_rel_morphism {A:Type} : - Proper (@relation_equivalence A ==> Logic.eq ==> iff) (@Acc A). + Proper (relation_equivalence ==> Logic.eq ==> iff) (@Acc A). Proof. apply proper_sym_impl_iff_2. red; now symmetry. red; now symmetry. intros R R' EQ a a' Ha WF. subst a'. @@ -121,7 +92,7 @@ Qed. (** Equivalent relations are simultaneously well-founded or not *) Instance well_founded_morphism {A : Type} : - Proper (@relation_equivalence A ==> iff) (@well_founded A). + Proper (relation_equivalence ==> iff) (@well_founded A). Proof. unfold well_founded. solve_proper. Qed. diff --git a/theories/Classes/Morphisms_Relations.v b/theories/Classes/Morphisms_Relations.v index ea2afb306..dc46b4bbb 100644 --- a/theories/Classes/Morphisms_Relations.v +++ b/theories/Classes/Morphisms_Relations.v @@ -30,8 +30,6 @@ Instance relation_disjunction_morphism : Proper (relation_equivalence (A:=A) ==> (* Predicate equivalence is exactly the same as the pointwise lifting of [iff]. *) -Require Import List. - Lemma predicate_equivalence_pointwise (l : Tlist) : Proper (@predicate_equivalence l ==> pointwise_lifting iff l) id. Proof. do 2 red. unfold predicate_equivalence. auto. Qed. @@ -52,6 +50,6 @@ Instance subrelation_pointwise : Proof. intro. apply (predicate_implication_pointwise (Tcons A (Tcons A Tnil))). Qed. -Lemma inverse_pointwise_relation A (R : relation A) : - relation_equivalence (pointwise_relation A (inverse R)) (inverse (pointwise_relation A R)). +Lemma flip_pointwise_relation A (R : relation A) : + relation_equivalence (pointwise_relation A (flip R)) (flip (pointwise_relation A R)). Proof. intros. split; firstorder. Qed. diff --git a/theories/Classes/RelationClasses.v b/theories/Classes/RelationClasses.v index b8fdac8c9..61edb2b98 100644 --- a/theories/Classes/RelationClasses.v +++ b/theories/Classes/RelationClasses.v @@ -20,41 +20,187 @@ Require Import Coq.Program.Basics. Require Import Coq.Program.Tactics. Require Import Coq.Relations.Relation_Definitions. -(** We allow to unfold the [relation] definition while doing morphism search. *) - -Notation inverse R := (flip (R:relation _) : relation _). - -Definition complement {A} (R : relation A) : relation A := fun x y => R x y -> False. - -(** Opaque for proof-search. *) -Typeclasses Opaque complement. - -(** These are convertible. *) - -Lemma complement_inverse : forall A (R : relation A), complement (inverse R) = inverse (complement R). -Proof. reflexivity. Qed. +Generalizable Variables A B C D R S T U l eqA eqB eqC eqD. -(** We rebind relations in separate classes to be able to overload each proof. *) +(** We allow to unfold the [relation] definition while doing morphism search. *) -Set Implicit Arguments. -Unset Strict Implicit. +Section Defs. + Context {A : Type}. + + (** We rebind relational properties in separate classes to be able to overload each proof. *) + + Class Reflexive (R : relation A) := + reflexivity : forall x : A, R x x. + + Definition complement (R : relation A) : relation A := fun x y => R x y -> False. + + (** Opaque for proof-search. *) + Typeclasses Opaque complement. + + (** These are convertible. *) + Lemma complement_inverse R : complement (flip R) = flip (complement R). + Proof. reflexivity. Qed. + + Class Irreflexive (R : relation A) := + irreflexivity : Reflexive (complement R). + + Class Symmetric (R : relation A) := + symmetry : forall {x y}, R x y -> R y x. + + Class Asymmetric (R : relation A) := + asymmetry : forall {x y}, R x y -> R y x -> False. + + Class Transitive (R : relation A) := + transitivity : forall {x y z}, R x y -> R y z -> R x z. + + (** Various combinations of reflexivity, symmetry and transitivity. *) + + (** A [PreOrder] is both Reflexive and Transitive. *) + + Class PreOrder (R : relation A) : Prop := { + PreOrder_Reflexive :> Reflexive R | 2 ; + PreOrder_Transitive :> Transitive R | 2 }. + + (** A [StrictOrder] is both Irreflexive and Transitive. *) + + Class StrictOrder (R : relation A) : Prop := { + StrictOrder_Irreflexive :> Irreflexive R ; + StrictOrder_Transitive :> Transitive R }. + + (** By definition, a strict order is also asymmetric *) + Global Instance StrictOrder_Asymmetric `(StrictOrder R) : Asymmetric R. + Proof. firstorder. Qed. + + (** A partial equivalence relation is Symmetric and Transitive. *) + + Class PER (R : relation A) : Prop := { + PER_Symmetric :> Symmetric R | 3 ; + PER_Transitive :> Transitive R | 3 }. + + (** Equivalence relations. *) + + Class Equivalence (R : relation A) : Prop := { + Equivalence_Reflexive :> Reflexive R ; + Equivalence_Symmetric :> Symmetric R ; + Equivalence_Transitive :> Transitive R }. + + (** An Equivalence is a PER plus reflexivity. *) + + Global Instance Equivalence_PER {R} `(E:Equivalence R) : PER R | 10 := + { }. + + (** We can now define antisymmetry w.r.t. an equivalence relation on the carrier. *) + + Class Antisymmetric eqA `{equ : Equivalence eqA} (R : relation A) := + antisymmetry : forall {x y}, R x y -> R y x -> eqA x y. + + Class subrelation (R R' : relation A) : Prop := + is_subrelation : forall {x y}, R x y -> R' x y. + + (** Any symmetric relation is equal to its inverse. *) + + Lemma subrelation_symmetric R `(Symmetric R) : subrelation (flip R) R. + Proof. hnf. intros. red in H0. apply symmetry. assumption. Qed. + + Section flip. + + Lemma flip_Reflexive `{Reflexive R} : Reflexive (flip R). + Proof. tauto. Qed. + + Program Definition flip_Irreflexive `(Irreflexive R) : Irreflexive (flip R) := + irreflexivity (R:=R). + + Program Definition flip_Symmetric `(Symmetric R) : Symmetric (flip R) := + fun x y H => symmetry (R:=R) H. + + Program Definition flip_Asymmetric `(Asymmetric R) : Asymmetric (flip R) := + fun x y H H' => asymmetry (R:=R) H H'. + + Program Definition flip_Transitive `(Transitive R) : Transitive (flip R) := + fun x y z H H' => transitivity (R:=R) H' H. + + Program Definition flip_Antisymmetric `(Antisymmetric eqA R) : + Antisymmetric eqA (flip R). + Proof. firstorder. Qed. + + (** Inversing the larger structures *) + + Lemma flip_PreOrder `(PreOrder R) : PreOrder (flip R). + Proof. firstorder. Qed. + + Lemma flip_StrictOrder `(StrictOrder R) : StrictOrder (flip R). + Proof. firstorder. Qed. + + Lemma flip_PER `(PER R) : PER (flip R). + Proof. firstorder. Qed. + + Lemma flip_Equivalence `(Equivalence R) : Equivalence (flip R). + Proof. firstorder. Qed. + + End flip. + + Section complement. + + Definition complement_Irreflexive `(Reflexive R) + : Irreflexive (complement R). + Proof. firstorder. Qed. + + Definition complement_Symmetric `(Symmetric R) : Symmetric (complement R). + Proof. firstorder. Qed. + End complement. + + + (** Rewrite relation on a given support: declares a relation as a rewrite + relation for use by the generalized rewriting tactic. + It helps choosing if a rewrite should be handled + by the generalized or the regular rewriting tactic using leibniz equality. + Users can declare an [RewriteRelation A RA] anywhere to declare default + relations. This is also done automatically by the [Declare Relation A RA] + commands. *) -Class Reflexive {A} (R : relation A) := - reflexivity : forall x, R x x. + Class RewriteRelation (RA : relation A). -Class Irreflexive {A} (R : relation A) := - irreflexivity : Reflexive (complement R). + (** Any [Equivalence] declared in the context is automatically considered + a rewrite relation. *) + + Global Instance equivalence_rewrite_relation `(Equivalence eqA) : RewriteRelation eqA. + + (** Leibniz equality. *) + Section Leibniz. + Global Instance eq_Reflexive : Reflexive (@eq A) := @eq_refl A. + Global Instance eq_Symmetric : Symmetric (@eq A) := @eq_sym A. + Global Instance eq_Transitive : Transitive (@eq A) := @eq_trans A. + + (** Leibinz equality [eq] is an equivalence relation. + The instance has low priority as it is always applicable + if only the type is constrained. *) + + Global Program Instance eq_equivalence : Equivalence (@eq A) | 10. + End Leibniz. + +End Defs. + +(** Default rewrite relations handled by [setoid_rewrite]. *) +Instance: RewriteRelation impl. +Instance: RewriteRelation iff. +(** Hints to drive the typeclass resolution avoiding loops + due to the use of full unification. *) Hint Extern 1 (Reflexive (complement _)) => class_apply @irreflexivity : typeclass_instances. +Hint Extern 3 (Symmetric (complement _)) => class_apply complement_Symmetric : typeclass_instances. +Hint Extern 3 (Irreflexive (complement _)) => class_apply complement_Irreflexive : typeclass_instances. -Class Symmetric {A} (R : relation A) := - symmetry : forall x y, R x y -> R y x. - -Class Asymmetric {A} (R : relation A) := - asymmetry : forall x y, R x y -> R y x -> False. +Hint Extern 3 (Reflexive (flip _)) => apply flip_Reflexive : typeclass_instances. +Hint Extern 3 (Irreflexive (flip _)) => class_apply flip_Irreflexive : typeclass_instances. +Hint Extern 3 (Symmetric (flip _)) => class_apply flip_Symmetric : typeclass_instances. +Hint Extern 3 (Asymmetric (flip _)) => class_apply flip_Asymmetric : typeclass_instances. +Hint Extern 3 (Antisymmetric (flip _)) => class_apply flip_Antisymmetric : typeclass_instances. +Hint Extern 3 (Transitive (flip _)) => class_apply flip_Transitive : typeclass_instances. +Hint Extern 3 (StrictOrder (flip _)) => class_apply flip_StrictOrder : typeclass_instances. +Hint Extern 3 (PreOrder (flip _)) => class_apply flip_PreOrder : typeclass_instances. -Class Transitive {A} (R : relation A) := - transitivity : forall x y z, R x y -> R y z -> R x z. +Hint Extern 4 (subrelation (flip _) _) => + class_apply @subrelation_symmetric : typeclass_instances. Hint Resolve irreflexivity : ord. @@ -72,40 +218,6 @@ Hint Extern 4 => solve_relation : relations. (** We can already dualize all these properties. *) -Generalizable Variables A B C D R S T U l eqA eqB eqC eqD. - -Lemma flip_Reflexive `{Reflexive A R} : Reflexive (flip R). -Proof. tauto. Qed. - -Hint Extern 3 (Reflexive (flip _)) => apply flip_Reflexive : typeclass_instances. - -Program Definition flip_Irreflexive `(Irreflexive A R) : Irreflexive (flip R) := - irreflexivity (R:=R). - -Program Definition flip_Symmetric `(Symmetric A R) : Symmetric (flip R) := - fun x y H => symmetry (R:=R) H. - -Program Definition flip_Asymmetric `(Asymmetric A R) : Asymmetric (flip R) := - fun x y H H' => asymmetry (R:=R) H H'. - -Program Definition flip_Transitive `(Transitive A R) : Transitive (flip R) := - fun x y z H H' => transitivity (R:=R) H' H. - -Hint Extern 3 (Irreflexive (flip _)) => class_apply flip_Irreflexive : typeclass_instances. -Hint Extern 3 (Symmetric (flip _)) => class_apply flip_Symmetric : typeclass_instances. -Hint Extern 3 (Asymmetric (flip _)) => class_apply flip_Asymmetric : typeclass_instances. -Hint Extern 3 (Transitive (flip _)) => class_apply flip_Transitive : typeclass_instances. - -Definition Reflexive_complement_Irreflexive `(Reflexive A (R : relation A)) - : Irreflexive (complement R). -Proof. firstorder. Qed. - -Definition complement_Symmetric `(Symmetric A (R : relation A)) : Symmetric (complement R). -Proof. firstorder. Qed. - -Hint Extern 3 (Symmetric (complement _)) => class_apply complement_Symmetric : typeclass_instances. -Hint Extern 3 (Irreflexive (complement _)) => class_apply Reflexive_complement_Irreflexive : typeclass_instances. - (** * Standard instances. *) Ltac reduce_hyp H := @@ -145,54 +257,6 @@ Instance iff_Reflexive : Reflexive iff := iff_refl. Instance iff_Symmetric : Symmetric iff := iff_sym. Instance iff_Transitive : Transitive iff := iff_trans. -(** Leibniz equality. *) - -Instance eq_Reflexive {A} : Reflexive (@eq A) := @eq_refl A. -Instance eq_Symmetric {A} : Symmetric (@eq A) := @eq_sym A. -Instance eq_Transitive {A} : Transitive (@eq A) := @eq_trans A. - -(** Various combinations of reflexivity, symmetry and transitivity. *) - -(** A [PreOrder] is both Reflexive and Transitive. *) - -Class PreOrder {A} (R : relation A) : Prop := { - PreOrder_Reflexive :> Reflexive R | 2 ; - PreOrder_Transitive :> Transitive R | 2 }. - -(** A partial equivalence relation is Symmetric and Transitive. *) - -Class PER {A} (R : relation A) : Prop := { - PER_Symmetric :> Symmetric R | 3 ; - PER_Transitive :> Transitive R | 3 }. - -(** Equivalence relations. *) - -Class Equivalence {A} (R : relation A) : Prop := { - Equivalence_Reflexive :> Reflexive R ; - Equivalence_Symmetric :> Symmetric R ; - Equivalence_Transitive :> Transitive R }. - -(** An Equivalence is a PER plus reflexivity. *) - -Instance Equivalence_PER `(Equivalence A R) : PER R | 10 := - { PER_Symmetric := Equivalence_Symmetric ; - PER_Transitive := Equivalence_Transitive }. - -(** We can now define antisymmetry w.r.t. an equivalence relation on the carrier. *) - -Class Antisymmetric A eqA `{equ : Equivalence A eqA} (R : relation A) := - antisymmetry : forall {x y}, R x y -> R y x -> eqA x y. - -Program Definition flip_antiSymmetric `(Antisymmetric A eqA R) : - Antisymmetric A eqA (flip R). -Proof. firstorder. Qed. - -(** Leibinz equality [eq] is an equivalence relation. - The instance has low priority as it is always applicable - if only the type is constrained. *) - -Program Instance eq_equivalence : Equivalence (@eq A) | 10. - (** Logical equivalence [iff] is an equivalence relation. *) Program Instance iff_equivalence : Equivalence iff. @@ -203,9 +267,6 @@ Program Instance iff_equivalence : Equivalence iff. Local Open Scope list_scope. -(* Notation " [ ] " := nil : list_scope. *) -(* Notation " [ x ; .. ; y ] " := (cons x .. (cons y nil) ..) (at level 1) : list_scope. *) - (** A compact representation of non-dependent arities, with the codomain singled-out. *) (* Note, we do not use [list Type] because it imposes unnecessary universe constraints *) @@ -346,106 +407,66 @@ Program Instance predicate_implication_preorder : (** We define the various operations which define the algebra on binary relations, from the general ones. *) -Definition relation_equivalence {A : Type} : relation (relation A) := - @predicate_equivalence (_::_::Tnil). - -Class subrelation {A:Type} (R R' : relation A) : Prop := - is_subrelation : @predicate_implication (A::A::Tnil) R R'. - -Arguments subrelation {A} R R'. - -Definition relation_conjunction {A} (R : relation A) (R' : relation A) : relation A := - @predicate_intersection (A::A::Tnil) R R'. - -Definition relation_disjunction {A} (R : relation A) (R' : relation A) : relation A := - @predicate_union (A::A::Tnil) R R'. - -(** Relation equivalence is an equivalence, and subrelation defines a partial order. *) - -Set Automatic Introduction. - -Instance relation_equivalence_equivalence (A : Type) : - Equivalence (@relation_equivalence A). -Proof. exact (@predicate_equivalence_equivalence (A::A::Tnil)). Qed. - -Instance relation_implication_preorder A : PreOrder (@subrelation A). -Proof. exact (@predicate_implication_preorder (A::A::Tnil)). Qed. - -(** *** Partial Order. +Section Binary. + Context {A : Type}. + + Definition relation_equivalence : relation (relation A) := + @predicate_equivalence (_::_::Tnil). + + Global Instance: RewriteRelation relation_equivalence. + + Definition relation_conjunction (R : relation A) (R' : relation A) : relation A := + @predicate_intersection (A::A::Tnil) R R'. + + Definition relation_disjunction (R : relation A) (R' : relation A) : relation A := + @predicate_union (A::A::Tnil) R R'. + + (** Relation equivalence is an equivalence, and subrelation defines a partial order. *) + + Set Automatic Introduction. + + Global Instance relation_equivalence_equivalence : + Equivalence relation_equivalence. + Proof. exact (@predicate_equivalence_equivalence (A::A::Tnil)). Qed. + + Global Instance relation_implication_preorder : PreOrder (@subrelation A). + Proof. exact (@predicate_implication_preorder (A::A::Tnil)). Qed. + + (** *** Partial Order. A partial order is a preorder which is additionally antisymmetric. We give an equivalent definition, up-to an equivalence relation on the carrier. *) -Class PartialOrder {A} eqA `{equ : Equivalence A eqA} R `{preo : PreOrder A R} := - partial_order_equivalence : relation_equivalence eqA (relation_conjunction R (inverse R)). + Class PartialOrder eqA `{equ : Equivalence A eqA} R `{preo : PreOrder A R} := + partial_order_equivalence : relation_equivalence eqA (relation_conjunction R (flip R)). + + (** The equivalence proof is sufficient for proving that [R] must be a + morphism for equivalence (see Morphisms). It is also sufficient to + show that [R] is antisymmetric w.r.t. [eqA] *) + + Global Instance partial_order_antisym `(PartialOrder eqA R) : ! Antisymmetric A eqA R. + Proof with auto. + reduce_goal. + pose proof partial_order_equivalence as poe. do 3 red in poe. + apply <- poe. firstorder. + Qed. -(** The equivalence proof is sufficient for proving that [R] must be a morphism - for equivalence (see Morphisms). - It is also sufficient to show that [R] is antisymmetric w.r.t. [eqA] *) -Instance partial_order_antisym `(PartialOrder A eqA R) : ! Antisymmetric A eqA R. -Proof with auto. - reduce_goal. - pose proof partial_order_equivalence as poe. do 3 red in poe. - apply <- poe. firstorder. -Qed. + Lemma PartialOrder_inverse `(PartialOrder eqA R) : PartialOrder eqA (flip R). + Proof. firstorder. Qed. +End Binary. + +Hint Extern 3 (PartialOrder (flip _)) => class_apply PartialOrder_inverse : typeclass_instances. (** The partial order defined by subrelation and relation equivalence. *) Program Instance subrelation_partial_order : ! PartialOrder (relation A) relation_equivalence subrelation. - Next Obligation. - Proof. - unfold relation_equivalence in *. compute; firstorder. - Qed. +Next Obligation. +Proof. + unfold relation_equivalence in *. compute; firstorder. +Qed. Typeclasses Opaque arrows predicate_implication predicate_equivalence - relation_equivalence pointwise_lifting. - -(** Rewrite relation on a given support: declares a relation as a rewrite - relation for use by the generalized rewriting tactic. - It helps choosing if a rewrite should be handled - by the generalized or the regular rewriting tactic using leibniz equality. - Users can declare an [RewriteRelation A RA] anywhere to declare default - relations. This is also done automatically by the [Declare Relation A RA] - commands. *) - -Class RewriteRelation {A : Type} (RA : relation A). - -Instance: RewriteRelation impl. -Instance: RewriteRelation iff. -Instance: RewriteRelation (@relation_equivalence A). - -(** Any [Equivalence] declared in the context is automatically considered - a rewrite relation. *) - -Instance equivalence_rewrite_relation `(Equivalence A eqA) : RewriteRelation eqA. - -(** Strict Order *) - -Class StrictOrder {A : Type} (R : relation A) : Prop := { - StrictOrder_Irreflexive :> Irreflexive R ; - StrictOrder_Transitive :> Transitive R -}. - -Instance StrictOrder_Asymmetric `(StrictOrder A R) : Asymmetric R. -Proof. firstorder. Qed. - -(** Inversing a [StrictOrder] gives another [StrictOrder] *) - -Lemma StrictOrder_inverse `(StrictOrder A R) : StrictOrder (inverse R). -Proof. firstorder. Qed. - -(** Same for [PartialOrder]. *) - -Lemma PreOrder_inverse `(PreOrder A R) : PreOrder (inverse R). -Proof. firstorder. Qed. - -Hint Extern 3 (StrictOrder (inverse _)) => class_apply StrictOrder_inverse : typeclass_instances. -Hint Extern 3 (PreOrder (inverse _)) => class_apply PreOrder_inverse : typeclass_instances. - -Lemma PartialOrder_inverse `(PartialOrder A eqA R) : PartialOrder eqA (inverse R). -Proof. firstorder. Qed. - -Hint Extern 3 (PartialOrder (inverse _)) => class_apply PartialOrder_inverse : typeclass_instances. + relation_equivalence pointwise_lifting. diff --git a/theories/Classes/RelationPairs.v b/theories/Classes/RelationPairs.v index 2b010206c..73be830a4 100644 --- a/theories/Classes/RelationPairs.v +++ b/theories/Classes/RelationPairs.v @@ -9,8 +9,8 @@ (** * Relations over pairs *) +Require Import SetoidList. Require Import Relations Morphisms. - (* NB: This should be system-wide someday, but for that we need to fix the simpl tactic, since "simpl fst" would be refused for the moment. @@ -40,7 +40,7 @@ Generalizable Variables A B RA RB Ri Ro f. (** Any function from [A] to [B] allow to obtain a relation over [A] out of a relation over [B]. *) -Definition RelCompFun {A B}(R:relation B)(f:A->B) : relation A := +Definition RelCompFun {A} {B : Type}(R:relation B)(f:A->B) : relation A := fun a a' => R (f a) (f a'). Infix "@@" := RelCompFun (at level 30, right associativity) : signature_scope. @@ -62,13 +62,13 @@ Instance snd_measure : @Measure (A * B) B Snd. (** We define a product relation over [A*B]: each components should satisfy the corresponding initial relation. *) -Definition RelProd {A B}(RA:relation A)(RB:relation B) : relation (A*B) := - relation_conjunction (RA @@1) (RB @@2). +Polymorphic Definition RelProd {A : Type} {B : Type} (RA:relation A)(RB:relation B) : relation (A*B) := + relation_conjunction (@RelCompFun (A * B) A RA fst) (RB @@2). Infix "*" := RelProd : signature_scope. Section RelCompFun_Instances. - Context {A B : Type} (R : relation B). + Context {A : Type} {B : Type} (R : relation B). Global Instance RelCompFun_Reflexive `(Measure A B f, Reflexive _ R) : Reflexive (R@@f). @@ -94,57 +94,61 @@ Section RelCompFun_Instances. End RelCompFun_Instances. -Instance RelProd_Reflexive {A B}(RA:relation A)(RB:relation B) - `(Reflexive _ RA, Reflexive _ RB) : Reflexive (RA*RB). -Proof. firstorder. Qed. - -Instance RelProd_Symmetric {A B}(RA:relation A)(RB:relation B) - `(Symmetric _ RA, Symmetric _ RB) : Symmetric (RA*RB). -Proof. firstorder. Qed. - -Instance RelProd_Transitive {A B}(RA:relation A)(RB:relation B) - `(Transitive _ RA, Transitive _ RB) : Transitive (RA*RB). -Proof. firstorder. Qed. - -Program Instance RelProd_Equivalence {A B}(RA:relation A)(RB:relation B) - `(Equivalence _ RA, Equivalence _ RB) : Equivalence (RA*RB). - -Lemma FstRel_ProdRel {A B}(RA:relation A) : - relation_equivalence (RA @@1) (RA*(fun _ _ : B => True)). -Proof. firstorder. Qed. - -Lemma SndRel_ProdRel {A B}(RB:relation B) : - relation_equivalence (RB @@2) ((fun _ _ : A =>True) * RB). -Proof. firstorder. Qed. - -Instance FstRel_sub {A B} (RA:relation A)(RB:relation B): - subrelation (RA*RB) (RA @@1). -Proof. firstorder. Qed. - -Instance SndRel_sub {A B} (RA:relation A)(RB:relation B): - subrelation (RA*RB) (RB @@2). -Proof. firstorder. Qed. - -Instance pair_compat { A B } (RA:relation A)(RB:relation B) : - Proper (RA==>RB==> RA*RB) (@pair _ _). -Proof. firstorder. Qed. - -Instance fst_compat { A B } (RA:relation A)(RB:relation B) : - Proper (RA*RB ==> RA) Fst. -Proof. -intros (x,y) (x',y') (Hx,Hy); compute in *; auto. -Qed. - -Instance snd_compat { A B } (RA:relation A)(RB:relation B) : - Proper (RA*RB ==> RB) Snd. -Proof. -intros (x,y) (x',y') (Hx,Hy); compute in *; auto. -Qed. - -Instance RelCompFun_compat {A B}(f:A->B)(R : relation B) - `(Proper _ (Ri==>Ri==>Ro) R) : - Proper (Ri@@f==>Ri@@f==>Ro) (R@@f)%signature. -Proof. unfold RelCompFun; firstorder. Qed. +Section RelProd_Instances. + + Context {A : Type} {B : Type} (RA : relation A) (RB : relation B). + + Global Instance RelProd_Reflexive `(Reflexive _ RA, Reflexive _ RB) : Reflexive (RA*RB). + Proof. firstorder. Qed. + + Global Instance RelProd_Symmetric `(Symmetric _ RA, Symmetric _ RB) + : Symmetric (RA*RB). + Proof. firstorder. Qed. + + Global Instance RelProd_Transitive + `(Transitive _ RA, Transitive _ RB) : Transitive (RA*RB). + Proof. firstorder. Qed. + + Global Program Instance RelProd_Equivalence + `(Equivalence _ RA, Equivalence _ RB) : Equivalence (RA*RB). + + Lemma FstRel_ProdRel : + relation_equivalence (RA @@1) (RA*(fun _ _ : B => True)). + Proof. firstorder. Qed. + + Lemma SndRel_ProdRel : + relation_equivalence (RB @@2) ((fun _ _ : A =>True) * RB). + Proof. firstorder. Qed. + + Global Instance FstRel_sub : + subrelation (RA*RB) (RA @@1). + Proof. firstorder. Qed. + + Global Instance SndRel_sub : + subrelation (RA*RB) (RB @@2). + Proof. firstorder. Qed. + + Global Instance pair_compat : + Proper (RA==>RB==> RA*RB) (@pair _ _). + Proof. firstorder. Qed. + + Global Instance fst_compat : + Proper (RA*RB ==> RA) Fst. + Proof. + intros (x,y) (x',y') (Hx,Hy); compute in *; auto. + Qed. + + Global Instance snd_compat : + Proper (RA*RB ==> RB) Snd. + Proof. + intros (x,y) (x',y') (Hx,Hy); compute in *; auto. + Qed. + + Global Instance RelCompFun_compat (f:A->B) + `(Proper _ (Ri==>Ri==>Ro) RB) : + Proper (Ri@@f==>Ri@@f==>Ro) (RB@@f)%signature. + Proof. unfold RelCompFun; firstorder. Qed. +End RelProd_Instances. Hint Unfold RelProd RelCompFun. Hint Extern 2 (RelProd _ _ _ _) => split. diff --git a/theories/Classes/SetoidDec.v b/theories/Classes/SetoidDec.v index 7bc208c45..3ea8fe10e 100644 --- a/theories/Classes/SetoidDec.v +++ b/theories/Classes/SetoidDec.v @@ -121,7 +121,7 @@ Program Instance bool_function_eqdec `(! EqDec (eq_setoid A)) else in_right else in_right. - Solve Obligations with try red ; unfold equiv, complement ; program_simpl. + Solve Obligations with try red ; unfold complement ; program_simpl. Next Obligation. Proof. diff --git a/theories/FSets/FMapAVL.v b/theories/FSets/FMapAVL.v index 5d34a4bf5..bee922c6f 100644 --- a/theories/FSets/FMapAVL.v +++ b/theories/FSets/FMapAVL.v @@ -1247,11 +1247,11 @@ Proof. intros m1 m2; functional induction (concat m1 m2); intros; auto; try factornode _x _x0 _x1 _x2 _x3 as m1. apply join_bst; auto. - change (bst (m2',xd)#1); rewrite <-e1; eauto. + change (bst (m2',xd)#1). rewrite <-e1; eauto. intros y Hy. apply H1; auto. rewrite remove_min_in, e1; simpl; auto. - change (gt_tree (m2',xd)#2#1 (m2',xd)#1); rewrite <-e1; eauto. + change (gt_tree (m2',xd)#2#1 (m2',xd)#1). rewrite <-e1; eauto. Qed. Hint Resolve concat_bst. @@ -1930,7 +1930,7 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Lemma Equivb_Equivb : forall cmp m m', Equivb cmp m m' <-> Raw.Proofs.Equivb cmp m m'. Proof. - intros; unfold Equivb, Equiv, Raw.Proofs.Equivb, In; intuition. + intros; unfold Equivb, Equiv, Raw.Proofs.Equivb, In. intuition. generalize (H0 k); do 2 rewrite In_alt; intuition. generalize (H0 k); do 2 rewrite In_alt; intuition. generalize (H0 k); do 2 rewrite <- In_alt; intuition. diff --git a/theories/FSets/FMapFacts.v b/theories/FSets/FMapFacts.v index 85b7242b5..0e3b5cef1 100644 --- a/theories/FSets/FMapFacts.v +++ b/theories/FSets/FMapFacts.v @@ -437,12 +437,6 @@ intros; do 2 rewrite mem_find_b; rewrite remove_o; unfold eqb. destruct (eq_dec x y); auto. Qed. -Definition option_map (A B:Type)(f:A->B)(o:option A) : option B := - match o with - | Some a => Some (f a) - | None => None - end. - Lemma map_o : forall m x (f:elt->elt'), find x (map f m) = option_map f (find x m). Proof. @@ -678,7 +672,7 @@ Qed. Add Parametric Morphism elt : (@Empty elt) with signature Equal ==> iff as Empty_m. Proof. -unfold Empty; intros m m' Hm; intuition. +unfold Empty; intros m m' Hm. split; intros; intro. rewrite <-Hm in H0; eapply H, H0. rewrite Hm in H0; eapply H, H0. Qed. diff --git a/theories/FSets/FMapList.v b/theories/FSets/FMapList.v index f15ab222c..64d5b1c9a 100644 --- a/theories/FSets/FMapList.v +++ b/theories/FSets/FMapList.v @@ -527,7 +527,7 @@ Fixpoint mapi (f: key -> elt -> elt') (m:t elt) : t elt' := | nil => nil | (k,e)::m' => (k,f k e) :: mapi f m' end. - + End Elt. Section Elt2. (* A new section is necessary for previous definitions to work @@ -543,14 +543,13 @@ Proof. intros m x e f. (* functional induction map elt elt' f m. *) (* Marche pas ??? *) induction m. - inversion 1. + inversion 1. destruct a as (x',e'). simpl. - inversion_clear 1. + inversion_clear 1. constructor 1. unfold eqke in *; simpl in *; intuition congruence. - constructor 2. unfold MapsTo in *; auto. Qed. diff --git a/theories/FSets/FMapPositive.v b/theories/FSets/FMapPositive.v index 792b88717..253800a45 100644 --- a/theories/FSets/FMapPositive.v +++ b/theories/FSets/FMapPositive.v @@ -8,7 +8,7 @@ (** * FMapPositive : an implementation of FMapInterface for [positive] keys. *) -Require Import Bool ZArith OrderedType OrderedTypeEx FMapInterface. +Require Import Bool OrderedType ZArith OrderedType OrderedTypeEx FMapInterface. Set Implicit Arguments. Local Open Scope positive_scope. @@ -69,7 +69,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Module E:=PositiveOrderedTypeBits. Module ME:=KeyOrderedType E. - Definition key := positive. + Definition key := positive : Type. Inductive tree (A : Type) := | Leaf : tree A @@ -93,7 +93,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. | _ => false end. - Fixpoint find (i : positive) (m : t A) : option A := + Fixpoint find (i : key) (m : t A) : option A := match m with | Leaf => None | Node l o r => @@ -104,7 +104,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. end end. - Fixpoint mem (i : positive) (m : t A) : bool := + Fixpoint mem (i : key) (m : t A) : bool := match m with | Leaf => false | Node l o r => @@ -115,7 +115,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. end end. - Fixpoint add (i : positive) (v : A) (m : t A) : t A := + Fixpoint add (i : key) (v : A) (m : t A) : t A := match m with | Leaf => match i with @@ -131,7 +131,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. end end. - Fixpoint remove (i : positive) (m : t A) : t A := + Fixpoint remove (i : key) (m : t A) : t A := match i with | xH => match m with @@ -163,7 +163,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. (** [elements] *) - Fixpoint xelements (m : t A) (i : positive) : list (positive * A) := + Fixpoint xelements (m : t A) (i : key) : list (key * A) := match m with | Leaf => nil | Node l None r => @@ -190,33 +190,33 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Section CompcertSpec. Theorem gempty: - forall (i: positive), find i empty = None. + forall (i: key), find i empty = None. Proof. destruct i; simpl; auto. Qed. Theorem gss: - forall (i: positive) (x: A) (m: t A), find i (add i x m) = Some x. + forall (i: key) (x: A) (m: t A), find i (add i x m) = Some x. Proof. induction i; destruct m; simpl; auto. Qed. - Lemma gleaf : forall (i : positive), find i (Leaf : t A) = None. + Lemma gleaf : forall (i : key), find i (Leaf : t A) = None. Proof. exact gempty. Qed. Theorem gso: - forall (i j: positive) (x: A) (m: t A), + forall (i j: key) (x: A) (m: t A), i <> j -> find i (add j x m) = find i m. Proof. induction i; intros; destruct j; destruct m; simpl; try rewrite <- (gleaf i); auto; try apply IHi; congruence. Qed. - Lemma rleaf : forall (i : positive), remove i (Leaf : t A) = Leaf. + Lemma rleaf : forall (i : key), remove i (Leaf : t A) = Leaf. Proof. destruct i; simpl; auto. Qed. Theorem grs: - forall (i: positive) (m: t A), find i (remove i m) = None. + forall (i: key) (m: t A), find i (remove i m) = None. Proof. induction i; destruct m. simpl; auto. @@ -236,7 +236,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Qed. Theorem gro: - forall (i j: positive) (m: t A), + forall (i j: key) (m: t A), i <> j -> find i (remove j m) = find i m. Proof. induction i; intros; destruct j; destruct m; @@ -265,11 +265,11 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Qed. Lemma xelements_correct: - forall (m: t A) (i j : positive) (v: A), + forall (m: t A) (i j : key) (v: A), find i m = Some v -> List.In (append j i, v) (xelements m j). Proof. induction m; intros. - rewrite (gleaf i) in H; congruence. + rewrite (gleaf i) in H; discriminate. destruct o; destruct i; simpl; simpl in H. rewrite append_assoc_1; apply in_or_app; right; apply in_cons; apply IHm2; auto. @@ -282,14 +282,14 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Qed. Theorem elements_correct: - forall (m: t A) (i: positive) (v: A), + forall (m: t A) (i: key) (v: A), find i m = Some v -> List.In (i, v) (elements m). Proof. intros m i v H. exact (xelements_correct m i xH H). Qed. - Fixpoint xfind (i j : positive) (m : t A) : option A := + Fixpoint xfind (i j : key) (m : t A) : option A := match i, j with | _, xH => find i m | xO ii, xO jj => xfind ii jj m @@ -298,7 +298,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. end. Lemma xfind_left : - forall (j i : positive) (m1 m2 : t A) (o : option A) (v : A), + forall (j i : key) (m1 m2 : t A) (o : option A) (v : A), xfind i (append j (xO xH)) m1 = Some v -> xfind i j (Node m1 o m2) = Some v. Proof. induction j; intros; destruct i; simpl; simpl in H; auto; try congruence. @@ -306,7 +306,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Qed. Lemma xelements_ii : - forall (m: t A) (i j : positive) (v: A), + forall (m: t A) (i j : key) (v: A), List.In (xI i, v) (xelements m (xI j)) -> List.In (i, v) (xelements m j). Proof. induction m. @@ -322,7 +322,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Qed. Lemma xelements_io : - forall (m: t A) (i j : positive) (v: A), + forall (m: t A) (i j : key) (v: A), ~List.In (xI i, v) (xelements m (xO j)). Proof. induction m. @@ -337,7 +337,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Qed. Lemma xelements_oo : - forall (m: t A) (i j : positive) (v: A), + forall (m: t A) (i j : key) (v: A), List.In (xO i, v) (xelements m (xO j)) -> List.In (i, v) (xelements m j). Proof. induction m. @@ -353,7 +353,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Qed. Lemma xelements_oi : - forall (m: t A) (i j : positive) (v: A), + forall (m: t A) (i j : key) (v: A), ~List.In (xO i, v) (xelements m (xI j)). Proof. induction m. @@ -368,7 +368,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Qed. Lemma xelements_ih : - forall (m1 m2: t A) (o: option A) (i : positive) (v: A), + forall (m1 m2: t A) (o: option A) (i : key) (v: A), List.In (xI i, v) (xelements (Node m1 o m2) xH) -> List.In (i, v) (xelements m2 xH). Proof. destruct o; simpl; intros; destruct (in_app_or _ _ _ H). @@ -381,7 +381,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Qed. Lemma xelements_oh : - forall (m1 m2: t A) (o: option A) (i : positive) (v: A), + forall (m1 m2: t A) (o: option A) (i : key) (v: A), List.In (xO i, v) (xelements (Node m1 o m2) xH) -> List.In (i, v) (xelements m1 xH). Proof. destruct o; simpl; intros; destruct (in_app_or _ _ _ H). @@ -394,7 +394,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Qed. Lemma xelements_hi : - forall (m: t A) (i : positive) (v: A), + forall (m: t A) (i : key) (v: A), ~List.In (xH, v) (xelements m (xI i)). Proof. induction m; intros. @@ -409,7 +409,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Qed. Lemma xelements_ho : - forall (m: t A) (i : positive) (v: A), + forall (m: t A) (i : key) (v: A), ~List.In (xH, v) (xelements m (xO i)). Proof. induction m; intros. @@ -424,13 +424,13 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Qed. Lemma find_xfind_h : - forall (m: t A) (i: positive), find i m = xfind i xH m. + forall (m: t A) (i: key), find i m = xfind i xH m. Proof. destruct i; simpl; auto. Qed. Lemma xelements_complete: - forall (i j : positive) (m: t A) (v: A), + forall (i j : key) (m: t A) (v: A), List.In (i, v) (xelements m j) -> xfind i j m = Some v. Proof. induction i; simpl; intros; destruct j; simpl. @@ -458,7 +458,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Qed. Theorem elements_complete: - forall (m: t A) (i: positive) (v: A), + forall (m: t A) (i: key) (v: A), List.In (i, v) (elements m) -> find i m = Some v. Proof. intros m i v H. @@ -479,18 +479,18 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. End CompcertSpec. - Definition MapsTo (i:positive)(v:A)(m:t A) := find i m = Some v. + Definition MapsTo (i:key)(v:A)(m:t A) := find i m = Some v. - Definition In (i:positive)(m:t A) := exists e:A, MapsTo i e m. + Definition In (i:key)(m:t A) := exists e:A, MapsTo i e m. - Definition Empty m := forall (a : positive)(e:A) , ~ MapsTo a e m. + Definition Empty m := forall (a : key)(e:A) , ~ MapsTo a e m. - Definition eq_key (p p':positive*A) := E.eq (fst p) (fst p'). + Definition eq_key (p p':key*A) := E.eq (fst p) (fst p'). - Definition eq_key_elt (p p':positive*A) := + Definition eq_key_elt (p p':key*A) := E.eq (fst p) (fst p') /\ (snd p) = (snd p'). - Definition lt_key (p p':positive*A) := E.lt (fst p) (fst p'). + Definition lt_key (p p':key*A) := E.lt (fst p) (fst p'). Global Instance eqk_equiv : Equivalence eq_key := _. Global Instance eqke_equiv : Equivalence eq_key_elt := _. @@ -715,8 +715,8 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Lemma elements_3w : NoDupA eq_key (elements m). Proof. - change eq_key with (@ME.eqk A). - apply ME.Sort_NoDupA; apply elements_3; auto. + apply ME.Sort_NoDupA. + apply elements_3. Qed. End FMapSpec. @@ -727,9 +727,9 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Section Mapi. - Variable f : positive -> A -> B. + Variable f : key -> A -> B. - Fixpoint xmapi (m : t A) (i : positive) : t B := + Fixpoint xmapi (m : t A) (i : key) : t B := match m with | Leaf => @Leaf B | Node l o r => Node (xmapi l (append i (xO xH))) @@ -746,7 +746,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. End A. Lemma xgmapi: - forall (A B: Type) (f: positive -> A -> B) (i j : positive) (m: t A), + forall (A B: Type) (f: key -> A -> B) (i j : key) (m: t A), find i (xmapi f m j) = option_map (f (append j i)) (find i m). Proof. induction i; intros; destruct m; simpl; auto. @@ -756,7 +756,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Qed. Theorem gmapi: - forall (A B: Type) (f: positive -> A -> B) (i: positive) (m: t A), + forall (A B: Type) (f: key -> A -> B) (i: key) (m: t A), find i (mapi f m) = option_map (f i) (find i m). Proof. intros. @@ -820,7 +820,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. | Node l o r => Node (xmap2_l l) (f o None) (xmap2_l r) end. - Lemma xgmap2_l : forall (i : positive) (m : t A), + Lemma xgmap2_l : forall (i : key) (m : t A), f None None = None -> find i (xmap2_l m) = f (find i m) None. Proof. induction i; intros; destruct m; simpl; auto. @@ -832,7 +832,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. | Node l o r => Node (xmap2_r l) (f None o) (xmap2_r r) end. - Lemma xgmap2_r : forall (i : positive) (m : t B), + Lemma xgmap2_r : forall (i : key) (m : t B), f None None = None -> find i (xmap2_r m) = f None (find i m). Proof. induction i; intros; destruct m; simpl; auto. @@ -848,7 +848,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. end end. - Lemma gmap2: forall (i: positive)(m1:t A)(m2: t B), + Lemma gmap2: forall (i: key)(m1:t A)(m2: t B), f None None = None -> find i (_map2 m1 m2) = f (find i m1) (find i m2). Proof. @@ -896,9 +896,9 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Section Fold. Variables A B : Type. - Variable f : positive -> A -> B -> B. + Variable f : key -> A -> B -> B. - Fixpoint xfoldi (m : t A) (v : B) (i : positive) := + Fixpoint xfoldi (m : t A) (v : B) (i : key) := match m with | Leaf _ => v | Node l (Some x) r => @@ -1070,7 +1070,7 @@ Module PositiveMapAdditionalFacts. (* Derivable from the Map interface *) Theorem gsspec: - forall (A:Type)(i j: positive) (x: A) (m: t A), + forall (A:Type)(i j: key) (x: A) (m: t A), find i (add j x m) = if E.eq_dec i j then Some x else find i m. Proof. intros. @@ -1079,7 +1079,7 @@ Module PositiveMapAdditionalFacts. (* Not derivable from the Map interface *) Theorem gsident: - forall (A:Type)(i: positive) (m: t A) (v: A), + forall (A:Type)(i: key) (m: t A) (v: A), find i m = Some v -> add i v m = m. Proof. induction i; intros; destruct m; simpl; simpl in H; try congruence. @@ -1118,4 +1118,3 @@ Module PositiveMapAdditionalFacts. Qed. End PositiveMapAdditionalFacts. - diff --git a/theories/FSets/FSetPositive.v b/theories/FSets/FSetPositive.v index 670d09154..efd49f54e 100644 --- a/theories/FSets/FSetPositive.v +++ b/theories/FSets/FSetPositive.v @@ -27,7 +27,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. Module E:=PositiveOrderedTypeBits. - Definition elt := positive. + Definition elt := positive : Type. Inductive tree := | Leaf : tree @@ -35,9 +35,9 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. Scheme tree_ind := Induction for tree Sort Prop. - Definition t := tree. + Definition t := tree : Type. - Definition empty := Leaf. + Definition empty : t := Leaf. Fixpoint is_empty (m : t) : bool := match m with @@ -45,7 +45,11 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. | Node l b r => negb b &&& is_empty l &&& is_empty r end. +<<<<<<< HEAD Fixpoint mem (i : positive) (m : t) {struct m} : bool := +======= + Fixpoint mem (i : elt) (m : t) : bool := +>>>>>>> This commit adds full universe polymorphism and fast projections to Coq. match m with | Leaf => false | Node l o r => @@ -56,7 +60,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. end end. - Fixpoint add (i : positive) (m : t) : t := + Fixpoint add (i : elt) (m : t) : t := match m with | Leaf => match i with @@ -76,13 +80,17 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. (** helper function to avoid creating empty trees that are not leaves *) - Definition node l (b: bool) r := + Definition node (l : t) (b: bool) (r : t) : t := if b then Node l b r else match l,r with | Leaf,Leaf => Leaf | _,_ => Node l false r end. +<<<<<<< HEAD Fixpoint remove (i : positive) (m : t) {struct m} : t := +======= + Fixpoint remove (i : elt) (m : t) : t := +>>>>>>> This commit adds full universe polymorphism and fast projections to Coq. match m with | Leaf => Leaf | Node l o r => @@ -93,7 +101,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. end end. - Fixpoint union (m m': t) := + Fixpoint union (m m': t) : t := match m with | Leaf => m' | Node l o r => @@ -103,7 +111,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. end end. - Fixpoint inter (m m': t) := + Fixpoint inter (m m': t) : t := match m with | Leaf => Leaf | Node l o r => @@ -113,7 +121,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. end end. - Fixpoint diff (m m': t) := + Fixpoint diff (m m': t) : t := match m with | Leaf => Leaf | Node l o r => @@ -145,7 +153,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. (** reverses [y] and concatenate it with [x] *) - Fixpoint rev_append y x := + Fixpoint rev_append (y x : elt) : elt := match y with | 1 => x | y~1 => rev_append y x~1 @@ -156,8 +164,8 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. Section Fold. - Variables B : Type. - Variable f : positive -> B -> B. + Variable B : Type. + Variable f : elt -> B -> B. (** the additional argument, [i], records the current path, in reverse order (this should be more efficient: we reverse this argument @@ -165,7 +173,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. we also use this convention in all functions below *) - Fixpoint xfold (m : t) (v : B) (i : positive) := + Fixpoint xfold (m : t) (v : B) (i : elt) := match m with | Leaf => v | Node l true r => @@ -179,9 +187,9 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. Section Quantifiers. - Variable f : positive -> bool. + Variable f : elt -> bool. - Fixpoint xforall (m : t) (i : positive) := + Fixpoint xforall (m : t) (i : elt) := match m with | Leaf => true | Node l o r => @@ -189,21 +197,21 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. end. Definition for_all m := xforall m 1. - Fixpoint xexists (m : t) (i : positive) := + Fixpoint xexists (m : t) (i : elt) := match m with | Leaf => false | Node l o r => (o &&& f (rev i)) ||| xexists r i~1 ||| xexists l i~0 end. Definition exists_ m := xexists m 1. - Fixpoint xfilter (m : t) (i : positive) := + Fixpoint xfilter (m : t) (i : elt) : t := match m with | Leaf => Leaf | Node l o r => node (xfilter l i~0) (o &&& f (rev i)) (xfilter r i~1) end. Definition filter m := xfilter m 1. - Fixpoint xpartition (m : t) (i : positive) := + Fixpoint xpartition (m : t) (i : elt) : t * t := match m with | Leaf => (Leaf,Leaf) | Node l o r => @@ -221,7 +229,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. (** uses [a] to accumulate values rather than doing a lot of concatenations *) - Fixpoint xelements (m : t) (i : positive) (a: list positive) := + Fixpoint xelements (m : t) (i : elt) (a: list elt) := match m with | Leaf => a | Node l false r => xelements l i~0 (xelements r i~1 a) @@ -245,7 +253,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. (** would it be more efficient to use a path like in the above functions ? *) - Fixpoint choose (m: t) := + Fixpoint choose (m: t) : option elt := match m with | Leaf => None | Node l o r => if o then Some 1 else @@ -255,7 +263,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. end end. - Fixpoint min_elt (m: t) := + Fixpoint min_elt (m: t) : option elt := match m with | Leaf => None | Node l o r => @@ -265,7 +273,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. end end. - Fixpoint max_elt (m: t) := + Fixpoint max_elt (m: t) : option elt := match m with | Leaf => None | Node l o r => @@ -750,7 +758,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. Proof. intros. rewrite diff_spec. split; assumption. Qed. (** Specification of [fold] *) - + Lemma fold_1: forall s (A : Type) (i : A) (f : elt -> A -> A), fold f s i = fold_left (fun a e => f e a) (elements s) i. Proof. @@ -798,15 +806,15 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. rewrite <- andb_lazy_alt. apply andb_true_iff. Qed. - Lemma filter_1 : forall s x f, compat_bool E.eq f -> + Lemma filter_1 : forall s x f, @compat_bool elt E.eq f -> In x (filter f s) -> In x s. Proof. unfold filter. intros s x f _. rewrite xfilter_spec. tauto. Qed. - Lemma filter_2 : forall s x f, compat_bool E.eq f -> + Lemma filter_2 : forall s x f, @compat_bool elt E.eq f -> In x (filter f s) -> f x = true. Proof. unfold filter. intros s x f _. rewrite xfilter_spec. tauto. Qed. - Lemma filter_3 : forall s x f, compat_bool E.eq f -> In x s -> + Lemma filter_3 : forall s x f, @compat_bool elt E.eq f -> In x s -> f x = true -> In x (filter f s). Proof. unfold filter. intros s x f _. rewrite xfilter_spec. tauto. Qed. @@ -831,11 +839,11 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. apply H. assumption. Qed. - Lemma for_all_1 : forall s f, compat_bool E.eq f -> + Lemma for_all_1 : forall s f, @compat_bool elt E.eq f -> For_all (fun x => f x = true) s -> for_all f s = true. Proof. intros s f _. unfold for_all. rewrite xforall_spec. trivial. Qed. - Lemma for_all_2 : forall s f, compat_bool E.eq f -> + Lemma for_all_2 : forall s f, @compat_bool elt E.eq f -> for_all f s = true -> For_all (fun x => f x = true) s. Proof. intros s f _. unfold for_all. rewrite xforall_spec. trivial. Qed. @@ -858,11 +866,11 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. intros [[x|x|] H]; eauto. Qed. - Lemma exists_1 : forall s f, compat_bool E.eq f -> + Lemma exists_1 : forall s f, @compat_bool elt E.eq f -> Exists (fun x => f x = true) s -> exists_ f s = true. Proof. intros s f _. unfold exists_. rewrite xexists_spec. trivial. Qed. - Lemma exists_2 : forall s f, compat_bool E.eq f -> + Lemma exists_2 : forall s f, @compat_bool elt E.eq f -> exists_ f s = true -> Exists (fun x => f x = true) s. Proof. intros s f _. unfold exists_. rewrite xexists_spec. trivial. Qed. @@ -878,11 +886,11 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. destruct o; simpl; rewrite IHl, IHr; reflexivity. Qed. - Lemma partition_1 : forall s f, compat_bool E.eq f -> + Lemma partition_1 : forall s f, @compat_bool elt E.eq f -> Equal (fst (partition f s)) (filter f s). Proof. intros. rewrite partition_filter. apply eq_refl. Qed. - Lemma partition_2 : forall s f, compat_bool E.eq f -> + Lemma partition_2 : forall s f, @compat_bool elt E.eq f -> Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). Proof. intros. rewrite partition_filter. apply eq_refl. Qed. @@ -990,7 +998,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. constructor. intros x H. apply E.lt_not_eq in H. apply H. reflexivity. intro. apply E.lt_trans. - intros ? ? <- ? ? <-. reflexivity. + solve_proper. apply elements_3. Qed. @@ -1101,7 +1109,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. destruct (min_elt r). injection H. intros <-. clear H. destruct y as [z|z|]. - apply (IHr p z); trivial. + apply (IHr e z); trivial. elim (Hp _ H'). discriminate. discriminate. @@ -1155,7 +1163,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. injection H. intros <-. clear H. destruct y as [z|z|]. elim (Hp _ H'). - apply (IHl p z); trivial. + apply (IHl e z); trivial. discriminate. discriminate. Qed. diff --git a/theories/Init/Datatypes.v b/theories/Init/Datatypes.v index a95695454..cc46fe617 100644 --- a/theories/Init/Datatypes.v +++ b/theories/Init/Datatypes.v @@ -143,6 +143,8 @@ Arguments S _%nat. (********************************************************************) (** * Container datatypes *) +Set Universe Polymorphism. + (** [option A] is the extension of [A] with an extra element [None] *) Inductive option (A:Type) : Type := @@ -182,7 +184,8 @@ Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope. Arguments pair {A B} _ _. Section projections. - Variables A B : Type. + Context {A : Type} {B : Type}. + Definition fst (p:A * B) := match p with | (x, y) => x end. @@ -244,8 +247,10 @@ Definition app (A : Type) : list A -> list A -> list A := | a :: l1 => a :: app l1 m end. + Infix "++" := app (right associativity, at level 60) : list_scope. +Unset Universe Polymorphism. (********************************************************************) (** * The comparison datatype *) @@ -310,6 +315,7 @@ Defined. Definition CompSpec {A} (eq lt : A->A->Prop)(x y:A) : comparison -> Prop := CompareSpec (eq x y) (lt x y) (lt y x). + Definition CompSpecT {A} (eq lt : A->A->Prop)(x y:A) : comparison -> Type := CompareSpecT (eq x y) (lt x y) (lt y x). Hint Unfold CompSpec CompSpecT. @@ -336,8 +342,11 @@ Arguments identity_rect [A] a P f y i. (** Identity type *) -Definition ID := forall A:Type, A -> A. -Definition id : ID := fun A x => x. +Polymorphic Definition ID := forall A:Type, A -> A. +Polymorphic Definition id : ID := fun A x => x. + +Definition IDProp := forall A:Prop, A -> A. +Definition idProp : IDProp := fun A x => x. (* begin hide *) diff --git a/theories/Init/Logic.v b/theories/Init/Logic.v index 9251d00ff..f994b4ca6 100644 --- a/theories/Init/Logic.v +++ b/theories/Init/Logic.v @@ -15,6 +15,7 @@ Notation "A -> B" := (forall (_ : A), B) : type_scope. (** * Propositional connectives *) (** [True] is the always true proposition *) + Inductive True : Prop := I : True. @@ -232,7 +233,6 @@ Notation "'IF' c1 'then' c2 'else' c3" := (IF_then_else c1 c2 c3) P x] is in fact equivalent to [ex (fun x => P x)] which may be not convertible to [ex P] if [P] is not itself an abstraction *) - Inductive ex (A:Type) (P:A -> Prop) : Prop := ex_intro : forall x:A, P x -> ex (A:=A) P. @@ -301,7 +301,8 @@ Arguments eq_ind [A] x P _ y _. Arguments eq_rec [A] x P _ y _. Arguments eq_rect [A] x P _ y _. -Hint Resolve I conj or_introl or_intror eq_refl: core. +Hint Resolve I conj or_introl or_intror : core. +Hint Resolve eq_refl: core. Hint Resolve ex_intro ex_intro2: core. Section Logic_lemmas. @@ -341,7 +342,7 @@ Section Logic_lemmas. Definition eq_ind_r : forall (A:Type) (x:A) (P:A -> Prop), P x -> forall y:A, y = x -> P y. - intros A x P H y H0; elim eq_sym with (1 := H0); assumption. + intros A x P H y H0. elim eq_sym with (1 := H0); assumption. Defined. Definition eq_rec_r : diff --git a/theories/Init/Specif.v b/theories/Init/Specif.v index f58c21f48..f534dd6c6 100644 --- a/theories/Init/Specif.v +++ b/theories/Init/Specif.v @@ -21,19 +21,19 @@ Require Import Logic. Similarly [(sig2 A P Q)], or [{x:A | P x & Q x}], denotes the subset of elements of the type [A] which satisfy both [P] and [Q]. *) -Inductive sig (A:Type) (P:A -> Prop) : Type := +Polymorphic Inductive sig (A:Type) (P:A -> Prop) : Type := exist : forall x:A, P x -> sig P. -Inductive sig2 (A:Type) (P Q:A -> Prop) : Type := +Polymorphic Inductive sig2 (A:Type) (P Q:A -> Prop) : Type := exist2 : forall x:A, P x -> Q x -> sig2 P Q. (** [(sigT A P)], or more suggestively [{x:A & (P x)}] is a Sigma-type. Similarly for [(sigT2 A P Q)], also written [{x:A & (P x) & (Q x)}]. *) -Inductive sigT (A:Type) (P:A -> Type) : Type := +Polymorphic Inductive sigT (A:Type) (P:A -> Type) : Type := existT : forall x:A, P x -> sigT P. -Inductive sigT2 (A:Type) (P Q:A -> Type) : Type := +Polymorphic Inductive sigT2 (A:Type) (P Q:A -> Type) : Type := existT2 : forall x:A, P x -> Q x -> sigT2 P Q. (* Notations *) @@ -65,7 +65,7 @@ Add Printing Let sigT2. [(proj1_sig y)] is the witness [a] and [(proj2_sig y)] is the proof of [(P a)] *) - +Set Universe Polymorphism. Section Subset_projections. Variable A : Type. @@ -123,6 +123,8 @@ End Subset_projections2. [(projT1 x)] is the first projection and [(projT2 x)] is the second projection, the type of which depends on the [projT1]. *) + + Section Projections. Variable A : Type. @@ -131,6 +133,7 @@ Section Projections. Definition projT1 (x:sigT P) : A := match x with | existT _ a _ => a end. + Definition projT2 (x:sigT P) : P (projT1 x) := match x return P (projT1 x) with | existT _ _ h => h @@ -212,6 +215,8 @@ Add Printing If sumor. Arguments inleft {A B} _ , [A] B _. Arguments inright {A B} _ , A [B] _. +Unset Universe Polymorphism. + (** Various forms of the axiom of choice for specifications *) Section Choice_lemmas. @@ -257,10 +262,10 @@ Section Dependent_choice_lemmas. (forall x:X, {y | R x y}) -> forall x0, {f : nat -> X | f O = x0 /\ forall n, R (f n) (f (S n))}. Proof. - intros H x0. + intros H x0. set (f:=fix f n := match n with O => x0 | S n' => proj1_sig (H (f n')) end). exists f. - split. reflexivity. + split. reflexivity. induction n; simpl; apply proj2_sig. Defined. @@ -273,11 +278,13 @@ End Dependent_choice_lemmas. [Inductive Exc [A:Type] : Type := value : A->(Exc A) | error : (Exc A)]. It is implemented using the option type. *) +Section Exc. + Variable A : Type. -Definition Exc := option. -Definition value := Some. -Definition error := @None. - + Definition Exc := option A. + Definition value := @Some A. + Definition error := @None A. +End Exc. Arguments error [A]. Definition except := False_rec. (* for compatibility with previous versions *) diff --git a/theories/Lists/List.v b/theories/Lists/List.v index d282fe8c3..f6a0382c2 100644 --- a/theories/Lists/List.v +++ b/theories/Lists/List.v @@ -10,7 +10,7 @@ Require Import Le Gt Minus Bool. Require Setoid. Set Implicit Arguments. - +Set Universe Polymorphism. (******************************************************************) (** * Basics: definition of polymorphic lists and some operations *) @@ -65,8 +65,6 @@ End ListNotations. Import ListNotations. -(** ** Facts about lists *) - Section Facts. Variable A : Type. @@ -131,7 +129,7 @@ Section Facts. subst a; auto. exists [], l; auto. destruct (IHl H) as (l1,(l2,H0)). - exists (a::l1), l2; simpl; f_equal; auto. + exists (a::l1), l2; simpl. apply f_equal. auto. Qed. (** Inversion *) @@ -174,7 +172,7 @@ Section Facts. Qed. Theorem app_nil_r : forall l:list A, l ++ [] = l. - Proof. + Proof. induction l; simpl; f_equal; auto. Qed. @@ -654,8 +652,6 @@ Section Elts. End Elts. - - (*******************************) (** * Manipulating whole lists *) (*******************************) @@ -858,7 +854,7 @@ End ListOps. (************) Section Map. - Variables A B : Type. + Variables (A : Type) (B : Type). Variable f : A -> B. Fixpoint map (l:list A) : list B := @@ -983,7 +979,7 @@ Qed. (************************************) Section Fold_Left_Recursor. - Variables A B : Type. + Variables (A : Type) (B : Type). Variable f : A -> B -> A. Fixpoint fold_left (l:list B) (a0:A) : A := @@ -1021,7 +1017,7 @@ Qed. (************************************) Section Fold_Right_Recursor. - Variables A B : Type. + Variables (A : Type) (B : Type). Variable f : B -> A -> A. Variable a0 : A. @@ -1211,7 +1207,7 @@ End Fold_Right_Recursor. (******************************************************) Section ListPairs. - Variables A B : Type. + Variables (A : Type) (B : Type). (** [split] derives two lists from a list of pairs *) @@ -2039,3 +2035,5 @@ Notation AllS := Forall (only parsing). (* was formerly in TheoryList *) Hint Resolve app_nil_end : datatypes v62. (* end hide *) + +Unset Universe Polymorphism. diff --git a/theories/Lists/SetoidList.v b/theories/Lists/SetoidList.v index 8fd229917..d75eb384f 100644 --- a/theories/Lists/SetoidList.v +++ b/theories/Lists/SetoidList.v @@ -11,7 +11,7 @@ Require Export Sorted. Require Export Setoid Basics Morphisms. Set Implicit Arguments. Unset Strict Implicit. - +Set Universe Polymorphism. (** * Logical relations over lists with respect to a setoid equality or ordering. *) @@ -34,7 +34,7 @@ Hint Constructors InA. of the previous one. Having [InA = Exists eqA] raises too many compatibility issues. For now, we only state the equivalence: *) -Lemma InA_altdef : forall x l, InA x l <-> Exists (eqA x) l. +Lemma InA_altdef : forall x l, InA x l <-> Exists (eqA x) l. Proof. split; induction 1; auto. Qed. Lemma InA_cons : forall x y l, InA x (y::l) <-> eqA x y \/ InA x l. @@ -104,7 +104,7 @@ Hypothesis eqA_equiv : Equivalence eqA. Definition eqarefl := (@Equivalence_Reflexive _ _ eqA_equiv). Definition eqatrans := (@Equivalence_Transitive _ _ eqA_equiv). Definition eqasym := (@Equivalence_Symmetric _ _ eqA_equiv). - + Hint Resolve eqarefl eqatrans. Hint Immediate eqasym. @@ -151,7 +151,7 @@ Qed. Lemma InA_eqA : forall l x y, eqA x y -> InA x l -> InA y l. Proof. - intros l x y H H'. rewrite <- H; auto. + intros l x y H H'. rewrite <- H. auto. Qed. Hint Immediate InA_eqA. @@ -498,7 +498,7 @@ Proof. apply Hrec; auto. inv; auto. eapply NoDupA_split; eauto. - invlist ForallOrdPairs; auto. + invlist ForallOrdPairs; auto. eapply equivlistA_NoDupA_split; eauto. transitivity (f y (fold_right f i (s1++s2))). apply Comp; auto. reflexivity. @@ -819,7 +819,6 @@ intros. rewrite filter_In in H; destruct H. eapply SortA_InfA_InA; eauto. Qed. - Arguments eq {A} x _. Lemma filter_InA : forall f, Proper (eqA==>eq) f -> diff --git a/theories/Lists/SetoidPermutation.v b/theories/Lists/SetoidPermutation.v index b0657b63a..05f03ea56 100644 --- a/theories/Lists/SetoidPermutation.v +++ b/theories/Lists/SetoidPermutation.v @@ -7,6 +7,7 @@ (***********************************************************************) Require Import SetoidList. +Set Universe Polymorphism. Set Implicit Arguments. Unset Strict Implicit. @@ -88,7 +89,7 @@ Lemma PermutationA_cons_app l l₁ l₂ x : PermutationA l (l₁ ++ l₂) -> PermutationA (x :: l) (l₁ ++ x :: l₂). Proof. intros E. rewrite E. - now rewrite app_comm_cons, PermutationA_cons_append, <-app_assoc. + now rewrite app_comm_cons, (PermutationA_cons_append l₁ x), <- app_assoc. Qed. Lemma PermutationA_middle l₁ l₂ x : diff --git a/theories/Logic/Berardi.v b/theories/Logic/Berardi.v index 383775735..cb61e8f00 100644 --- a/theories/Logic/Berardi.v +++ b/theories/Logic/Berardi.v @@ -67,18 +67,13 @@ Variables A B : Prop. Record retract : Prop := {i : A -> B; j : B -> A; inv : forall a:A, j (i a) = a}. - Record retract_cond : Prop := {i2 : A -> B; j2 : B -> A; inv2 : retract -> forall a:A, j2 (i2 a) = a}. - (** The dependent elimination above implies the axiom of choice: *) -Lemma AC : forall r:retract_cond, retract -> forall a:A, j2 r (i2 r a) = a. -Proof. -intros r. -case r; simpl. -trivial. -Qed. + +Lemma AC : forall r:retract_cond, retract -> forall a:A, r.(j2) (r.(i2) a) = a. +Proof. intros r. exact r.(inv2). Qed. End Retracts. @@ -114,7 +109,7 @@ Proof. exists g f. intro a. unfold f, g; simpl. -apply AC. +apply AC. exists (fun x:pow U => x) (fun x:pow U => x). trivial. Qed. @@ -132,9 +127,10 @@ Lemma not_has_fixpoint : R R = Not_b (R R). Proof. unfold R at 1. unfold g. -rewrite AC with (r := L1 U U) (a := fun u:U => Not_b (u U u)). +rewrite AC. +trivial. +exists (fun x:pow U => x) (fun x:pow U => x). trivial. -exists (fun x:pow U => x) (fun x:pow U => x); trivial. Qed. diff --git a/theories/Logic/ChoiceFacts.v b/theories/Logic/ChoiceFacts.v index b22f58dad..57a82161d 100644 --- a/theories/Logic/ChoiceFacts.v +++ b/theories/Logic/ChoiceFacts.v @@ -96,6 +96,12 @@ Local Unset Intuition Negation Unfolding. (** Choice, reification and description schemes *) +(** We make them all polymorphic. most of them have existentials as conclusion + so they require polymorphism otherwise their first application (e.g. to an + existential in [Set]) will fix the level of [A]. +*) +Set Universe Polymorphism. + Section ChoiceSchemes. Variables A B :Type. @@ -217,39 +223,39 @@ End ChoiceSchemes. (** Generalized schemes *) Notation RelationalChoice := - (forall A B, RelationalChoice_on A B). + (forall A B : Type, RelationalChoice_on A B). Notation FunctionalChoice := - (forall A B, FunctionalChoice_on A B). + (forall A B : Type, FunctionalChoice_on A B). Definition FunctionalDependentChoice := - (forall A, FunctionalDependentChoice_on A). + (forall A : Type, FunctionalDependentChoice_on A). Definition FunctionalCountableChoice := - (forall A, FunctionalCountableChoice_on A). + (forall A : Type, FunctionalCountableChoice_on A). Notation FunctionalChoiceOnInhabitedSet := - (forall A B, inhabited B -> FunctionalChoice_on A B). + (forall A B : Type, inhabited B -> FunctionalChoice_on A B). Notation FunctionalRelReification := - (forall A B, FunctionalRelReification_on A B). + (forall A B : Type, FunctionalRelReification_on A B). Notation GuardedRelationalChoice := - (forall A B, GuardedRelationalChoice_on A B). + (forall A B : Type, GuardedRelationalChoice_on A B). Notation GuardedFunctionalChoice := - (forall A B, GuardedFunctionalChoice_on A B). + (forall A B : Type, GuardedFunctionalChoice_on A B). Notation GuardedFunctionalRelReification := - (forall A B, GuardedFunctionalRelReification_on A B). + (forall A B : Type, GuardedFunctionalRelReification_on A B). Notation OmniscientRelationalChoice := - (forall A B, OmniscientRelationalChoice_on A B). + (forall A B : Type, OmniscientRelationalChoice_on A B). Notation OmniscientFunctionalChoice := - (forall A B, OmniscientFunctionalChoice_on A B). + (forall A B : Type, OmniscientFunctionalChoice_on A B). Notation ConstructiveDefiniteDescription := - (forall A, ConstructiveDefiniteDescription_on A). + (forall A : Type, ConstructiveDefiniteDescription_on A). Notation ConstructiveIndefiniteDescription := - (forall A, ConstructiveIndefiniteDescription_on A). + (forall A : Type, ConstructiveIndefiniteDescription_on A). Notation IotaStatement := - (forall A, IotaStatement_on A). + (forall A : Type, IotaStatement_on A). Notation EpsilonStatement := - (forall A, EpsilonStatement_on A). + (forall A : Type, EpsilonStatement_on A). (** Subclassical schemes *) @@ -293,7 +299,7 @@ Proof. Qed. Lemma funct_choice_imp_rel_choice : - forall A B, FunctionalChoice_on A B -> RelationalChoice_on A B. + forall A B : Type, FunctionalChoice_on A B -> RelationalChoice_on A B. Proof. intros A B FunCh R H. destruct (FunCh R H) as (f,H0). @@ -306,7 +312,7 @@ Proof. Qed. Lemma funct_choice_imp_description : - forall A B, FunctionalChoice_on A B -> FunctionalRelReification_on A B. + forall A B : Type, FunctionalChoice_on A B -> FunctionalRelReification_on A B. Proof. intros A B FunCh R H. destruct (FunCh R) as [f H0]. @@ -319,10 +325,10 @@ Proof. Qed. Corollary FunChoice_Equiv_RelChoice_and_ParamDefinDescr : - forall A B, FunctionalChoice_on A B <-> + forall A B : Type, FunctionalChoice_on A B <-> RelationalChoice_on A B /\ FunctionalRelReification_on A B. Proof. - intros A B; split. + intros A B. split. intro H; split; [ exact (funct_choice_imp_rel_choice H) | exact (funct_choice_imp_description H) ]. @@ -363,7 +369,7 @@ Proof. Qed. Lemma rel_choice_indep_of_general_premises_imp_guarded_rel_choice : - forall A B, inhabited B -> RelationalChoice_on A B -> + forall A B : Type, inhabited B -> RelationalChoice_on A B -> IndependenceOfGeneralPremises -> GuardedRelationalChoice_on A B. Proof. intros A B Inh AC_rel IndPrem P R H. @@ -375,7 +381,7 @@ Proof. Qed. Lemma guarded_rel_choice_imp_rel_choice : - forall A B, GuardedRelationalChoice_on A B -> RelationalChoice_on A B. + forall A B : Type, GuardedRelationalChoice_on A B -> RelationalChoice_on A B. Proof. intros A B GAC_rel R H. destruct (GAC_rel (fun _ => True) R) as (R',(HR'R,H0)). @@ -794,12 +800,13 @@ be applied on the same Type universes on both sides of the first Require Import Setoid. Theorem constructive_definite_descr_excluded_middle : - ConstructiveDefiniteDescription -> + (forall A : Type, ConstructiveDefiniteDescription_on A) -> (forall P:Prop, P \/ ~ P) -> (forall P:Prop, {P} + {~ P}). Proof. intros Descr EM P. pose (select := fun b:bool => if b then P else ~P). assert { b:bool | select b } as ([|],HP). + red in Descr. apply Descr. rewrite <- unique_existence; split. destruct (EM P). @@ -815,14 +822,13 @@ Corollary fun_reification_descr_computational_excluded_middle_in_prop_context : (forall P:Prop, P \/ ~ P) -> forall C:Prop, ((forall P:Prop, {P} + {~ P}) -> C) -> C. Proof. - intros FunReify EM C; intuition auto using + intros FunReify EM C H. intuition auto using constructive_definite_descr_excluded_middle, (relative_non_contradiction_of_definite_descr (C:=C)). Qed. (**********************************************************************) (** * Choice => Dependent choice => Countable choice *) - (* The implications below are standard *) Require Import Arith. diff --git a/theories/Logic/Diaconescu.v b/theories/Logic/Diaconescu.v index 87b279877..0eba49a7e 100644 --- a/theories/Logic/Diaconescu.v +++ b/theories/Logic/Diaconescu.v @@ -99,7 +99,7 @@ Lemma AC_bool_subset_to_bool : Proof. destruct (guarded_rel_choice _ _ (fun Q:bool -> Prop => exists y : _, Q y) - (fun (Q:bool -> Prop) (y:bool) => Q y)) as (R,(HRsub,HR)). + (fun (Q:bool -> Prop) (y:bool) => Q y)) as (R,(HRsub,HR)). exact (fun _ H => H). exists R; intros P HP. destruct (HR P HP) as (y,(Hy,Huni)). @@ -172,7 +172,7 @@ Variables a1 a2 : A. (** We build the subset [A'] of [A] made of [a1] and [a2] *) -Definition A' := sigT (fun x => x=a1 \/ x=a2). +Definition A' := @sigT A (fun x => x=a1 \/ x=a2). Definition a1':A'. exists a1 ; auto. diff --git a/theories/Logic/EqdepFacts.v b/theories/Logic/EqdepFacts.v index 0e9f39f6b..2c971ec24 100644 --- a/theories/Logic/EqdepFacts.v +++ b/theories/Logic/EqdepFacts.v @@ -52,6 +52,8 @@ Table of contents: Import EqNotations. +Set Universe Polymorphism. + Section Dependent_Equality. Variable U : Type. @@ -117,7 +119,7 @@ Lemma eq_sigT_eq_dep : existT P p x = existT P q y -> eq_dep p x q y. Proof. intros. - dependent rewrite H. + dependent rewrite H. apply eq_dep_intro. Qed. @@ -162,11 +164,12 @@ Proof. split; auto using eq_sig_eq_dep, eq_dep_eq_sig. Qed. -(** Dependent equality is equivalent to a dependent pair of equalities *) +(** Dependent equality is equivalent tco a dependent pair of equalities *) Set Implicit Arguments. -Lemma eq_sigT_sig_eq : forall X P (x1 x2:X) H1 H2, existT P x1 H1 = existT P x2 H2 <-> {H:x1=x2 | rew H in H1 = H2}. +Lemma eq_sigT_sig_eq : forall X P (x1 x2:X) H1 H2, existT P x1 H1 = existT P x2 H2 <-> + {H:x1=x2 | rew H in H1 = H2}. Proof. intros; split; intro H. - change x2 with (projT1 (existT P x2 H2)). @@ -191,7 +194,7 @@ Lemma eq_sigT_snd : forall X P (x1 x2:X) H1 H2 (H:existT P x1 H1 = existT P x2 H2), rew (eq_sigT_fst H) in H1 = H2. Proof. intros. - unfold eq_sigT_fst. + unfold eq_sigT_fst. change x2 with (projT1 (existT P x2 H2)). change H2 with (projT2 (existT P x2 H2)) at 3. destruct H. @@ -271,8 +274,8 @@ Section Equivalences. Lemma eq_rect_eq__eq_dep_eq : Eq_rect_eq -> Eq_dep_eq. Proof. intros eq_rect_eq; red; intros. - apply (eq_rect_eq__eq_dep1_eq eq_rect_eq); apply eq_dep_dep1; trivial. - Qed. + apply (eq_rect_eq__eq_dep1_eq eq_rect_eq). apply eq_dep_dep1; trivial. + Qed. (** Uniqueness of Identity Proofs (UIP) is a consequence of *) (** Injectivity of Dependent Equality *) diff --git a/theories/Logic/Eqdep_dec.v b/theories/Logic/Eqdep_dec.v index 53b25d4a8..e4db81faf 100644 --- a/theories/Logic/Eqdep_dec.v +++ b/theories/Logic/Eqdep_dec.v @@ -35,6 +35,7 @@ Table of contents: (** * Streicher's K and injectivity of dependent pair hold on decidable types *) Set Implicit Arguments. +Set Universe Polymorphism. Section EqdepDec. @@ -203,7 +204,7 @@ Unset Implicit Arguments. Module Type DecidableType. - Parameter U:Type. + Monomorphic Parameter U:Type. Axiom eq_dec : forall x y:U, {x = y} + {x <> y}. End DecidableType. @@ -271,7 +272,7 @@ End DecidableEqDep. Module Type DecidableSet. - Parameter U:Type. + Parameter U:Set. Axiom eq_dec : forall x y:U, {x = y} + {x <> y}. End DecidableSet. @@ -294,23 +295,23 @@ Module DecidableEqDepSet (M:DecidableSet). Theorem eq_dep_eq : forall (P:U->Type) (p:U) (x y:P p), eq_dep U P p x p y -> x = y. - Proof N.eq_dep_eq. + Proof (eq_rect_eq__eq_dep_eq U eq_rect_eq). (** Uniqueness of Identity Proofs (UIP) *) Lemma UIP : forall (x y:U) (p1 p2:x = y), p1 = p2. - Proof N.UIP. + Proof (eq_dep_eq__UIP U eq_dep_eq). (** Uniqueness of Reflexive Identity Proofs *) Lemma UIP_refl : forall (x:U) (p:x = x), p = eq_refl x. - Proof N.UIP_refl. + Proof (UIP__UIP_refl U UIP). (** Streicher's axiom K *) Lemma Streicher_K : forall (x:U) (P:x = x -> Prop), P (eq_refl x) -> forall p:x = x, P p. - Proof N.Streicher_K. + Proof (K_dec_type eq_dec). (** Proof-irrelevance on subsets of decidable sets *) @@ -350,7 +351,7 @@ Qed. Lemma UIP_refl_unit (x : tt = tt) : x = eq_refl tt. Proof. - change (match tt as b return tt = b -> Type with + change (match tt as b return tt = b -> Prop with | tt => fun x => x = eq_refl tt end x). destruct x; reflexivity. diff --git a/theories/Logic/JMeq.v b/theories/Logic/JMeq.v index 530e05559..b557a7867 100644 --- a/theories/Logic/JMeq.v +++ b/theories/Logic/JMeq.v @@ -28,9 +28,11 @@ Arguments JMeq_refl {A x} , [A] x. Hint Resolve JMeq_refl. +Definition JMeq_hom {A : Type} (x y : A) := JMeq x y. + Lemma JMeq_sym : forall (A B:Type) (x:A) (y:B), JMeq x y -> JMeq y x. -Proof. -destruct 1; trivial. +Proof. +intros; destruct H; trivial. Qed. Hint Immediate JMeq_sym. diff --git a/theories/MSets/MSetEqProperties.v b/theories/MSets/MSetEqProperties.v index 4f0d93fb9..843b9aaa7 100644 --- a/theories/MSets/MSetEqProperties.v +++ b/theories/MSets/MSetEqProperties.v @@ -856,7 +856,7 @@ intros. rewrite <- (fold_equal _ _ _ _ fc ft 0 _ _ H). rewrite <- (fold_equal _ _ _ _ gc gt 0 _ _ H). rewrite <- (fold_equal _ _ _ _ fgc fgt 0 _ _ H); auto. -intros; do 3 (rewrite fold_add; auto with *). +intros. do 3 (rewrite fold_add; auto with *). do 3 rewrite fold_empty;auto. Qed. diff --git a/theories/MSets/MSetInterface.v b/theories/MSets/MSetInterface.v index bd8811689..a61ef8bcd 100644 --- a/theories/MSets/MSetInterface.v +++ b/theories/MSets/MSetInterface.v @@ -595,7 +595,7 @@ Module Raw2SetsOn (O:OrderedType)(M:RawSets O) <: SetsOn O. (** Specification of [lt] *) Instance lt_strorder : StrictOrder lt. Proof. constructor ; unfold lt; red. - unfold complement. red. intros. apply (irreflexivity H). + unfold complement. red. intros. apply (irreflexivity _ H). intros. transitivity y; auto. Qed. diff --git a/theories/MSets/MSetList.v b/theories/MSets/MSetList.v index b0e09b719..5c232f340 100644 --- a/theories/MSets/MSetList.v +++ b/theories/MSets/MSetList.v @@ -472,7 +472,7 @@ Module MakeRaw (X: OrderedType) <: RawSets X. equal s s' = true <-> Equal s s'. Proof. induction s as [ | x s IH]; intros [ | x' s'] Hs Hs'; simpl. - intuition. + intuition reflexivity. split; intros H. discriminate. assert (In x' nil) by (rewrite H; auto). inv. split; intros H. discriminate. assert (In x nil) by (rewrite <-H; auto). inv. inv. @@ -820,7 +820,7 @@ Module MakeRaw (X: OrderedType) <: RawSets X. Lemma compare_spec_aux : forall s s', CompSpec eq L.lt s s' (compare s s'). Proof. - induction s as [|x s IH]; intros [|x' s']; simpl; intuition. + induction s as [|x s IH]; intros [|x' s']; simpl; intuition. elim_compare x x'; auto. Qed. diff --git a/theories/MSets/MSetPositive.v b/theories/MSets/MSetPositive.v index f3a1d39c9..25a8c1629 100644 --- a/theories/MSets/MSetPositive.v +++ b/theories/MSets/MSetPositive.v @@ -93,7 +93,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. Module E:=PositiveOrderedTypeBits. - Definition elt := positive. + Definition elt := positive : Type. Inductive tree := | Leaf : tree @@ -101,9 +101,9 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. Scheme tree_ind := Induction for tree Sort Prop. - Definition t := tree. + Definition t := tree : Type. - Definition empty := Leaf. + Definition empty : t := Leaf. Fixpoint is_empty (m : t) : bool := match m with @@ -142,7 +142,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. (** helper function to avoid creating empty trees that are not leaves *) - Definition node l (b: bool) r := + Definition node (l : t) (b: bool) (r : t) : t := if b then Node l b r else match l,r with | Leaf,Leaf => Leaf @@ -159,7 +159,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. end end. - Fixpoint union (m m': t) := + Fixpoint union (m m': t) : t := match m with | Leaf => m' | Node l o r => @@ -169,7 +169,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. end end. - Fixpoint inter (m m': t) := + Fixpoint inter (m m': t) : t := match m with | Leaf => Leaf | Node l o r => @@ -179,7 +179,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. end end. - Fixpoint diff (m m': t) := + Fixpoint diff (m m': t) : t := match m with | Leaf => Leaf | Node l o r => @@ -211,7 +211,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. (** reverses [y] and concatenate it with [x] *) - Fixpoint rev_append y x := + Fixpoint rev_append (y x : elt) : elt := match y with | 1 => x | y~1 => rev_append y x~1 @@ -262,14 +262,14 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. end. Definition exists_ m := xexists m 1. - Fixpoint xfilter (m : t) (i : positive) := + Fixpoint xfilter (m : t) (i : positive) : t := match m with | Leaf => Leaf | Node l o r => node (xfilter l i~0) (o &&& f (rev i)) (xfilter r i~1) end. Definition filter m := xfilter m 1. - Fixpoint xpartition (m : t) (i : positive) := + Fixpoint xpartition (m : t) (i : positive) : t * t := match m with | Leaf => (Leaf,Leaf) | Node l o r => @@ -311,7 +311,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. (** would it be more efficient to use a path like in the above functions ? *) - Fixpoint choose (m: t) := + Fixpoint choose (m: t) : option elt := match m with | Leaf => None | Node l o r => if o then Some 1 else @@ -321,7 +321,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. end end. - Fixpoint min_elt (m: t) := + Fixpoint min_elt (m: t) : option elt := match m with | Leaf => None | Node l o r => @@ -331,7 +331,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. end end. - Fixpoint max_elt (m: t) := + Fixpoint max_elt (m: t) : option elt := match m with | Leaf => None | Node l o r => @@ -805,7 +805,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. rewrite <- andb_lazy_alt. apply andb_true_iff. Qed. - Lemma filter_spec: forall s x f, compat_bool E.eq f -> + Lemma filter_spec: forall s x f, @compat_bool elt E.eq f -> (In x (filter f s) <-> In x s /\ f x = true). Proof. intros. apply xfilter_spec. Qed. @@ -830,7 +830,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. apply H. assumption. Qed. - Lemma for_all_spec: forall s f, compat_bool E.eq f -> + Lemma for_all_spec: forall s f, @compat_bool elt E.eq f -> (for_all f s = true <-> For_all (fun x => f x = true) s). Proof. intros. apply xforall_spec. Qed. @@ -852,7 +852,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. intros [[x|x|] H]; eauto. Qed. - Lemma exists_spec : forall s f, compat_bool E.eq f -> + Lemma exists_spec : forall s f, @compat_bool elt E.eq f -> (exists_ f s = true <-> Exists (fun x => f x = true) s). Proof. intros. apply xexists_spec. Qed. @@ -868,11 +868,11 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. destruct o; simpl; rewrite IHl, IHr; reflexivity. Qed. - Lemma partition_spec1 : forall s f, compat_bool E.eq f -> + Lemma partition_spec1 : forall s f, @compat_bool elt E.eq f -> Equal (fst (partition f s)) (filter f s). Proof. intros. rewrite partition_filter. reflexivity. Qed. - Lemma partition_spec2 : forall s f, compat_bool E.eq f -> + Lemma partition_spec2 : forall s f, @compat_bool elt E.eq f -> Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). Proof. intros. rewrite partition_filter. reflexivity. Qed. @@ -1079,7 +1079,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. destruct (min_elt r). injection H. intros <-. clear H. destruct y as [z|z|]. - apply (IHr p z); trivial. + apply (IHr e z); trivial. elim (Hp _ H'). discriminate. discriminate. @@ -1133,7 +1133,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. injection H. intros <-. clear H. destruct y as [z|z|]. elim (Hp _ H'). - apply (IHl p z); trivial. + apply (IHl e z); trivial. discriminate. discriminate. Qed. diff --git a/theories/MSets/MSetRBT.v b/theories/MSets/MSetRBT.v index f0cddcc38..d8f675ade 100644 --- a/theories/MSets/MSetRBT.v +++ b/theories/MSets/MSetRBT.v @@ -1047,7 +1047,7 @@ Qed. (** ** Filter *) -Lemma filter_app A f (l l':list A) : +Polymorphic Lemma filter_app A f (l l':list A) : List.filter f (l ++ l') = List.filter f l ++ List.filter f l'. Proof. induction l as [|x l IH]; simpl; trivial. @@ -1196,7 +1196,7 @@ Lemma INV_rev l1 l2 acc : Proof. intros. rewrite rev_append_rev. apply SortA_app with X.eq; eauto with *. - intros x y. inA. eapply l1_lt_acc; eauto. + intros x y. inA. eapply @l1_lt_acc; eauto. Qed. (** ** union *) diff --git a/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v b/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v index 39e086c31..17c69d226 100644 --- a/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v +++ b/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v @@ -93,7 +93,7 @@ Module ZnZ. lor : t -> t -> t; land : t -> t -> t; lxor : t -> t -> t }. - + Section Specs. Context {t : Type}{ops : Ops t}. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v index 809169a4d..a6bc44682 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v @@ -809,7 +809,7 @@ refine refine (@spec_ww_sqrt t w_is_even w_0 w_1 w_Bm1 w_sub w_add_mul_div w_digits w_zdigits _ww_zdigits w_sqrt2 pred add_mul_div head0 compare - _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _); wwauto. + _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _); wwauto. exact ZnZ.spec_zdigits. exact ZnZ.spec_more_than_1_digit. exact ZnZ.spec_is_even. @@ -846,7 +846,7 @@ refine intros (Hn,Hn'). assert (E : ZnZ.to_Z y = [|WW x y|] mod wB). { simpl; symmetry. - rewrite Z.add_comm, Z.mod_add; auto with zarith. + rewrite Z.add_comm, Z.mod_add; auto with zarith nocore. apply Z.mod_small; eauto with ZnZ zarith. } rewrite E. unfold wB, base. symmetry. apply Z.mod_pow2_bits_low; auto. @@ -923,6 +923,7 @@ refine End Z_2nZ. + Section MulAdd. Context {t : Type}{ops : ZnZ.Ops t}{specs : ZnZ.Specs ops}. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v index 8525b0e13..dddae7db5 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v @@ -211,8 +211,7 @@ Section DoubleDiv32. Variable w_div21 : w -> w -> w -> w*w. Variable ww_sub_c : zn2z w -> zn2z w -> carry (zn2z w). - Definition w_div32 a1 a2 a3 b1 b2 := - Eval lazy beta iota delta [ww_add_c_cont ww_add] in + Definition w_div32_body a1 a2 a3 b1 b2 := match w_compare a1 b1 with | Lt => let (q,r) := w_div21 a1 a2 b1 in @@ -233,6 +232,10 @@ Section DoubleDiv32. | Gt => (w_0, W0) (* cas absurde *) end. + Definition w_div32 a1 a2 a3 b1 b2 := + Eval lazy beta iota delta [ww_add_c_cont ww_add w_div32_body] in + w_div32_body a1 a2 a3 b1 b2. + (* Proof *) Variable w_digits : positive. @@ -312,26 +315,8 @@ Section DoubleDiv32. assert (U:= lt_0_wB w_digits); assert (U1:= lt_0_wwB w_digits). Spec_w_to_Z a1;Spec_w_to_Z a2;Spec_w_to_Z a3;Spec_w_to_Z b1;Spec_w_to_Z b2. rewrite wwB_wBwB; rewrite Z.pow_2_r; rewrite Z.mul_assoc;rewrite <- Z.mul_add_distr_r. - change (w_div32 a1 a2 a3 b1 b2) with - match w_compare a1 b1 with - | Lt => - let (q,r) := w_div21 a1 a2 b1 in - match ww_sub_c (w_WW r a3) (w_mul_c q b2) with - | C0 r1 => (q,r1) - | C1 r1 => - let q := w_pred q in - ww_add_c_cont w_WW w_add_c w_add_carry_c - (fun r2=>(w_pred q, ww_add w_add_c w_add w_add_carry r2 (WW b1 b2))) - (fun r2 => (q,r2)) - r1 (WW b1 b2) - end - | Eq => - ww_add_c_cont w_WW w_add_c w_add_carry_c - (fun r => (w_Bm2, ww_add w_add_c w_add w_add_carry r (WW b1 b2))) - (fun r => (w_Bm1,r)) - (WW (w_sub a2 b2) a3) (WW b1 b2) - | Gt => (w_0, W0) (* cas absurde *) - end. + change (w_div32 a1 a2 a3 b1 b2) with (w_div32_body a1 a2 a3 b1 b2). + unfold w_div32_body. rewrite spec_compare. case Z.compare_spec; intro Hcmp. simpl in Hlt. rewrite Hcmp in Hlt;assert ([|a2|] < [|b2|]). omega. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v index df5d42bbc..789436334 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v @@ -692,7 +692,7 @@ intros x; case x; simpl ww_is_even. intros x y H; unfold ww_sqrt2. repeat match goal with |- context[split ?x] => generalize (spec_split x); case (split x) - end; simpl fst; simpl snd. + end; simpl @fst; simpl @snd. intros w0 w1 Hw0 w2 w3 Hw1. assert (U: wB/4 <= [|w2|]). case (Z.le_gt_cases (wB / 4) [|w2|]); auto; intros H1. @@ -1193,7 +1193,7 @@ Qed. rewrite <- wwB_4_wB_4; auto. generalize (@spec_w_sqrt2 w0 w1 V);auto with zarith. case (w_sqrt2 w0 w1); intros w2 c. - simpl ww_to_Z; simpl fst. + simpl ww_to_Z; simpl @fst. case c; unfold interp_carry; autorewrite with rm10. intros w3 (H6, H7); rewrite H6. assert (V1 := spec_to_Z w3);auto with zarith. @@ -1256,7 +1256,7 @@ Qed. generalize (@spec_w_sqrt2 w0 w1 V);auto with zarith. case (w_sqrt2 w0 w1); intros w2 c. case (spec_to_Z w2); intros HH1 HH2. - simpl ww_to_Z; simpl fst. + simpl ww_to_Z; simpl @fst. assert (Hv3: [[ww_pred ww_zdigits]] = Zpos (xO w_digits) - 1). rewrite spec_ww_pred; rewrite spec_ww_zdigits. diff --git a/theories/Numbers/Cyclic/Int31/Cyclic31.v b/theories/Numbers/Cyclic/Int31/Cyclic31.v index 03fc58c55..634ff7d63 100644 --- a/theories/Numbers/Cyclic/Int31/Cyclic31.v +++ b/theories/Numbers/Cyclic/Int31/Cyclic31.v @@ -623,7 +623,7 @@ Section Basics. rewrite i2l_length; omega. generalize (firstn_length (size-n) (i2l x)). rewrite i2l_length. - intros H0 H1; rewrite H1 in H0. + intros H0 H1. rewrite H1 in H0. rewrite min_l in H0 by omega. simpl length in H0. omega. @@ -882,16 +882,16 @@ Section Basics. destruct p; simpl snd. specialize IHn with p. - destruct (p2ibis n p). simpl snd in *. -rewrite nshiftr_S_tail. + destruct (p2ibis n p). simpl @snd in *. + rewrite nshiftr_S_tail. destruct (le_lt_dec size n). rewrite nshiftr_above_size; auto. assert (H:=nshiftr_0_firstl _ _ l IHn). replace (shiftr (twice_plus_one i)) with i; auto. - destruct i; simpl in *; rewrite H; auto. + destruct i; simpl in *. rewrite H; auto. specialize IHn with p. - destruct (p2ibis n p); simpl snd in *. + destruct (p2ibis n p); simpl @snd in *. rewrite nshiftr_S_tail. destruct (le_lt_dec size n). rewrite nshiftr_above_size; auto. @@ -945,7 +945,7 @@ rewrite nshiftr_S_tail. intros. simpl p2ibis; destruct p; [ | | red; auto]; specialize IHn with p; - destruct (p2ibis n p); simpl snd in *; simpl phi_inv_positive; + destruct (p2ibis n p); simpl @snd in *; simpl phi_inv_positive; rewrite ?EqShiftL_twice_plus_one, ?EqShiftL_twice; replace (S (size - S n))%nat with (size - n)%nat by omega; apply IHn; omega. @@ -1629,7 +1629,7 @@ Section Int31_Specs. Lemma spec_pos_mod : forall w p, [|ZnZ.pos_mod p w|] = [|w|] mod (2 ^ [|p|]). Proof. - unfold ZnZ.pos_mod, int31_ops, compare31. + unfold int31_ops, ZnZ.pos_mod, compare31. change [|31|] with 31%Z. assert (forall w p, 31<=p -> [|w|] = [|w|] mod 2^p). intros. @@ -1959,7 +1959,7 @@ Section Int31_Specs. Lemma div31_phi i j: 0 < [|j|] -> [|fst (i/j)%int31|] = [|i|]/[|j|]. intros Hj; generalize (spec_div i j Hj). - case div31; intros q r; simpl fst. + case div31; intros q r; simpl @fst. intros (H1,H2); apply Zdiv_unique with [|r|]; auto with zarith. rewrite H1; ring. Qed. @@ -2094,7 +2094,7 @@ Section Int31_Specs. generalize (spec_div21 ih il j Hj Hj1). case div3121; intros q r (Hq, Hr). apply Zdiv_unique with (phi r); auto with zarith. - simpl fst; apply eq_trans with (1 := Hq); ring. + simpl @fst; apply eq_trans with (1 := Hq); ring. Qed. Lemma sqrt312_step_correct rec ih il j: @@ -2215,6 +2215,9 @@ Section Int31_Specs. apply Nat2Z.is_nonneg. Qed. + (* Avoid expanding [iter312_sqrt] before variables in the context. *) + Strategy 1 [iter312_sqrt]. + Lemma spec_sqrt2 : forall x y, wB/ 4 <= [|x|] -> let (s,r) := sqrt312 x y in diff --git a/theories/Numbers/NatInt/NZParity.v b/theories/Numbers/NatInt/NZParity.v index 0e9323789..1e6593b10 100644 --- a/theories/Numbers/NatInt/NZParity.v +++ b/theories/Numbers/NatInt/NZParity.v @@ -95,7 +95,7 @@ Proof. intros. generalize (Even_or_Odd n) (Even_Odd_False n). rewrite <- even_spec, <- odd_spec. - destruct (odd n), (even n); simpl; intuition. + destruct (odd n), (even n) ; simpl; intuition. Qed. Lemma negb_even : forall n, negb (even n) = odd n. diff --git a/theories/Numbers/NatInt/NZSqrt.v b/theories/Numbers/NatInt/NZSqrt.v index 8146fd014..6b6c85310 100644 --- a/theories/Numbers/NatInt/NZSqrt.v +++ b/theories/Numbers/NatInt/NZSqrt.v @@ -438,7 +438,7 @@ Instance sqrt_up_wd : Proper (eq==>eq) sqrt_up. Proof. assert (Proper (eq==>eq==>Logic.eq) compare). intros x x' Hx y y' Hy. do 2 case compare_spec; trivial; order. - intros x x' Hx. unfold sqrt_up. rewrite Hx. case compare; now rewrite ?Hx. + intros x x' Hx; unfold sqrt_up; rewrite Hx; case compare; now rewrite ?Hx. Qed. (** The spec of [sqrt_up] indeed determines it *) diff --git a/theories/Numbers/Natural/Abstract/NDefOps.v b/theories/Numbers/Natural/Abstract/NDefOps.v index 621a2ed9c..adbbc5ea0 100644 --- a/theories/Numbers/Natural/Abstract/NDefOps.v +++ b/theories/Numbers/Natural/Abstract/NDefOps.v @@ -133,7 +133,6 @@ Proof. intros m n; unfold ltb at 1. f_equiv. rewrite recursion_succ; f_equiv'. -reflexivity. Qed. (* Above, we rewrite applications of function. Is it possible to rewrite diff --git a/theories/Numbers/Natural/Abstract/NStrongRec.v b/theories/Numbers/Natural/Abstract/NStrongRec.v index 67cab5507..f98e8da9a 100644 --- a/theories/Numbers/Natural/Abstract/NStrongRec.v +++ b/theories/Numbers/Natural/Abstract/NStrongRec.v @@ -13,7 +13,7 @@ and proves its properties *) Require Export NSub. -Ltac f_equiv' := repeat (f_equiv; try intros ? ? ?; auto). +Ltac f_equiv' := repeat (repeat f_equiv; try intros ? ? ?; auto). Module NStrongRecProp (Import N : NAxiomsRecSig'). Include NSubProp N. @@ -82,7 +82,6 @@ Proof. intros. unfold strong_rec0. f_equiv. rewrite recursion_succ; f_equiv'. -reflexivity. Qed. Lemma strong_rec_0 : forall a, diff --git a/theories/Numbers/Natural/BigN/NMake.v b/theories/Numbers/Natural/BigN/NMake.v index 93ae858d8..bfbcb9465 100644 --- a/theories/Numbers/Natural/BigN/NMake.v +++ b/theories/Numbers/Natural/BigN/NMake.v @@ -242,8 +242,8 @@ Module Make (W0:CyclicType) <: NType. Definition comparen_m n : forall m, word (dom_t n) (S m) -> dom_t n -> comparison := let op := dom_op n in - let zero := @ZnZ.zero _ op in - let compare := @ZnZ.compare _ op in + let zero := ZnZ.zero (Ops:=op) in + let compare := ZnZ.compare (Ops:=op) in let compare0 := compare zero in fun m => compare_mn_1 (dom_t n) (dom_t n) zero compare compare0 compare (S m). @@ -273,7 +273,7 @@ Module Make (W0:CyclicType) <: NType. Local Notation compare_folded := (iter_sym _ - (fun n => @ZnZ.compare _ (dom_op n)) + (fun n => ZnZ.compare (Ops:=dom_op n)) comparen_m comparenm CompOpp). @@ -358,13 +358,13 @@ Module Make (W0:CyclicType) <: NType. Definition wn_mul n : forall m, word (dom_t n) (S m) -> dom_t n -> t := let op := dom_op n in - let zero := @ZnZ.zero _ op in - let succ := @ZnZ.succ _ op in - let add_c := @ZnZ.add_c _ op in - let mul_c := @ZnZ.mul_c _ op in + let zero := ZnZ.zero in + let succ := ZnZ.succ (Ops:=op) in + let add_c := ZnZ.add_c (Ops:=op) in + let mul_c := ZnZ.mul_c (Ops:=op) in let ww := @ZnZ.WW _ op in let ow := @ZnZ.OW _ op in - let eq0 := @ZnZ.eq0 _ op in + let eq0 := ZnZ.eq0 in let mul_add := @DoubleMul.w_mul_add _ zero succ add_c mul_c in let mul_add_n1 := @DoubleMul.double_mul_add_n1 _ zero ww ow mul_add in fun m x y => @@ -464,13 +464,13 @@ Module Make (W0:CyclicType) <: NType. Definition wn_divn1 n := let op := dom_op n in let zd := ZnZ.zdigits op in - let zero := @ZnZ.zero _ op in - let ww := @ZnZ.WW _ op in - let head0 := @ZnZ.head0 _ op in - let add_mul_div := @ZnZ.add_mul_div _ op in - let div21 := @ZnZ.div21 _ op in - let compare := @ZnZ.compare _ op in - let sub := @ZnZ.sub _ op in + let zero := ZnZ.zero in + let ww := ZnZ.WW in + let head0 := ZnZ.head0 in + let add_mul_div := ZnZ.add_mul_div in + let div21 := ZnZ.div21 in + let compare := ZnZ.compare in + let sub := ZnZ.sub in let ddivn1 := DoubleDivn1.double_divn1 zd zero ww head0 add_mul_div div21 compare sub in fun m x y => let (u,v) := ddivn1 (S m) x y in (mk_t_w' n m u, mk_t n v). @@ -633,12 +633,12 @@ Module Make (W0:CyclicType) <: NType. Definition wn_modn1 n := let op := dom_op n in let zd := ZnZ.zdigits op in - let zero := @ZnZ.zero _ op in - let head0 := @ZnZ.head0 _ op in - let add_mul_div := @ZnZ.add_mul_div _ op in - let div21 := @ZnZ.div21 _ op in - let compare := @ZnZ.compare _ op in - let sub := @ZnZ.sub _ op in + let zero := ZnZ.zero in + let head0 := ZnZ.head0 in + let add_mul_div := ZnZ.add_mul_div in + let div21 := ZnZ.div21 in + let compare := ZnZ.compare in + let sub := ZnZ.sub in let dmodn1 := DoubleDivn1.double_modn1 zd zero head0 add_mul_div div21 compare sub in fun m x y => reduce n (dmodn1 (S m) x y). diff --git a/theories/Numbers/Natural/BigN/NMake_gen.ml b/theories/Numbers/Natural/BigN/NMake_gen.ml index b28ce15b9..8df4b7c64 100644 --- a/theories/Numbers/Natural/BigN/NMake_gen.ml +++ b/theories/Numbers/Natural/BigN/NMake_gen.ml @@ -324,8 +324,13 @@ pr " Lemma spec_zeron : forall n, ZnZ.to_Z (zeron n) = 0%%Z. Proof. - do_size (destruct n; [exact ZnZ.spec_0|]). - destruct n; auto. simpl. rewrite make_op_S. exact ZnZ.spec_0. + do_size (destruct n; + [match goal with + |- @eq Z (_ (zeron ?n)) _ => + apply (ZnZ.spec_0 (Specs:=dom_spec n)) + end|]). + destruct n; auto. simpl. rewrite make_op_S. fold word. + apply (ZnZ.spec_0 (Specs:=wn_spec (SizePlus 0))). Qed. (** * Digits *) diff --git a/theories/Numbers/Rational/BigQ/QMake.v b/theories/Numbers/Rational/BigQ/QMake.v index 167be6d70..d9f4b0429 100644 --- a/theories/Numbers/Rational/BigQ/QMake.v +++ b/theories/Numbers/Rational/BigQ/QMake.v @@ -627,7 +627,7 @@ Module Make (NN:NType)(ZZ:ZType)(Import NZ:NType_ZType NN ZZ) <: QType. assert (Hz := spec_irred_zero nx dy). assert (Hz':= spec_irred_zero ny dx). destruct irred as (n1,d1); destruct irred as (n2,d2). - simpl snd in *; destruct Hg as [Hg1 Hg2]; destruct Hg' as [Hg1' Hg2']. + simpl @snd in *; destruct Hg as [Hg1 Hg2]; destruct Hg' as [Hg1' Hg2']. rewrite spec_norm_denum. qsimpl. @@ -665,7 +665,7 @@ Module Make (NN:NType)(ZZ:ZType)(Import NZ:NType_ZType NN ZZ) <: QType. assert (Hgc := strong_spec_irred nx dy). assert (Hgc' := strong_spec_irred ny dx). destruct irred as (n1,d1); destruct irred as (n2,d2). - simpl snd in *; destruct Hg as [Hg1 Hg2]; destruct Hg' as [Hg1' Hg2']. + simpl @snd in *; destruct Hg as [Hg1 Hg2]; destruct Hg' as [Hg1' Hg2']. unfold norm_denum; qsimpl. diff --git a/theories/PArith/BinPosDef.v b/theories/PArith/BinPosDef.v index aed4fef05..22f3dcd64 100644 --- a/theories/PArith/BinPosDef.v +++ b/theories/PArith/BinPosDef.v @@ -375,7 +375,7 @@ Fixpoint gcdn (n : nat) (a b : positive) : positive := Definition gcd (a b : positive) := gcdn (size_nat a + size_nat b)%nat a b. (** Generalized Gcd, also computing the division of a and b by the gcd *) - +Set Printing Universes. Fixpoint ggcdn (n : nat) (a b : positive) : (positive*(positive*positive)) := match n with | O => (1,(a,b)) diff --git a/theories/Program/Basics.v b/theories/Program/Basics.v index 22436de69..ab1eccee2 100644 --- a/theories/Program/Basics.v +++ b/theories/Program/Basics.v @@ -15,6 +15,8 @@ Institution: LRI, CNRS UMR 8623 - University Paris Sud *) +Set Universe Polymorphism. + (** The polymorphic identity function is defined in [Datatypes]. *) Arguments id {A} x. @@ -45,7 +47,7 @@ Definition const {A B} (a : A) := fun _ : B => a. (** The [flip] combinator reverses the first two arguments of a function. *) -Definition flip {A B C} (f : A -> B -> C) x y := f y x. +Monomorphic Definition flip {A B C} (f : A -> B -> C) x y := f y x. (** Application as a combinator. *) diff --git a/theories/Program/Equality.v b/theories/Program/Equality.v index 323e80cc3..96345e154 100644 --- a/theories/Program/Equality.v +++ b/theories/Program/Equality.v @@ -263,7 +263,7 @@ Class DependentEliminationPackage (A : Type) := Ltac elim_tac tac p := let ty := type of p in - let eliminator := eval simpl in (elim (A:=ty)) in + let eliminator := eval simpl in (@elim (_ : DependentEliminationPackage ty)) in tac p eliminator. (** Specialization to do case analysis or induction. diff --git a/theories/Program/Wf.v b/theories/Program/Wf.v index f6d795b94..d82fa602a 100644 --- a/theories/Program/Wf.v +++ b/theories/Program/Wf.v @@ -153,7 +153,7 @@ Section Fix_rects. Hypothesis equiv_lowers: forall x0 (g h: forall x: {y: A | R y x0}, P (proj1_sig x)), - (forall x p p', g (exist (fun y: A => R y x0) x p) = h (exist _ x p')) -> + (forall x p p', g (exist (fun y: A => R y x0) x p) = h (exist (*FIXME shouldn't be needed *) (fun y => R y x0) x p')) -> f g = f h. (* From equiv_lowers, it follows that @@ -231,10 +231,10 @@ Module WfExtensionality. Program Lemma fix_sub_eq_ext : forall (A : Type) (R : A -> A -> Prop) (Rwf : well_founded R) (P : A -> Type) - (F_sub : forall x : A, (forall y:{y : A | R y x}, P y) -> P x), + (F_sub : forall x : A, (forall y:{y : A | R y x}, P (` y)) -> P x), forall x : A, Fix_sub A R Rwf P F_sub x = - F_sub x (fun y:{y : A | R y x} => Fix_sub A R Rwf P F_sub y). + F_sub x (fun y:{y : A | R y x} => Fix_sub A R Rwf P F_sub (` y)). Proof. intros ; apply Fix_eq ; auto. intros. diff --git a/theories/QArith/Qcanon.v b/theories/QArith/Qcanon.v index e395e4d03..e777c74d3 100644 --- a/theories/QArith/Qcanon.v +++ b/theories/QArith/Qcanon.v @@ -460,13 +460,13 @@ Proof. induction n; simpl; auto with qarith. rewrite IHn; auto with qarith. Qed. - +Transparent Qred. Lemma Qcpower_0 : forall n, n<>O -> 0^n = 0. Proof. destruct n; simpl. destruct 1; auto. intros. - now apply Qc_is_canon. + now apply Qc_is_canon. Qed. Lemma Qcpower_pos : forall p n, 0 <= p -> 0 <= p^n. diff --git a/theories/QArith/Qreals.v b/theories/QArith/Qreals.v index 4a826f691..f363fd7c2 100644 --- a/theories/QArith/Qreals.v +++ b/theories/QArith/Qreals.v @@ -167,14 +167,13 @@ Qed. Lemma Q2R_inv : forall x : Q, ~ x==0 -> Q2R (/x) = (/ Q2R x)%R. Proof. -unfold Qinv, Q2R, Qeq; intros (x1, x2); unfold Qden, Qnum. -case x1. +unfold Qinv, Q2R, Qeq; intros (x1, x2). case x1; unfold Qnum, Qden. simpl; intros; elim H; trivial. -intros; field; auto. +intros; field; auto. intros; change (IZR (Zneg x2)) with (- IZR (' x2))%R; change (IZR (Zneg p)) with (- IZR (' p))%R; - field; (*auto 8 with real.*) + simpl; field; (*auto 8 with real.*) repeat split; auto; auto with real. Qed. diff --git a/theories/Reals/Ranalysis2.v b/theories/Reals/Ranalysis2.v index 3c15a3053..b2d9c749f 100644 --- a/theories/Reals/Ranalysis2.v +++ b/theories/Reals/Ranalysis2.v @@ -442,7 +442,7 @@ Proof. apply (Rabs_pos_lt _ H0). ring. assert (H6 := Req_dec x0 (x0 + h)); elim H6; intro. - intro; rewrite <- H7; unfold dist, R_met; unfold R_dist; + intro; rewrite <- H7. unfold R_met, dist; unfold R_dist; unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0; apply Rabs_pos_lt. unfold Rdiv; apply prod_neq_R0; diff --git a/theories/Reals/Ranalysis5.v b/theories/Reals/Ranalysis5.v index d876b5d8e..0614f3998 100644 --- a/theories/Reals/Ranalysis5.v +++ b/theories/Reals/Ranalysis5.v @@ -695,7 +695,7 @@ intros f g lb ub x Prf g_cont_pur lb_lt_ub x_encad Prg_incr f_eq_g df_neq. exists deltatemp ; exact Htemp. elim (Hf_deriv eps eps_pos). intros deltatemp Htemp. - red in Hlinv ; red in Hlinv ; simpl dist in Hlinv ; unfold R_dist in Hlinv. + red in Hlinv ; red in Hlinv ; unfold dist in Hlinv ; unfold R_dist in Hlinv. assert (Hlinv' := Hlinv (fun h => (f (y+h) - f y)/h) (fun h => h <>0) l 0). unfold limit1_in, limit_in, dist in Hlinv' ; simpl in Hlinv'. unfold R_dist in Hlinv'. assert (Premisse : (forall eps : R, diff --git a/theories/Reals/Rlimit.v b/theories/Reals/Rlimit.v index 658ffd12f..3d52a98cd 100644 --- a/theories/Reals/Rlimit.v +++ b/theories/Reals/Rlimit.v @@ -164,7 +164,7 @@ Definition limit_in (X X':Metric_Space) (f:Base X -> Base X') eps > 0 -> exists alp : R, alp > 0 /\ - (forall x:Base X, D x /\ dist X x x0 < alp -> dist X' (f x) l < eps). + (forall x:Base X, D x /\ X.(dist) x x0 < alp -> X'.(dist) (f x) l < eps). (*******************************) (** ** R is a metric space *) @@ -191,9 +191,9 @@ Lemma tech_limit : Proof. intros f D l x0 H H0. case (Rabs_pos (f x0 - l)); intros H1. - absurd (dist R_met (f x0) l < dist R_met (f x0) l). + absurd (R_met.(@dist) (f x0) l < R_met.(@dist) (f x0) l). apply Rlt_irrefl. - case (H0 (dist R_met (f x0) l)); auto. + case (H0 (R_met.(@dist) (f x0) l)); auto. intros alpha1 [H2 H3]; apply H3; auto; split; auto. case (dist_refl R_met x0 x0); intros Hr1 Hr2; rewrite Hr2; auto. case (dist_refl R_met (f x0) l); intros Hr1 Hr2; symmetry; auto. @@ -345,8 +345,9 @@ Lemma single_limit : adhDa D x0 -> limit1_in f D l x0 -> limit1_in f D l' x0 -> l = l'. Proof. unfold limit1_in; unfold limit_in; intros. + simpl in *. cut (forall eps:R, eps > 0 -> dist R_met l l' < 2 * eps). - clear H0 H1; unfold dist; unfold R_met; unfold R_dist; + clear H0 H1; simpl @dist; unfold R_met; unfold R_dist, dist; unfold Rabs; case (Rcase_abs (l - l')); intros. cut (forall eps:R, eps > 0 -> - (l - l') < eps). intro; generalize (prop_eps (- (l - l')) H1); intro; @@ -356,7 +357,7 @@ Proof. intros; cut (eps * / 2 > 0). intro; generalize (H0 (eps * / 2) H2); rewrite (Rmult_comm eps (/ 2)); rewrite <- (Rmult_assoc 2 (/ 2) eps); rewrite (Rinv_r 2). - elim (Rmult_ne eps); intros a b; rewrite b; clear a b; trivial. + elim (Rmult_ne eps); intros a b; rewrite b; clear a b; trivial. apply (Rlt_dichotomy_converse 2 0); right; generalize Rlt_0_1; intro; unfold Rgt; generalize (Rplus_lt_compat_l 1 0 1 H3); intro; elim (Rplus_ne 1); intros a b; rewrite a in H4; diff --git a/theories/Reals/Rtopology.v b/theories/Reals/Rtopology.v index f05539379..7e020dd41 100644 --- a/theories/Reals/Rtopology.v +++ b/theories/Reals/Rtopology.v @@ -339,7 +339,7 @@ Proof. unfold neighbourhood in H4; elim H4; intros del H5. exists (pos del); split. apply (cond_pos del). - intros; unfold included in H5; apply H5; elim H6; intros; apply H8. + intros. unfold included in H5; apply H5; elim H6; intros; apply H8. unfold disc; unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0; apply H0. apply disc_P1. diff --git a/theories/Reals/SeqSeries.v b/theories/Reals/SeqSeries.v index 5140c29c1..6ff3fa8b8 100644 --- a/theories/Reals/SeqSeries.v +++ b/theories/Reals/SeqSeries.v @@ -361,7 +361,7 @@ Proof with trivial. replace (sum_f_R0 (fun k:nat => An k * (Bn k - l)) n) with (sum_f_R0 (fun k:nat => An k * Bn k) n + sum_f_R0 (fun k:nat => An k * - l) n)... - rewrite <- (scal_sum An n (- l)); field... + rewrite <- (scal_sum An n (- l)); field... rewrite <- plus_sum; apply sum_eq; intros; ring... Qed. diff --git a/theories/Sets/Cpo.v b/theories/Sets/Cpo.v index 058eec3da..5ab6f3824 100644 --- a/theories/Sets/Cpo.v +++ b/theories/Sets/Cpo.v @@ -32,9 +32,9 @@ Section Bounds. Variable U : Type. Variable D : PO U. - Let C := Carrier_of U D. + Let C := @Carrier_of U D. - Let R := Rel_of U D. + Let R := @Rel_of U D. Inductive Upper_Bound (B:Ensemble U) (x:U) : Prop := Upper_Bound_definition : @@ -103,6 +103,6 @@ Section Specific_orders. Record Chain : Type := Definition_of_chain {PO_of_chain : PO U; - Chain_cond : Totally_ordered U PO_of_chain (Carrier_of U PO_of_chain)}. + Chain_cond : Totally_ordered U PO_of_chain (@Carrier_of _ PO_of_chain)}. End Specific_orders. diff --git a/theories/Sets/Partial_Order.v b/theories/Sets/Partial_Order.v index 054164da5..8d97e3208 100644 --- a/theories/Sets/Partial_Order.v +++ b/theories/Sets/Partial_Order.v @@ -61,7 +61,7 @@ Section Partial_order_facts. Lemma Strict_Rel_Transitive_with_Rel : forall x y z:U, - Strict_Rel_of U D x y -> Rel_of U D y z -> Strict_Rel_of U D x z. + Strict_Rel_of U D x y -> @Rel_of U D y z -> Strict_Rel_of U D x z. Proof. unfold Strict_Rel_of at 1. red. @@ -77,7 +77,7 @@ Section Partial_order_facts. Lemma Strict_Rel_Transitive_with_Rel_left : forall x y z:U, - Rel_of U D x y -> Strict_Rel_of U D y z -> Strict_Rel_of U D x z. + @Rel_of U D x y -> Strict_Rel_of U D y z -> Strict_Rel_of U D x z. Proof. unfold Strict_Rel_of at 1. red. diff --git a/theories/Sorting/Permutation.v b/theories/Sorting/Permutation.v index acad98e5f..899acfc64 100644 --- a/theories/Sorting/Permutation.v +++ b/theories/Sorting/Permutation.v @@ -16,6 +16,7 @@ Require Import List Setoid Compare_dec Morphisms FinFun. Import ListNotations. (* For notations [] and [a;b;c] *) Set Implicit Arguments. +Set Universe Polymorphism. Section Permutation. diff --git a/theories/Sorting/Sorted.v b/theories/Sorting/Sorted.v index 03952c95a..a89b90238 100644 --- a/theories/Sorting/Sorted.v +++ b/theories/Sorting/Sorted.v @@ -20,6 +20,8 @@ Require Import List Relations Relations_1. +Set Universe Polymorphism. + (** Preambule *) Set Implicit Arguments. diff --git a/theories/Structures/DecidableType.v b/theories/Structures/DecidableType.v index 79e817717..f85222dfb 100644 --- a/theories/Structures/DecidableType.v +++ b/theories/Structures/DecidableType.v @@ -80,13 +80,13 @@ Module KeyDecidableType(D:DecidableType). Lemma InA_eqke_eqk : forall x m, InA eqke x m -> InA eqk x m. Proof. - unfold eqke; induction 1; intuition. + unfold eqke; induction 1; intuition. Qed. Hint Resolve InA_eqke_eqk. Lemma InA_eqk : forall p q m, eqk p q -> InA eqk p m -> InA eqk q m. Proof. - intros; apply InA_eqA with p; auto with *. + intros; apply InA_eqA with p; auto with *. Qed. Definition MapsTo (k:key)(e:elt):= InA eqke (k,e). diff --git a/theories/Structures/Equalities.v b/theories/Structures/Equalities.v index eb5373859..747d03f8a 100644 --- a/theories/Structures/Equalities.v +++ b/theories/Structures/Equalities.v @@ -126,14 +126,14 @@ Module Type DecidableTypeFull' := DecidableTypeFull <+ EqNotation. [EqualityType] and [DecidableType] *) Module BackportEq (E:Eq)(F:IsEq E) <: IsEqOrig E. - Definition eq_refl := @Equivalence_Reflexive _ _ F.eq_equiv. - Definition eq_sym := @Equivalence_Symmetric _ _ F.eq_equiv. - Definition eq_trans := @Equivalence_Transitive _ _ F.eq_equiv. + Definition eq_refl := F.eq_equiv.(@Equivalence_Reflexive _ _). + Definition eq_sym := F.eq_equiv.(@Equivalence_Symmetric _ _). + Definition eq_trans := F.eq_equiv.(@Equivalence_Transitive _ _). End BackportEq. Module UpdateEq (E:Eq)(F:IsEqOrig E) <: IsEq E. Instance eq_equiv : Equivalence E.eq. - Proof. exact (Build_Equivalence _ _ F.eq_refl F.eq_sym F.eq_trans). Qed. + Proof. exact (Build_Equivalence _ F.eq_refl F.eq_sym F.eq_trans). Qed. End UpdateEq. Module Backport_ET (E:EqualityType) <: EqualityTypeBoth diff --git a/theories/Structures/GenericMinMax.v b/theories/Structures/GenericMinMax.v index ffd0649af..a0ee4caaa 100644 --- a/theories/Structures/GenericMinMax.v +++ b/theories/Structures/GenericMinMax.v @@ -440,7 +440,7 @@ Qed. Lemma max_min_antimono f : Proper (eq==>eq) f -> - Proper (le==>inverse le) f -> + Proper (le==>flip le) f -> forall x y, max (f x) (f y) == f (min x y). Proof. intros Eqf Lef x y. @@ -452,7 +452,7 @@ Qed. Lemma min_max_antimono f : Proper (eq==>eq) f -> - Proper (le==>inverse le) f -> + Proper (le==>flip le) f -> forall x y, min (f x) (f y) == f (max x y). Proof. intros Eqf Lef x y. @@ -557,11 +557,11 @@ Module UsualMinMaxLogicalProperties forall x y, min (f x) (f y) = f (min x y). Proof. intros; apply min_mono; auto. congruence. Qed. - Lemma min_max_antimonotone f : Proper (le ==> inverse le) f -> + Lemma min_max_antimonotone f : Proper (le ==> flip le) f -> forall x y, min (f x) (f y) = f (max x y). Proof. intros; apply min_max_antimono; auto. congruence. Qed. - Lemma max_min_antimonotone f : Proper (le ==> inverse le) f -> + Lemma max_min_antimonotone f : Proper (le ==> flip le) f -> forall x y, max (f x) (f y) = f (min x y). Proof. intros; apply max_min_antimono; auto. congruence. Qed. diff --git a/theories/Structures/OrderedType.v b/theories/Structures/OrderedType.v index fa08f9366..fb28e0cfc 100644 --- a/theories/Structures/OrderedType.v +++ b/theories/Structures/OrderedType.v @@ -328,7 +328,7 @@ Module KeyOrderedType(O:OrderedType). Proof. split; eauto. Qed. Global Instance ltk_strorder : StrictOrder ltk. - Proof. constructor; eauto. intros x; apply (irreflexivity (x:=fst x)). Qed. + Proof. constructor; eauto. intros x; apply (irreflexivity (fst x)). Qed. Global Instance ltk_compat : Proper (eqk==>eqk==>iff) ltk. Proof. diff --git a/theories/Structures/OrdersFacts.v b/theories/Structures/OrdersFacts.v index 2e9c0cf56..88fbd8c11 100644 --- a/theories/Structures/OrdersFacts.v +++ b/theories/Structures/OrdersFacts.v @@ -31,7 +31,7 @@ Module Type CompareFacts (Import O:DecStrOrder'). Lemma compare_lt_iff x y : (x ?= y) = Lt <-> x<y. Proof. - case compare_spec; intro H; split; try easy; intro LT; + case compare_spec; intro H; split; try easy; intro LT; contradict LT; rewrite H; apply irreflexivity. Qed. @@ -90,7 +90,7 @@ Module Type OrderedTypeFullFacts (Import O:OrderedTypeFull'). Instance le_order : PartialOrder eq le. Proof. compute; iorder. Qed. - Instance le_antisym : Antisymmetric _ eq le. + Instance le_antisym : Antisymmetric eq le. Proof. apply partial_order_antisym; auto with *. Qed. Lemma le_not_gt_iff : forall x y, x<=y <-> ~y<x. diff --git a/theories/Structures/OrdersTac.v b/theories/Structures/OrdersTac.v index 68ffc379d..475a25a41 100644 --- a/theories/Structures/OrdersTac.v +++ b/theories/Structures/OrdersTac.v @@ -29,7 +29,7 @@ Set Implicit Arguments. [le x y -> le y z -> le x z]. *) -Inductive ord := OEQ | OLT | OLE. +Inductive ord : Set := OEQ | OLT | OLE. Definition trans_ord o o' := match o, o' with | OEQ, _ => o' @@ -70,7 +70,7 @@ Lemma le_refl : forall x, x<=x. Proof. intros; rewrite P.le_lteq; right; reflexivity. Qed. Lemma lt_irrefl : forall x, ~ x<x. -Proof. intros; apply StrictOrder_Irreflexive. Qed. +Proof. intros. apply StrictOrder_Irreflexive. Qed. (** Symmetry rules *) @@ -100,8 +100,9 @@ Local Notation "#" := interp_ord. Lemma trans : forall o o' x y z, #o x y -> #o' y z -> #(o+o') x z. Proof. -destruct o, o'; simpl; intros x y z; rewrite ?P.le_lteq; intuition; - subst_eqns; eauto using (StrictOrder_Transitive x y z) with *. +destruct o, o'; simpl; intros x y z; +rewrite ?P.le_lteq; intuition auto; +subst_eqns; eauto using (StrictOrder_Transitive x y z) with *. Qed. Definition eq_trans x y z : x==y -> y==z -> x==z := @trans OEQ OEQ x y z. diff --git a/theories/Vectors/Fin.v b/theories/Vectors/Fin.v index f57726bea..1c4c16cc1 100644 --- a/theories/Vectors/Fin.v +++ b/theories/Vectors/Fin.v @@ -24,7 +24,7 @@ Inductive t : nat -> Set := Section SCHEMES. Definition case0 P (p: t 0): P p := - match p with | F1 | FS _ => fun devil => False_rect (@ID) devil (* subterm !!! *) end. + match p with | F1 | FS _ => fun devil => False_rect (@IDProp) devil (* subterm !!! *) end. Definition caseS (P: forall {n}, t (S n) -> Type) (P1: forall n, @P n F1) (PS : forall {n} (p: t n), P (FS p)) diff --git a/theories/Vectors/VectorDef.v b/theories/Vectors/VectorDef.v index 8f672deda..f12aa0b87 100644 --- a/theories/Vectors/VectorDef.v +++ b/theories/Vectors/VectorDef.v @@ -21,6 +21,8 @@ Require Vectors.Fin. Import EqNotations. Local Open Scope nat_scope. +Set Universe Polymorphism. + (** A vector is a list of size n whose elements belong to a set A. *) @@ -43,10 +45,10 @@ Definition rectS {A} (P:forall {n}, t A (S n) -> Type) |@cons _ a 0 v => match v with |nil _ => bas a - |_ => fun devil => False_rect (@ID) devil (* subterm !!! *) + |_ => fun devil => False_ind (@IDProp) devil (* subterm !!! *) end |@cons _ a (S nn') v => rect a v (rectS_fix v) - |_ => fun devil => False_rect (@ID) devil (* subterm !!! *) + |_ => fun devil => False_ind (@IDProp) devil (* subterm !!! *) end. (** An induction scheme for 2 vectors of same length *) @@ -60,13 +62,13 @@ match v1 as v1' in t _ n1 |[] => fun v2 => match v2 with |[] => bas - |_ => fun devil => False_rect (@ID) devil (* subterm !!! *) + |_ => fun devil => False_ind (@IDProp) devil (* subterm !!! *) end |h1 :: t1 => fun v2 => match v2 with |h2 :: t2 => fun t1' => rect (rect2_fix t1' t2) h1 h2 - |_ => fun devil => False_rect (@ID) devil (* subterm !!! *) + |_ => fun devil => False_ind (@IDProp) devil (* subterm !!! *) end t1 end. @@ -74,7 +76,7 @@ end. Definition case0 {A} (P:t A 0 -> Type) (H:P (nil A)) v:P v := match v with |[] => H - |_ => fun devil => False_rect (@ID) devil (* subterm !!! *) + |_ => fun devil => False_ind (@IDProp) devil (* subterm !!! *) end. (** A vector of length [S _] is [cons] *) @@ -82,7 +84,7 @@ Definition caseS {A} (P : forall {n}, t A (S n) -> Type) (H : forall h {n} t, @P n (h :: t)) {n} (v: t A (S n)) : P v := match v with |h :: t => H h t - |_ => fun devil => False_rect (@ID) devil (* subterm !!! *) + |_ => fun devil => False_ind (@IDProp) devil (* subterm !!! *) end. End SCHEMES. @@ -245,11 +247,11 @@ fix fold_left2_fix (a : A) {n} (v : t B n) : t C n -> A := match v in t _ n0 return t C n0 -> A with |[] => fun w => match w with |[] => a - |_ => fun devil => False_rect (@ID) devil (* subterm !!! *) + |_ => fun devil => False_ind (@IDProp) devil (* subterm !!! *) end |@cons _ vh vn vt => fun w => match w with |wh :: wt => fun vt' => fold_left2_fix (f a vh wh) vt' wt - |_ => fun devil => False_rect (@ID) devil (* subterm !!! *) + |_ => fun devil => False_ind (@IDProp) devil (* subterm !!! *) end vt end. diff --git a/theories/Vectors/VectorSpec.v b/theories/Vectors/VectorSpec.v index ed2b56d1f..3e8c1175f 100644 --- a/theories/Vectors/VectorSpec.v +++ b/theories/Vectors/VectorSpec.v @@ -105,7 +105,7 @@ Proof. assert (forall n h (v: t B n) a, fold_left f (f a h) v = f (fold_left f a v) h). induction v0. now simpl. - intros; simpl. rewrite<- IHv0. now f_equal. + intros; simpl. rewrite<- IHv0, assoc. now f_equal. induction v. reflexivity. simpl. intros; now rewrite<- (IHv). diff --git a/theories/Wellfounded/Lexicographic_Exponentiation.v b/theories/Wellfounded/Lexicographic_Exponentiation.v index 24f5d308a..28288c0cb 100644 --- a/theories/Wellfounded/Lexicographic_Exponentiation.v +++ b/theories/Wellfounded/Lexicographic_Exponentiation.v @@ -130,7 +130,7 @@ Section Wf_Lexicographic_Exponentiation. match goal with [ |- clos_refl_trans ?A ?R ?x ?y ] => cut (clos_refl A R x y) end. intros; inversion H8; subst; [apply rt_step|apply rt_refl]; assumption. generalize H1. - rewrite H4; intro. + setoid_rewrite H4; intro. generalize (app_inj_tail _ _ _ _ H8); simple induction 1. intros. @@ -182,7 +182,8 @@ Section Wf_Lexicographic_Exponentiation. Descl x0 /\ Descl y0). intro. - generalize (app_nil_end x1); simple induction 1; simple induction 1. + generalize (app_nil_end x1). + simple induction 1; simple induction 1. split. apply d_conc; auto with sets. apply d_nil. diff --git a/theories/ZArith/Wf_Z.v b/theories/ZArith/Wf_Z.v index 3935e1248..f1bfb027f 100644 --- a/theories/ZArith/Wf_Z.v +++ b/theories/ZArith/Wf_Z.v @@ -151,9 +151,7 @@ Section Efficient_Rec. forall P:Z -> Prop, (forall x:Z, (forall y:Z, 0 <= y < x -> P y) -> 0 <= x -> P x) -> forall x:Z, 0 <= x -> P x. - Proof. - exact Zlt_0_rec. - Qed. + Proof. intros; now apply Zlt_0_rec. Qed. (** Obsolete version of [Z.lt] induction principle on non-negative numbers *) @@ -170,7 +168,7 @@ Section Efficient_Rec. (forall x:Z, (forall y:Z, 0 <= y < x -> P y) -> P x) -> forall x:Z, 0 <= x -> P x. Proof. - exact Z_lt_rec. + intros; now apply Z_lt_rec. Qed. (** An even more general induction principle using [Z.lt]. *) @@ -196,7 +194,7 @@ Section Efficient_Rec. (forall x:Z, (forall y:Z, z <= y < x -> P y) -> z <= x -> P x) -> forall x:Z, z <= x -> P x. Proof. - exact Zlt_lower_bound_rec. + intros; now apply Zlt_lower_bound_rec with z. Qed. End Efficient_Rec. diff --git a/theories/ZArith/Zcomplements.v b/theories/ZArith/Zcomplements.v index b4163ef99..a5e710504 100644 --- a/theories/ZArith/Zcomplements.v +++ b/theories/ZArith/Zcomplements.v @@ -53,10 +53,11 @@ Theorem Z_lt_abs_rec : forall n:Z, P n. Proof. intros P HP p. - set (Q := fun z => 0 <= z -> P z * P (- z)) in *. - cut (Q (Z.abs p)); [ intros | apply (Z_lt_rec Q); auto with zarith ]. - elim (Zabs_dec p); intro eq; rewrite eq; elim H; auto with zarith. - unfold Q; clear Q; intros. + set (Q := fun z => 0 <= z -> P z * P (- z)). + cut (Q (Z.abs p)); [ intros H | apply (Z_lt_rec Q); auto with zarith ]. + elim (Zabs_dec p); intro eq; rewrite eq; + elim H; auto with zarith. + intros x H; subst Q. split; apply HP. rewrite Z.abs_eq; auto; intros. elim (H (Z.abs m)); intros; auto with zarith. diff --git a/tools/coqc.ml b/tools/coqc.ml index e835091ea..d7f1bebdf 100644 --- a/tools/coqc.ml +++ b/tools/coqc.ml @@ -120,7 +120,7 @@ let parse_args () = |"-dont-load-proofs"|"-load-proofs"|"-force-load-proofs" |"-impredicative-set"|"-vm"|"-no-native-compiler" |"-verbose-compat-notations"|"-no-compat-notations" - |"-quick" + |"-indices-matter"|"-quick" as o) :: rem -> parse (cfiles,o::args) rem @@ -158,8 +158,6 @@ let parse_args () = extra_arg_needed := false; parse (cfiles, List.rev nodash @ s :: o :: args) rem -(* Anything else is interpreted as a file *) - | f :: rem -> if Sys.file_exists f then parse (f::cfiles,args) rem diff --git a/toplevel/auto_ind_decl.ml b/toplevel/auto_ind_decl.ml index 04d0f3de4..1a1a4dfe7 100644 --- a/toplevel/auto_ind_decl.ml +++ b/toplevel/auto_ind_decl.ml @@ -25,6 +25,8 @@ open Ind_tables open Misctypes open Proofview.Notations +let out_punivs = Univ.out_punivs + (**********************************************************************) (* Generic synthesis of boolean equality *) @@ -55,6 +57,8 @@ exception NonSingletonProp of inductive let dl = Loc.ghost +let constr_of_global g = lazy (Universes.constr_of_global g) + (* Some pre declaration of constant we are going to use *) let bb = constr_of_global Coqlib.glob_bool @@ -93,7 +97,7 @@ let destruct_on c = None (None,None) None (* reconstruct the inductive with the correct deBruijn indexes *) -let mkFullInd ind n = +let mkFullInd (ind,u) n = let mib = Global.lookup_mind (fst ind) in let nparams = mib.mind_nparams in let nparrec = mib.mind_nparams_rec in @@ -101,12 +105,12 @@ let mkFullInd ind n = let lnonparrec,lnamesparrec = context_chop (nparams-nparrec) mib.mind_params_ctxt in if nparrec > 0 - then mkApp (mkInd ind, + then mkApp (mkIndU (ind,u), Array.of_list(extended_rel_list (nparrec+n) lnamesparrec)) - else mkInd ind + else mkIndU (ind,u) let check_bool_is_defined () = - try let _ = Global.type_of_global Coqlib.glob_bool in () + try let _ = Global.type_of_global_unsafe Coqlib.glob_bool in () with e when Errors.noncritical e -> raise (UndefinedCst "bool") let beq_scheme_kind_aux = ref (fun _ -> failwith "Undefined") @@ -142,7 +146,7 @@ let build_beq_scheme kn = let eqs_typ = List.map (fun aa -> let a = lift !lift_cnt aa in incr lift_cnt; - myArrow a (myArrow a bb) + myArrow a (myArrow a (Lazy.force bb)) ) ext_rel_list in let eq_input = List.fold_left2 @@ -159,11 +163,12 @@ let build_beq_scheme kn = t a) eq_input lnamesparrec in let make_one_eq cur = - let ind = kn,cur in + let u = Univ.Instance.empty in + let ind = (kn,cur),u (* FIXME *) in (* current inductive we are working on *) - let cur_packet = mib.mind_packets.(snd ind) in + let cur_packet = mib.mind_packets.(snd (fst ind)) in (* Inductive toto : [rettyp] := *) - let rettyp = Inductive.type_of_inductive env (mib,cur_packet) in + let rettyp = Inductive.type_of_inductive env ((mib,cur_packet),u) in (* split rettyp in a list without the non rec params and the last -> e.g. Inductive vec (A:Set) : nat -> Set := ... will do [nat] *) let rettyp_l = quick_chop nparrec (deconstruct_type rettyp) in @@ -182,7 +187,7 @@ let build_beq_scheme kn = | Var x -> mkVar (id_of_string ("eq_"^(string_of_id x))), Declareops.no_seff | Cast (x,_,_) -> aux (applist (x,a)) | App _ -> assert false - | Ind (kn',i as ind') -> + | Ind ((kn',i as ind'),u) (*FIXME: universes *) -> if eq_mind kn kn' then mkRel(eqA-nlist-i+nb_ind-1), Declareops.no_seff else begin try @@ -200,16 +205,17 @@ let build_beq_scheme kn = (Array.of_list (List.map (fun x -> lift lifti x) a)) eqa in if Int.equal (Array.length args) 0 then eq, eff else mkApp (eq, args), eff - with Not_found -> raise(EqNotFound (ind',ind)) + with Not_found -> raise(EqNotFound (ind', fst ind)) end | Sort _ -> raise InductiveWithSort | Prod _ -> raise InductiveWithProduct | Lambda _-> raise (EqUnknown "Lambda") | LetIn _ -> raise (EqUnknown "LetIn") | Const kn -> - (match Environ.constant_opt_value env kn with - | None -> raise (ParameterWithoutEquality kn) + (match Environ.constant_opt_value_in env kn with + | None -> raise (ParameterWithoutEquality (fst kn)) | Some c -> aux (applist (c,a))) + | Proj _ -> raise (EqUnknown "Proj") | Construct _ -> raise (EqUnknown "Construct") | Case _ -> raise (EqUnknown "Case") | CoFix _ -> raise (EqUnknown "CoFix") @@ -224,28 +230,28 @@ let build_beq_scheme kn = List.fold_left (fun a b -> mkLambda(Anonymous,b,a)) (mkLambda (Anonymous, mkFullInd ind (n+3+(List.length rettyp_l)+nb_ind-1), - bb)) + (Lazy.force bb))) (List.rev rettyp_l) in (* make_one_eq *) (* do the [| C1 ... => match Y with ... end ... Cn => match Y with ... end |] part *) - let ci = make_case_info env ind MatchStyle in + let ci = make_case_info env (fst ind) MatchStyle in let constrs n = get_constructors env (make_ind_family (ind, extended_rel_list (n+nb_ind-1) mib.mind_params_ctxt)) in let constrsi = constrs (3+nparrec) in let n = Array.length constrsi in - let ar = Array.make n ff in - let eff = ref Declareops.no_seff in + let ar = Array.make n (Lazy.force ff) in + let eff = ref Declareops.no_seff in for i=0 to n-1 do let nb_cstr_args = List.length constrsi.(i).cs_args in - let ar2 = Array.make n ff in + let ar2 = Array.make n (Lazy.force ff) in let constrsj = constrs (3+nparrec+nb_cstr_args) in for j=0 to n-1 do if Int.equal i j then ar2.(j) <- let cc = (match nb_cstr_args with - | 0 -> tt - | _ -> let eqs = Array.make nb_cstr_args tt in + | 0 -> Lazy.force tt + | _ -> let eqs = Array.make nb_cstr_args (Lazy.force tt) in for ndx = 0 to nb_cstr_args-1 do let _,_,cc = List.nth constrsi.(i).cs_args ndx in let eqA, eff' = compute_A_equality rel_list @@ -270,7 +276,7 @@ let build_beq_scheme kn = (constrsj.(j).cs_args) ) else ar2.(j) <- (List.fold_left (fun a (p,q,r) -> - mkLambda (p,r,a)) ff (constrsj.(j).cs_args) ) + mkLambda (p,r,a)) (Lazy.force ff) (constrsj.(j).cs_args) ) done; ar.(i) <- (List.fold_left (fun a (p,q,r) -> mkLambda (p,r,a)) @@ -287,21 +293,23 @@ let build_beq_scheme kn = types = Array.make nb_ind mkSet and cores = Array.make nb_ind mkSet in let eff = ref Declareops.no_seff in + let u = Univ.Instance.empty in for i=0 to (nb_ind-1) do names.(i) <- Name (Id.of_string (rec_name i)); - types.(i) <- mkArrow (mkFullInd (kn,i) 0) - (mkArrow (mkFullInd (kn,i) 1) bb); + types.(i) <- mkArrow (mkFullInd ((kn,i),u) 0) + (mkArrow (mkFullInd ((kn,i),u) 1) (Lazy.force bb)); let c, eff' = make_one_eq i in cores.(i) <- c; eff := Declareops.union_side_effects eff' !eff done; - Array.init nb_ind (fun i -> + (Array.init nb_ind (fun i -> let kelim = Inductive.elim_sorts (mib,mib.mind_packets.(i)) in - if not (Sorts.List.mem InSet kelim) then - raise (NonSingletonProp (kn,i)); - let fix = mkFix (((Array.make nb_ind 0),i),(names,types,cores)) in - create_input fix), - !eff + if not (Sorts.List.mem InSet kelim) then + raise (NonSingletonProp (kn,i)); + let fix = mkFix (((Array.make nb_ind 0),i),(names,types,cores)) in + create_input fix), + Evd.empty_evar_universe_context (* FIXME *)), + !eff let beq_scheme_kind = declare_mutual_scheme_object "_beq" build_beq_scheme @@ -343,8 +351,8 @@ let do_replace_lb lb_scheme_key aavoid narg p q = (* if this happen then the args have to be already declared as a Parameter*) ( - let mp,dir,lbl = repr_con (destConst v) in - mkConst (make_con mp dir (Label.make ( + let mp,dir,lbl = repr_con (fst (destConst v)) in + mkConst (make_con mp dir (mk_label ( if Int.equal offset 1 then ("eq_"^(Label.to_string lbl)) else ((Label.to_string lbl)^"_lb") ))) @@ -355,7 +363,7 @@ let do_replace_lb lb_scheme_key aavoid narg p q = let u,v = destruct_ind type_of_pq in let lb_type_of_p = try - let c, eff = find_scheme lb_scheme_key u in + let c, eff = find_scheme lb_scheme_key (out_punivs u) (*FIXME*) in Proofview.tclUNIT (mkConst c, eff) with Not_found -> (* spiwack: the format of this error message should probably @@ -383,7 +391,7 @@ let do_replace_lb lb_scheme_key aavoid narg p q = end (* used in the bool -> leib side *) -let do_replace_bl bl_scheme_key ind aavoid narg lft rgt = +let do_replace_bl bl_scheme_key (ind,u as indu) aavoid narg lft rgt = let avoid = Array.of_list aavoid in let do_arg v offset = try @@ -400,8 +408,8 @@ let do_replace_bl bl_scheme_key ind aavoid narg lft rgt = (* if this happen then the args have to be already declared as a Parameter*) ( - let mp,dir,lbl = repr_con (destConst v) in - mkConst (make_con mp dir (Label.make ( + let mp,dir,lbl = repr_con (fst (destConst v)) in + mkConst (make_con mp dir (mk_label ( if Int.equal offset 1 then ("eq_"^(Label.to_string lbl)) else ((Label.to_string lbl)^"_bl") ))) @@ -417,13 +425,13 @@ let do_replace_bl bl_scheme_key ind aavoid narg lft rgt = else ( let u,v = try destruct_ind tt1 (* trick so that the good sequence is returned*) - with e when Errors.noncritical e -> ind,[||] - in if eq_ind u ind + with e when Errors.noncritical e -> indu,[||] + in if eq_ind (fst u) ind then Tacticals.New.tclTHENLIST [Equality.replace t1 t2; Auto.default_auto ; aux q1 q2 ] else ( let bl_t1, eff = try - let c, eff = find_scheme bl_scheme_key u in + let c, eff = find_scheme bl_scheme_key (out_punivs u) (*FIXME*) in mkConst c, eff with Not_found -> (* spiwack: the format of this error message should probably @@ -462,15 +470,15 @@ let do_replace_bl bl_scheme_key ind aavoid narg lft rgt = begin try Proofview.tclUNIT (destApp rgt) with DestKO -> Proofview.tclZERO (UserError ("" , str"replace failed.")) end >>= fun (ind2,ca2) -> - begin try Proofview.tclUNIT (destInd ind1) + begin try Proofview.tclUNIT (out_punivs (destInd ind1)) with DestKO -> - begin try Proofview.tclUNIT (fst (destConstruct ind1)) + begin try Proofview.tclUNIT (fst (fst (destConstruct ind1))) with DestKO -> Proofview.tclZERO (UserError ("" , str"The expected type is an inductive one.")) end end >>= fun (sp1,i1) -> - begin try Proofview.tclUNIT (destInd ind2) + begin try Proofview.tclUNIT (out_punivs (destInd ind2)) with DestKO -> - begin try Proofview.tclUNIT (fst (destConstruct ind2)) + begin try Proofview.tclUNIT (fst (fst (destConstruct ind2))) with DestKO -> Proofview.tclZERO (UserError ("" , str"The expected type is an inductive one.")) end end >>= fun (sp2,i2) -> @@ -517,15 +525,15 @@ let compute_bl_goal ind lnamesparrec nparrec = mkNamedProd x (mkVar s) ( mkNamedProd y (mkVar s) ( mkArrow - ( mkApp(eq,[|bb;mkApp(mkVar seq,[|mkVar x;mkVar y|]);tt|])) - ( mkApp(eq,[|mkVar s;mkVar x;mkVar y|])) + ( mkApp(Lazy.force eq,[|(Lazy.force bb);mkApp(mkVar seq,[|mkVar x;mkVar y|]);(Lazy.force tt)|])) + ( mkApp(Lazy.force eq,[|mkVar s;mkVar x;mkVar y|])) )) ) list_id in let bl_input = List.fold_left2 ( fun a (s,_,sbl,_) b -> mkNamedProd sbl b a ) c (List.rev list_id) (List.rev bl_typ) in let eqs_typ = List.map (fun (s,_,_,_) -> - mkProd(Anonymous,mkVar s,mkProd(Anonymous,mkVar s,bb)) + mkProd(Anonymous,mkVar s,mkProd(Anonymous,mkVar s,(Lazy.force bb))) ) list_id in let eq_input = List.fold_left2 ( fun a (s,seq,_,_) b -> mkNamedProd seq b a @@ -536,12 +544,13 @@ let compute_bl_goal ind lnamesparrec nparrec = in let n = Id.of_string "x" and m = Id.of_string "y" in + let u = Univ.Instance.empty in create_input ( - mkNamedProd n (mkFullInd ind nparrec) ( - mkNamedProd m (mkFullInd ind (nparrec+1)) ( + mkNamedProd n (mkFullInd (ind,u) nparrec) ( + mkNamedProd m (mkFullInd (ind,u) (nparrec+1)) ( mkArrow - (mkApp(eq,[|bb;mkApp(eqI,[|mkVar n;mkVar m|]);tt|])) - (mkApp(eq,[|mkFullInd ind (nparrec+3);mkVar n;mkVar m|])) + (mkApp(Lazy.force eq,[|(Lazy.force bb);mkApp(eqI,[|mkVar n;mkVar m|]);(Lazy.force tt)|])) + (mkApp(Lazy.force eq,[|mkFullInd (ind,u) (nparrec+3);mkVar n;mkVar m|])) ))), eff let compute_bl_tact bl_scheme_key ind lnamesparrec nparrec = @@ -600,7 +609,7 @@ repeat ( apply andb_prop in z;let z1:= fresh "Z" in destruct z as [z1 z]). match (kind_of_term gl) with | App (c,ca) -> ( match (kind_of_term c) with - | Ind indeq -> + | Ind (indeq, u) -> if eq_gr (IndRef indeq) Coqlib.glob_eq then Tacticals.New.tclTHEN @@ -629,12 +638,14 @@ let make_bl_scheme mind = let ind = (mind,0) in let nparams = mib.mind_nparams in let nparrec = mib.mind_nparams_rec in - let lnonparrec,lnamesparrec = + let lnonparrec,lnamesparrec = (* TODO subst *) context_chop (nparams-nparrec) mib.mind_params_ctxt in let bl_goal, eff = compute_bl_goal ind lnamesparrec nparrec in - [|fst (Pfedit.build_by_tactic (Global.env()) bl_goal - (compute_bl_tact (!bl_scheme_kind_aux()) ind lnamesparrec nparrec))|], - eff + let ctx = Univ.ContextSet.empty (*FIXME univs *) in + let (ans, _, _) = Pfedit.build_by_tactic (Global.env()) (bl_goal, ctx) + (compute_bl_tact (!bl_scheme_kind_aux()) (ind, Univ.Instance.empty) lnamesparrec nparrec) + in + ([|ans|], Evd.empty_evar_universe_context), eff let bl_scheme_kind = declare_mutual_scheme_object "_dec_bl" make_bl_scheme @@ -645,6 +656,7 @@ let _ = bl_scheme_kind_aux := fun () -> bl_scheme_kind let compute_lb_goal ind lnamesparrec nparrec = let list_id = list_id lnamesparrec in + let eq = Lazy.force eq and tt = Lazy.force tt and bb = Lazy.force bb in let eqI, eff = eqI ind lnamesparrec in let create_input c = let x = Id.of_string "x" and @@ -672,11 +684,12 @@ let compute_lb_goal ind lnamesparrec nparrec = in let n = Id.of_string "x" and m = Id.of_string "y" in + let u = Univ.Instance.empty in create_input ( - mkNamedProd n (mkFullInd ind nparrec) ( - mkNamedProd m (mkFullInd ind (nparrec+1)) ( + mkNamedProd n (mkFullInd (ind,u) nparrec) ( + mkNamedProd m (mkFullInd (ind,u) (nparrec+1)) ( mkArrow - (mkApp(eq,[|mkFullInd ind (nparrec+2);mkVar n;mkVar m|])) + (mkApp(eq,[|mkFullInd (ind,u) (nparrec+2);mkVar n;mkVar m|])) (mkApp(eq,[|bb;mkApp(eqI,[|mkVar n;mkVar m|]);tt|])) ))), eff @@ -750,9 +763,10 @@ let make_lb_scheme mind = let lnonparrec,lnamesparrec = context_chop (nparams-nparrec) mib.mind_params_ctxt in let lb_goal, eff = compute_lb_goal ind lnamesparrec nparrec in - [|fst (Pfedit.build_by_tactic (Global.env()) lb_goal - (compute_lb_tact (!lb_scheme_kind_aux()) ind lnamesparrec nparrec))|], - eff + let (ans, _, _) = Pfedit.build_by_tactic (Global.env()) (lb_goal,Univ.ContextSet.empty) + (compute_lb_tact (!lb_scheme_kind_aux()) ind lnamesparrec nparrec) + in + ([|ans|], Evd.empty_evar_universe_context (* FIXME *)), eff let lb_scheme_kind = declare_mutual_scheme_object "_dec_lb" make_lb_scheme @@ -768,6 +782,7 @@ let check_not_is_defined () = (* {n=m}+{n<>m} part *) let compute_dec_goal ind lnamesparrec nparrec = check_not_is_defined (); + let eq = Lazy.force eq and tt = Lazy.force tt and bb = Lazy.force bb in let list_id = list_id lnamesparrec in let create_input c = let x = Id.of_string "x" and @@ -818,6 +833,8 @@ let compute_dec_goal ind lnamesparrec nparrec = ) let compute_dec_tact ind lnamesparrec nparrec = + let eq = Lazy.force eq and tt = Lazy.force tt + and ff = Lazy.force ff and bb = Lazy.force bb in let list_id = list_id lnamesparrec in let eqI, eff = eqI ind lnamesparrec in let avoid = ref [] in @@ -915,11 +932,14 @@ let make_eq_decidability mind = let ind = (mind,0) in let nparams = mib.mind_nparams in let nparrec = mib.mind_nparams_rec in + let u = Univ.Instance.empty in let lnonparrec,lnamesparrec = context_chop (nparams-nparrec) mib.mind_params_ctxt in - [|fst (Pfedit.build_by_tactic (Global.env()) - (compute_dec_goal ind lnamesparrec nparrec) - (compute_dec_tact ind lnamesparrec nparrec))|], Declareops.no_seff + let (ans, _, _) = Pfedit.build_by_tactic (Global.env()) + (compute_dec_goal (ind,u) lnamesparrec nparrec, Univ.ContextSet.empty) + (compute_dec_tact ind lnamesparrec nparrec) + in + ([|ans|], Evd.empty_evar_universe_context (* FIXME *)), Declareops.no_seff let eq_dec_scheme_kind = declare_mutual_scheme_object "_eq_dec" make_eq_decidability diff --git a/toplevel/auto_ind_decl.mli b/toplevel/auto_ind_decl.mli index 6509a7d3b..21362c973 100644 --- a/toplevel/auto_ind_decl.mli +++ b/toplevel/auto_ind_decl.mli @@ -26,17 +26,16 @@ exception ParameterWithoutEquality of constant exception NonSingletonProp of inductive val beq_scheme_kind : mutual scheme_kind -val build_beq_scheme : mutual_inductive -> constr array * Declareops.side_effects +val build_beq_scheme : mutual_scheme_object_function (** {6 Build equivalence between boolean equality and Leibniz equality } *) val lb_scheme_kind : mutual scheme_kind -val make_lb_scheme : mutual_inductive -> constr array * Declareops.side_effects - +val make_lb_scheme : mutual_scheme_object_function val bl_scheme_kind : mutual scheme_kind -val make_bl_scheme : mutual_inductive -> constr array * Declareops.side_effects +val make_bl_scheme : mutual_scheme_object_function (** {6 Build decidability of equality } *) val eq_dec_scheme_kind : mutual scheme_kind -val make_eq_decidability : mutual_inductive -> constr array * Declareops.side_effects +val make_eq_decidability : mutual_scheme_object_function diff --git a/toplevel/cerrors.ml b/toplevel/cerrors.ml index 0186b08ac..f5cc2015b 100644 --- a/toplevel/cerrors.ml +++ b/toplevel/cerrors.ml @@ -58,22 +58,10 @@ let wrap_vernac_error exn strm = Exninfo.copy exn e let process_vernac_interp_error exn = match exn with - | Univ.UniverseInconsistency (o,u,v,p) -> - let pr_rel r = - match r with - Univ.Eq -> str"=" | Univ.Lt -> str"<" | Univ.Le -> str"<=" in - let reason = match p with - [] -> mt() - | _::_ -> - str " because" ++ spc() ++ Univ.pr_uni v ++ - prlist (fun (r,v) -> spc() ++ pr_rel r ++ str" " ++ Univ.pr_uni v) - p ++ - (if Univ.Universe.equal (snd (List.last p)) u then mt() else - (spc() ++ str "= " ++ Univ.pr_uni u)) in + | Univ.UniverseInconsistency i -> let msg = if !Constrextern.print_universes then - spc() ++ str "(cannot enforce" ++ spc() ++ Univ.pr_uni u ++ spc() ++ - pr_rel o ++ spc() ++ Univ.pr_uni v ++ reason ++ str")" + str "." ++ spc() ++ Univ.explain_universe_inconsistency i else mt() in wrap_vernac_error exn (str "Universe inconsistency" ++ msg ++ str ".") diff --git a/toplevel/class.ml b/toplevel/class.ml index a9cb6ca5e..d54efb632 100644 --- a/toplevel/class.ml +++ b/toplevel/class.ml @@ -66,7 +66,7 @@ let explain_coercion_error g = function (* Verifications pour l'ajout d'une classe *) let check_reference_arity ref = - if not (Reductionops.is_arity (Global.env()) Evd.empty (Global.type_of_global ref)) then + if not (Reductionops.is_arity (Global.env()) Evd.empty (Global.type_of_global_unsafe ref)) then raise (CoercionError (NotAClass ref)) let check_arity = function @@ -118,19 +118,19 @@ l'indice de la classe source dans la liste lp let get_source lp source = match source with | None -> - let (cl1,lv1) = + let (cl1,u1,lv1) = match lp with | [] -> raise Not_found | t1::_ -> find_class_type Evd.empty t1 in - (cl1,lv1,1) + (cl1,u1,lv1,1) | Some cl -> let rec aux = function | [] -> raise Not_found | t1::lt -> try - let cl1,lv1 = find_class_type Evd.empty t1 in - if cl_typ_eq cl cl1 then cl1,lv1,(List.length lt+1) + let cl1,u1,lv1 = find_class_type Evd.empty t1 in + if cl_typ_eq cl cl1 then cl1,u1,lv1,(List.length lt+1) else raise Not_found with Not_found -> aux lt in aux (List.rev lp) @@ -139,7 +139,7 @@ let get_target t ind = if (ind > 1) then CL_FUN else - fst (find_class_type Evd.empty t) + pi1 (find_class_type Evd.empty t) let prods_of t = let rec aux acc d = match kind_of_term d with @@ -177,12 +177,12 @@ let error_not_transparent source = errorlabstrm "build_id_coercion" (pr_class source ++ str " must be a transparent constant.") -let build_id_coercion idf_opt source = +let build_id_coercion idf_opt source poly = let env = Global.env () in - let vs = match source with - | CL_CONST sp -> mkConst sp + let vs, ctx = match source with + | CL_CONST sp -> Universes.fresh_global_instance env (ConstRef sp) | _ -> error_not_transparent source in - let c = match constant_opt_value env (destConst vs) with + let c = match constant_opt_value_in env (destConst vs) with | Some c -> c | None -> error_not_transparent source in let lams,t = decompose_lam_assum c in @@ -211,7 +211,7 @@ let build_id_coercion idf_opt source = match idf_opt with | Some idf -> idf | None -> - let cl,_ = find_class_type Evd.empty t in + let cl,u,_ = find_class_type Evd.empty t in Id.of_string ("Id_"^(ident_key_of_class source)^"_"^ (ident_key_of_class cl)) in @@ -221,6 +221,9 @@ let build_id_coercion idf_opt source = (mkCast (val_f, DEFAULTcast, typ_f),Declareops.no_seff); const_entry_secctx = None; const_entry_type = Some typ_f; + const_entry_proj = None; + const_entry_polymorphic = poly; + const_entry_universes = Univ.ContextSet.to_context ctx; const_entry_opaque = false; const_entry_inline_code = true; const_entry_feedback = None; @@ -244,14 +247,14 @@ booleen "coercion identite'?" lorque source est None alors target est None aussi. *) -let add_new_coercion_core coef stre source target isid = +let add_new_coercion_core coef stre poly source target isid = check_source source; - let t = Global.type_of_global coef in + let t = Global.type_of_global_unsafe coef in if coercion_exists coef then raise (CoercionError AlreadyExists); let tg,lp = prods_of t in let llp = List.length lp in if Int.equal llp 0 then raise (CoercionError NotAFunction); - let (cls,lvs,ind) = + let (cls,us,lvs,ind) = try get_source lp source with Not_found -> @@ -275,44 +278,45 @@ let add_new_coercion_core coef stre source target isid = in declare_coercion coef ~local ~isid ~src:cls ~target:clt ~params:(List.length lvs) -let try_add_new_coercion_core ref ~local c d e = - try add_new_coercion_core ref (loc_of_bool local) c d e + +let try_add_new_coercion_core ref ~local c d e f = + try add_new_coercion_core ref (loc_of_bool local) c d e f with CoercionError e -> errorlabstrm "try_add_new_coercion_core" (explain_coercion_error ref e ++ str ".") -let try_add_new_coercion ref ~local = - try_add_new_coercion_core ref ~local None None false +let try_add_new_coercion ref ~local poly = + try_add_new_coercion_core ref ~local poly None None false -let try_add_new_coercion_subclass cl ~local = - let coe_ref = build_id_coercion None cl in - try_add_new_coercion_core coe_ref ~local (Some cl) None true +let try_add_new_coercion_subclass cl ~local poly = + let coe_ref = build_id_coercion None cl poly in + try_add_new_coercion_core coe_ref ~local poly (Some cl) None true -let try_add_new_coercion_with_target ref ~local ~source ~target = - try_add_new_coercion_core ref ~local (Some source) (Some target) false +let try_add_new_coercion_with_target ref ~local poly ~source ~target = + try_add_new_coercion_core ref ~local poly (Some source) (Some target) false -let try_add_new_identity_coercion id ~local ~source ~target = - let ref = build_id_coercion (Some id) source in - try_add_new_coercion_core ref ~local (Some source) (Some target) true +let try_add_new_identity_coercion id ~local poly ~source ~target = + let ref = build_id_coercion (Some id) source poly in + try_add_new_coercion_core ref ~local poly (Some source) (Some target) true -let try_add_new_coercion_with_source ref ~local ~source = - try_add_new_coercion_core ref ~local (Some source) None false +let try_add_new_coercion_with_source ref ~local poly ~source = + try_add_new_coercion_core ref ~local poly (Some source) None false -let add_coercion_hook local ref = +let add_coercion_hook poly local ref = let stre = match local with | Local -> true | Global -> false | Discharge -> assert false in - let () = try_add_new_coercion ref stre in + let () = try_add_new_coercion ref stre poly in let msg = pr_global_env Id.Set.empty ref ++ str " is now a coercion" in Flags.if_verbose msg_info msg -let add_subclass_hook local ref = +let add_subclass_hook poly local ref = let stre = match local with | Local -> true | Global -> false | Discharge -> assert false in let cl = class_of_global ref in - try_add_new_coercion_subclass cl stre + try_add_new_coercion_subclass cl stre poly diff --git a/toplevel/class.mli b/toplevel/class.mli index 8bb3eb7ce..d472bd984 100644 --- a/toplevel/class.mli +++ b/toplevel/class.mli @@ -14,32 +14,35 @@ open Globnames (** [try_add_new_coercion_with_target ref s src tg] declares [ref] as a coercion from [src] to [tg] *) -val try_add_new_coercion_with_target : global_reference -> local:bool -> +val try_add_new_coercion_with_target : global_reference -> local:bool -> + Decl_kinds.polymorphic -> source:cl_typ -> target:cl_typ -> unit (** [try_add_new_coercion ref s] declares [ref], assumed to be of type [(x1:T1)...(xn:Tn)src->tg], as a coercion from [src] to [tg] *) -val try_add_new_coercion : global_reference -> local:bool -> unit +val try_add_new_coercion : global_reference -> local:bool -> + Decl_kinds.polymorphic -> unit (** [try_add_new_coercion_subclass cst s] expects that [cst] denotes a transparent constant which unfolds to some class [tg]; it declares an identity coercion from [cst] to [tg], named something like ["Id_cst_tg"] *) -val try_add_new_coercion_subclass : cl_typ -> local:bool -> unit +val try_add_new_coercion_subclass : cl_typ -> local:bool -> + Decl_kinds.polymorphic -> unit (** [try_add_new_coercion_with_source ref s src] declares [ref] as a coercion from [src] to [tg] where the target is inferred from the type of [ref] *) -val try_add_new_coercion_with_source : global_reference -> local:bool -> - source:cl_typ -> unit +val try_add_new_coercion_with_source : global_reference -> local:bool -> + Decl_kinds.polymorphic -> source:cl_typ -> unit (** [try_add_new_identity_coercion id s src tg] enriches the environment with a new definition of name [id] declared as an identity coercion from [src] to [tg] *) -val try_add_new_identity_coercion : Id.t -> local:bool -> - source:cl_typ -> target:cl_typ -> unit +val try_add_new_identity_coercion : Id.t -> local:bool -> + Decl_kinds.polymorphic -> source:cl_typ -> target:cl_typ -> unit -val add_coercion_hook : unit Tacexpr.declaration_hook +val add_coercion_hook : Decl_kinds.polymorphic -> unit Tacexpr.declaration_hook -val add_subclass_hook : unit Tacexpr.declaration_hook +val add_subclass_hook : Decl_kinds.polymorphic -> unit Tacexpr.declaration_hook val class_of_global : global_reference -> cl_typ diff --git a/toplevel/classes.ml b/toplevel/classes.ml index 2e17f646b..cf47abf44 100644 --- a/toplevel/classes.ml +++ b/toplevel/classes.ml @@ -33,11 +33,14 @@ let set_typeclass_transparency c local b = let _ = Hook.set Typeclasses.add_instance_hint_hook - (fun inst path local pri -> + (fun inst path local pri poly -> + let inst' = match inst with IsConstr c -> Auto.IsConstr (c, Univ.ContextSet.empty) + | IsGlobal gr -> Auto.IsGlobRef gr + in Flags.silently (fun () -> Auto.add_hints local [typeclasses_db] (Auto.HintsResolveEntry - [pri, false, Auto.PathHints path, inst])) ()); + [pri, poly, false, Auto.PathHints path, inst'])) ()); Hook.set Typeclasses.set_typeclass_transparency_hook set_typeclass_transparency; Hook.set Typeclasses.classes_transparent_state_hook (fun () -> Auto.Hint_db.transparent_state (Auto.searchtable_map typeclasses_db)) @@ -52,10 +55,11 @@ let declare_class g = (** TODO: add subinstances *) let existing_instance glob g pri = let c = global g in - let instance = Typing.type_of (Global.env ()) Evd.empty (constr_of_global c) in + let instance = Typing.type_of (Global.env ()) Evd.empty (Universes.constr_of_global c) in let _, r = decompose_prod_assum instance in match class_of_constr r with - | Some (_, (tc, _)) -> add_instance (new_instance tc pri glob c) + | Some (_, ((tc,u), _)) -> add_instance (new_instance tc pri glob + (*FIXME*) (Flags.use_polymorphic_flag ()) c) | None -> user_err_loc (loc_of_reference g, "declare_instance", Pp.str "Constant does not build instances of a declared type class.") @@ -95,27 +99,22 @@ let instance_hook k pri global imps ?hook cst = Typeclasses.declare_instance pri (not global) cst; (match hook with Some h -> h cst | None -> ()) -let declare_instance_constant k pri global imps ?hook id term termtype = +let declare_instance_constant k pri global imps ?hook id poly uctx term termtype = let kind = IsDefinition Instance in - let entry = { - const_entry_body = Future.from_val term; - const_entry_secctx = None; - const_entry_type = Some termtype; - const_entry_opaque = false; - const_entry_inline_code = false; - const_entry_feedback = None; - } in + let entry = + Declare.definition_entry ~types:termtype ~poly ~univs:uctx term + in let cdecl = (DefinitionEntry entry, kind) in let kn = Declare.declare_constant id cdecl in Declare.definition_message id; instance_hook k pri global imps ?hook (ConstRef kn); id -let new_instance ?(abstract=false) ?(global=false) ctx (instid, bk, cl) props +let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) props ?(generalize=true) ?(tac:unit Proofview.tactic option) ?hook pri = let env = Global.env() in - let evars = ref Evd.empty in + let evars = ref (Evd.from_env env) in let tclass, ids = match bk with | Implicit -> @@ -129,15 +128,19 @@ let new_instance ?(abstract=false) ?(global=false) ctx (instid, bk, cl) props cl | Explicit -> cl, Id.Set.empty in - let tclass = if generalize then CGeneralization (Loc.ghost, Implicit, Some AbsPi, tclass) else tclass in - let k, cty, ctx', ctx, len, imps, subst = + let tclass = + if generalize then CGeneralization (Loc.ghost, Implicit, Some AbsPi, tclass) + else tclass + in + let k, u, cty, ctx', ctx, len, imps, subst = let impls, ((env', ctx), imps) = interp_context_evars evars env ctx in let c', imps' = interp_type_evars_impls ~impls evars env' tclass in let len = List.length ctx in let imps = imps @ Impargs.lift_implicits len imps' in let ctx', c = decompose_prod_assum c' in let ctx'' = ctx' @ ctx in - let cl, args = Typeclasses.dest_class_app (push_rel_context ctx'' env) c in + let k, args = Typeclasses.dest_class_app (push_rel_context ctx'' env) c in + let cl, u = Typeclasses.typeclass_univ_instance k in let _, args = List.fold_right (fun (na, b, t) (args, args') -> match b with @@ -145,7 +148,7 @@ let new_instance ?(abstract=false) ?(global=false) ctx (instid, bk, cl) props | Some b -> (args, substl args' b :: args')) (snd cl.cl_context) (args, []) in - cl, c', ctx', ctx, len, imps, args + cl, u, c', ctx', ctx, len, imps, args in let id = match snd instid with @@ -161,19 +164,23 @@ let new_instance ?(abstract=false) ?(global=false) ctx (instid, bk, cl) props let env' = push_rel_context ctx env in evars := Evarutil.nf_evar_map !evars; evars := resolve_typeclasses ~filter:Typeclasses.no_goals ~fail:true env !evars; - let sigma = !evars in - let subst = List.map (Evarutil.nf_evar sigma) subst in + let subst = List.map (Evarutil.nf_evar !evars) subst in if abstract then begin - let _, ty_constr = instance_constructor k (List.rev subst) in + let subst = List.fold_left2 + (fun subst' s (_, b, _) -> if Option.is_empty b then s :: subst' else subst') + [] subst (snd k.cl_context) + in + let (_, ty_constr) = instance_constructor (k,u) subst in let termtype = let t = it_mkProd_or_LetIn ty_constr (ctx' @ ctx) in - Evarutil.nf_evar !evars t + fst (Evarutil.e_nf_evars_and_universes evars) t in Evarutil.check_evars env Evd.empty !evars termtype; + let ctx = Evd.universe_context !evars in let cst = Declare.declare_constant ~internal:Declare.KernelSilent id (Entries.ParameterEntry - (None,termtype,None), Decl_kinds.IsAssumption Decl_kinds.Logical) + (None,poly,(termtype,ctx),None), Decl_kinds.IsAssumption Decl_kinds.Logical) in instance_hook k None global imps ?hook (ConstRef cst); id end else ( @@ -203,11 +210,11 @@ let new_instance ?(abstract=false) ?(global=false) ctx (instid, bk, cl) props let props, rest = List.fold_left (fun (props, rest) (id,b,_) -> - if Option.is_empty b then - try - let is_id (id', _) = match id, get_id id' with - | Name id, (_, id') -> Id.equal id id' - | Anonymous, _ -> false + if Option.is_empty b then + try + let is_id (id', _) = match id, get_id id' with + | Name id, (_, id') -> Id.equal id id' + | Anonymous, _ -> false in let (loc_mid, c) = List.find is_id rest @@ -242,7 +249,7 @@ let new_instance ?(abstract=false) ?(global=false) ctx (instid, bk, cl) props (fun subst' s (_, b, _) -> if Option.is_empty b then s :: subst' else subst') [] subst (k.cl_props @ snd k.cl_context) in - let app, ty_constr = instance_constructor k subst in + let (app, ty_constr) = instance_constructor (k,u) subst in let termtype = it_mkProd_or_LetIn ty_constr (ctx' @ ctx) in let term = Termops.it_mkLambda_or_LetIn (Option.get app) (ctx' @ ctx) in Some term, termtype @@ -259,17 +266,19 @@ let new_instance ?(abstract=false) ?(global=false) ctx (instid, bk, cl) props evars := Typeclasses.resolve_typeclasses ~filter:Typeclasses.all_evars ~fail:false env !evars in - let termtype = Evarutil.nf_evar !evars termtype in + let _ = evars := Evarutil.nf_evar_map_undefined !evars in + let evm, nf = Evarutil.nf_evar_map_universes !evars in + let termtype = nf termtype in let _ = (* Check that the type is free of evars now. *) - Evarutil.check_evars env Evd.empty !evars termtype + Evarutil.check_evars env Evd.empty evm termtype in - let term = Option.map (Evarutil.nf_evar !evars) term in - let evm = Evarutil.nf_evar_map_undefined !evars in + let term = Option.map nf term in if not (Evd.has_undefined evm) && not (Option.is_empty term) then + let ctx = Evd.universe_context evm in declare_instance_constant k pri global imps ?hook id - (Option.get term,Declareops.no_seff) termtype + poly ctx (Option.get term) termtype else begin - let kind = Decl_kinds.Global, Decl_kinds.DefinitionBody Decl_kinds.Instance in + let kind = Decl_kinds.Global, poly, Decl_kinds.DefinitionBody Decl_kinds.Instance in if Flags.is_program_mode () then let hook vis gr = let cst = match gr with ConstRef kn -> kn | _ -> assert false in @@ -280,17 +289,18 @@ let new_instance ?(abstract=false) ?(global=false) ctx (instid, bk, cl) props match term with | Some t -> let obls, _, constr, typ = - Obligations.eterm_obligations env id !evars 0 t termtype + Obligations.eterm_obligations env id evm 0 t termtype in obls, Some constr, typ | None -> [||], None, termtype in + let ctx = Evd.get_universe_context_set evm in ignore (Obligations.add_definition id ?term:constr - typ ~kind:(Global,Instance) ~hook obls); + typ ctx ~kind:(Global,poly,Instance) ~hook obls); id else (Flags.silently (fun () -> - Lemmas.start_proof id kind termtype + Lemmas.start_proof id kind (termtype, Evd.get_universe_context_set evm) (fun _ -> instance_hook k pri global imps ?hook); (* spiwack: I don't know what to do with the status here. *) if not (Option.is_empty term) then @@ -315,7 +325,8 @@ let context l = let env = Global.env() in let evars = ref Evd.empty in let _, ((env', fullctx), impls) = interp_context_evars evars env l in - let fullctx = Evarutil.nf_rel_context_evar !evars fullctx in + let subst = Evarutil.evd_comb0 Evarutil.nf_evars_and_universes evars in + let fullctx = Context.map_rel_context subst fullctx in let ce t = Evarutil.check_evars env Evd.empty !evars t in let () = List.iter (fun (n, b, t) -> Option.iter ce b; ce t) fullctx in let ctx = @@ -323,13 +334,17 @@ let context l = with e when Errors.noncritical e -> error "Anonymous variables not allowed in contexts." in - let fn status (id, _, t) = + let uctx = Evd.get_universe_context_set !evars in + let fn status (id, b, t) = + let uctx = Universes.shrink_universe_context uctx (Universes.universes_of_constr t) in if Lib.is_modtype () && not (Lib.sections_are_opened ()) then - let decl = (ParameterEntry (None,t,None), IsAssumption Logical) in + let uctx = Univ.ContextSet.to_context uctx in + let decl = (ParameterEntry (None,false,(t,uctx),None), IsAssumption Logical) in let cst = Declare.declare_constant ~internal:Declare.KernelSilent id decl in match class_of_constr t with - | Some (rels, (tc, args) as _cl) -> - add_instance (Typeclasses.new_instance tc None false (ConstRef cst)); + | Some (rels, ((tc,_), args) as _cl) -> + add_instance (Typeclasses.new_instance tc None false (*FIXME*) + (Flags.use_polymorphic_flag ()) (ConstRef cst)); status (* declare_subclasses (ConstRef cst) cl *) | None -> status @@ -339,9 +354,9 @@ let context l = | _ -> false in let impl = List.exists test impls in - let decl = (Discharge, Definitional) in + let decl = (Discharge, (Flags.use_polymorphic_flag ()), Definitional) in let nstatus = - snd (Command.declare_assumption false decl t [] impl + snd (Command.declare_assumption false decl (t, uctx) [] impl Vernacexpr.NoInline (Loc.ghost, id)) in status && nstatus diff --git a/toplevel/classes.mli b/toplevel/classes.mli index de62ff369..4dd62ba9f 100644 --- a/toplevel/classes.mli +++ b/toplevel/classes.mli @@ -36,13 +36,16 @@ val declare_instance_constant : Impargs.manual_explicitation list -> (** implicits *) ?hook:(Globnames.global_reference -> unit) -> Id.t -> (** name *) - Entries.proof_output -> (** body *) + bool -> (* polymorphic *) + Univ.universe_context -> (* Universes *) + Constr.t -> (** body *) Term.types -> (** type *) Names.Id.t val new_instance : ?abstract:bool -> (** Not abstract by default. *) ?global:bool -> (** Not global by default. *) + Decl_kinds.polymorphic -> local_binder list -> typeclass_constraint -> constr_expr option -> diff --git a/toplevel/command.ml b/toplevel/command.ml index f41acaba2..d2111f0fb 100644 --- a/toplevel/command.ml +++ b/toplevel/command.ml @@ -56,8 +56,8 @@ let rec complete_conclusion a cs = function user_err_loc (loc,"", strbrk"Cannot infer the non constant arguments of the conclusion of " ++ pr_id cs ++ str "."); - let args = List.map (fun id -> CRef(Ident(loc,id))) params in - CAppExpl (loc,(None,Ident(loc,name)),List.rev args) + let args = List.map (fun id -> CRef(Ident(loc,id),None)) params in + CAppExpl (loc,(None,Ident(loc,name),None),List.rev args) | c -> c (* Commands of the interface *) @@ -74,29 +74,34 @@ let red_constant_entry n ce = function under_binders env (fst (reduction_of_red_expr env red)) n body,eff) } -let interp_definition bl red_option c ctypopt = +let interp_definition bl p red_option c ctypopt = let env = Global.env() in - let evdref = ref Evd.empty in + let evdref = ref (Evd.from_env env) in let impls, ((env_bl, ctx), imps1) = interp_context_evars evdref env bl in let nb_args = List.length ctx in let imps,ce = match ctypopt with None -> + let subst = evd_comb0 Evd.nf_univ_variables evdref in + let ctx = map_rel_context (Vars.subst_univs_constr subst) ctx in + let env_bl = push_rel_context ctx env in let c, imps2 = interp_constr_evars_impls ~impls evdref env_bl c in - let body = nf_evar !evdref (it_mkLambda_or_LetIn c ctx) in - imps1@(Impargs.lift_implicits nb_args imps2), - { const_entry_body = Future.from_val (body,Declareops.no_seff); - const_entry_secctx = None; - const_entry_type = None; - const_entry_opaque = false; - const_entry_inline_code = false; - const_entry_feedback = None; - } + let nf,subst = Evarutil.e_nf_evars_and_universes evdref in + let body = nf (it_mkLambda_or_LetIn c ctx) in + let vars = Universes.universes_of_constr body in + let ctx = Universes.restrict_universe_context + (Evd.get_universe_context_set !evdref) vars in + imps1@(Impargs.lift_implicits nb_args imps2), + definition_entry ~univs:(Univ.ContextSet.to_context ctx) ~poly:p body | Some ctyp -> let ty, impsty = interp_type_evars_impls ~impls evdref env_bl ctyp in + let subst = evd_comb0 Evd.nf_univ_variables evdref in + let ctx = map_rel_context (Vars.subst_univs_constr subst) ctx in + let env_bl = push_rel_context ctx env in let c, imps2 = interp_casted_constr_evars_impls ~impls evdref env_bl c ty in - let body = nf_evar !evdref (it_mkLambda_or_LetIn c ctx) in - let typ = nf_evar !evdref (it_mkProd_or_LetIn ty ctx) in + let nf, subst = Evarutil.e_nf_evars_and_universes evdref in + let body = nf (it_mkLambda_or_LetIn c ctx) in + let typ = nf (it_mkProd_or_LetIn ty ctx) in let beq b1 b2 = if b1 then b2 else not b2 in let impl_eq (x,y,z) (x',y',z') = beq x x' && beq y y' && beq z z' in (* Check that all implicit arguments inferable from the term @@ -108,14 +113,13 @@ let interp_definition bl red_option c ctypopt = then msg_warning (strbrk "Implicit arguments declaration relies on type." ++ spc () ++ strbrk "The term declares more implicits than the type here."); + let vars = Univ.LSet.union (Universes.universes_of_constr body) + (Universes.universes_of_constr typ) in + let ctx = Universes.restrict_universe_context + (Evd.get_universe_context_set !evdref) vars in imps1@(Impargs.lift_implicits nb_args impsty), - { const_entry_body = Future.from_val(body,Declareops.no_seff); - const_entry_secctx = None; - const_entry_type = Some typ; - const_entry_opaque = false; - const_entry_inline_code = false; - const_entry_feedback = None; - } + definition_entry ~types:typ ~poly:p + ~univs:(Univ.ContextSet.to_context ctx) body in red_constant_entry (rel_context_length ctx) ce red_option, !evdref, imps @@ -144,7 +148,7 @@ let declare_definition_hook = ref ignore let set_declare_definition_hook = (:=) declare_definition_hook let get_declare_definition_hook () = !declare_definition_hook -let declare_definition ident (local,k) ce imps hook = +let declare_definition ident (local, p, k) ce imps hook = let () = !declare_definition_hook ce in let r = match local with | Discharge when Lib.sections_are_opened () -> @@ -164,7 +168,7 @@ let declare_definition ident (local,k) ce imps hook = let _ = Obligations.declare_definition_ref := declare_definition let do_definition ident k bl red_option c ctypopt hook = - let (ce, evd, imps as def) = interp_definition bl red_option c ctypopt in + let (ce, evd, imps as def) = interp_definition bl (pi2 k) red_option c ctypopt in if Flags.is_program_mode () then let env = Global.env () in let c,sideff = Future.force ce.const_entry_body in @@ -177,16 +181,17 @@ let do_definition ident k bl red_option c ctypopt hook = let obls, _, c, cty = Obligations.eterm_obligations env ident evd 0 c typ in - ignore(Obligations.add_definition ident ~term:c cty ~implicits:imps ~kind:k ~hook obls) + let ctx = Evd.get_universe_context_set evd in + ignore(Obligations.add_definition ident ~term:c cty ctx ~implicits:imps ~kind:k ~hook obls) else let ce = check_definition def in ignore(declare_definition ident k ce imps (fun l r -> hook l r;r)) (* 2| Variable/Hypothesis/Parameter/Axiom declarations *) -let declare_assumption is_coe (local, kind) c imps impl nl (_,ident) = match local with +let declare_assumption is_coe (local,p,kind) (c,ctx) imps impl nl (_,ident) = match local with | Discharge when Lib.sections_are_opened () -> - let decl = (Lib.cwd(), SectionLocalAssum (c,impl), IsAssumption kind) in + let decl = (Lib.cwd(), SectionLocalAssum ((c,ctx),p,impl), IsAssumption kind) in let _ = declare_variable ident decl in let () = assumption_message ident in let () = @@ -196,8 +201,9 @@ let declare_assumption is_coe (local, kind) c imps impl nl (_,ident) = match loc in let r = VarRef ident in let () = Typeclasses.declare_instance None true r in - let () = if is_coe then Class.try_add_new_coercion r ~local:true in + let () = if is_coe then Class.try_add_new_coercion r ~local:true false in (r,true) + | Global | Local | Discharge -> let local = get_locality ident local in let inl = match nl with @@ -205,18 +211,25 @@ let declare_assumption is_coe (local, kind) c imps impl nl (_,ident) = match loc | DefaultInline -> Some (Flags.get_inline_level()) | InlineAt i -> Some i in - let decl = (ParameterEntry (None,c,inl), IsAssumption kind) in + let ctx = Univ.ContextSet.to_context ctx in + let decl = (ParameterEntry (None,p,(c,ctx),inl), IsAssumption kind) in let kn = declare_constant ident ~local decl in let gr = ConstRef kn in let () = maybe_declare_manual_implicits false gr imps in let () = assumption_message ident in let () = Typeclasses.declare_instance None false gr in - let () = if is_coe then Class.try_add_new_coercion gr local in + let () = if is_coe then Class.try_add_new_coercion gr local p in (gr,Lib.is_modtype_strict ()) +let declare_assumptions_hook = ref ignore +let set_declare_assumptions_hook = (:=) declare_assumptions_hook + let interp_assumption evdref env bl c = let c = prod_constr_expr c bl in - interp_type_evars_impls evdref env c + let ty, impls = interp_type_evars_impls evdref env c in + let evd, nf = nf_evars_and_universes !evdref in + let ctx = Evd.get_universe_context_set evd in + ((nf ty, ctx), impls) let declare_assumptions idl is_coe k c imps impl_is_on nl = let refs, status = @@ -229,16 +242,16 @@ let do_assumptions kind nl l = let env = Global.env () in let evdref = ref Evd.empty in let _,l = List.fold_map (fun env (is_coe,(idl,c)) -> - let t,imps = interp_assumption evdref env [] c in + let (t,ctx),imps = interp_assumption evdref env [] c in let env = push_named_context (List.map (fun (_,id) -> (id,None,t)) idl) env in - (env,((is_coe,idl),t,imps))) env l in + (env,((is_coe,idl),t,(ctx,imps)))) env l in let evd = solve_remaining_evars all_and_fail_flags env Evd.empty !evdref in let l = List.map (on_pi2 (nf_evar evd)) l in - snd (List.fold_left (fun (subst,status) ((is_coe,idl),t,imps) -> + snd (List.fold_left (fun (subst,status) ((is_coe,idl),t,(ctx,imps)) -> let t = replace_vars subst t in - let (refs,status') = declare_assumptions idl is_coe kind t imps false nl in - let subst' = List.map2 (fun (_,id) c -> (id,constr_of_global c)) idl refs in + let (refs,status') = declare_assumptions idl is_coe kind (t,ctx) imps false nl in + let subst' = List.map2 (fun (_,id) c -> (id,Universes.constr_of_global c)) idl refs in (subst'@subst, status' && status)) ([],true) l) (* 3a| Elimination schemes for mutual inductive definitions *) @@ -290,6 +303,23 @@ let prepare_param = function | (na,None,t) -> out_name na, LocalAssum t | (na,Some b,_) -> out_name na, LocalDef b + +let make_conclusion_flexible evdref ty = + if isArity ty then + let _, concl = destArity ty in + match concl with + | Type u -> + (match Univ.universe_level u with + | Some u -> evdref := Evd.make_flexible_variable !evdref true u + | None -> ()) + | _ -> () + else () + +let is_impredicative env u = + u = Prop Null || + (engagement env = Some Declarations.ImpredicativeSet && u = Prop Pos) + +(** Make the arity conclusion flexible to avoid generating an upper bound universe now. *) let interp_ind_arity evdref env ind = interp_type_evars_impls evdref env ind.ind_arity @@ -301,10 +331,88 @@ let interp_cstrs evdref env impls mldata arity ind = let ctyps'', cimpls = List.split (List.map (interp_type_evars_impls evdref env ~impls) ctyps') in (cnames, ctyps'', cimpls) -let interp_mutual_inductive (paramsl,indl) notations finite = +let sign_level env evd sign = + fst (List.fold_right + (fun (_,_,t as d) (lev,env) -> + let s = destSort (Reduction.whd_betadeltaiota env + (nf_evar evd (Retyping.get_type_of env evd t))) + in + let u = univ_of_sort s in + (Univ.sup u lev, push_rel d env)) + sign (Univ.type0m_univ,env)) + +let sup_list = List.fold_left Univ.sup Univ.type0m_univ + +let extract_level env evd tys = + let sorts = List.map (fun ty -> + let ctx, concl = Reduction.dest_prod_assum env ty in + sign_level env evd ctx) tys + in sup_list sorts + +let inductive_levels env evdref arities inds = + let destarities = List.map (Reduction.dest_arity env) arities in + let levels = List.map (fun (ctx,a) -> + if a = Prop Null then None + else Some (univ_of_sort a)) destarities + in + let cstrs_levels, min_levels, sizes = + CList.split3 + (List.map2 (fun (_,tys,_) (ctx,du) -> + let len = List.length tys in + let clev = extract_level env !evdref tys in + let minlev = + if len > 1 && not (is_impredicative env du) then + Univ.type0_univ + else Univ.type0m_univ + in + (clev, minlev, len)) inds destarities) + in + (* Take the transitive closure of the system of constructors *) + (* level constraints and remove the recursive dependencies *) + let levels' = Univ.solve_constraints_system (Array.of_list levels) + (Array.of_list cstrs_levels) (Array.of_list min_levels) + in + let evd = + CList.fold_left3 (fun evd cu (ctx,du) len -> + if is_impredicative env du then + (** Any product is allowed here. *) + evd + else (** If in a predicative sort, or asked to infer the type, + we take the max of: + - indices (if in indices-matter mode) + - constructors + - Type(1) if there is more than 1 constructor + *) + let evd = + (** Indices contribute. *) + if Indtypes.is_indices_matter () then ( + let ilev = sign_level env !evdref ctx in + Evd.set_leq_sort evd (Type ilev) du) + else evd + in + (** Constructors contribute. *) + let evd = + if Sorts.is_set du then + if not (Evd.check_leq evd cu Univ.type0_univ) then + raise (Indtypes.InductiveError Indtypes.LargeNonPropInductiveNotInType) + else evd + else Evd.set_leq_sort evd (Type cu) du + in + let evd = + if len >= 2 && Univ.is_type0m_univ cu then + (** "Polymorphic" type constraint and more than one constructor, + should not land in Prop. Add constraint only if it would + land in Prop directly (no informative arguments as well). *) + Evd.set_leq_sort evd (Prop Pos) du + else evd + in evd) + !evdref (Array.to_list levels') destarities sizes + in evdref := evd; arities + +let interp_mutual_inductive (paramsl,indl) notations poly finite = check_all_names_different indl; let env0 = Global.env() in - let evdref = ref Evd.empty in + let evdref = ref Evd.(from_env env0) in let _, ((env_params, ctx_params), userimpls) = interp_context_evars evdref env0 paramsl in @@ -316,12 +424,14 @@ let interp_mutual_inductive (paramsl,indl) notations finite = (* Interpret the arities *) let arities = List.map (interp_ind_arity evdref env_params) indl in + let fullarities = List.map (fun (c, _) -> it_mkProd_or_LetIn c ctx_params) arities in let env_ar = push_types env0 indnames fullarities in let env_ar_params = push_rel_context ctx_params env_ar in (* Compute interpretation metadatas *) - let indimpls = List.map (fun (_, impls) -> userimpls @ lift_implicits (rel_context_nhyps ctx_params) impls) arities in + let indimpls = List.map (fun (_, impls) -> userimpls @ + lift_implicits (rel_context_nhyps ctx_params) impls) arities in let arities = List.map fst arities in let impls = compute_internalization_env env0 (Inductive params) indnames fullarities indimpls in let mldatas = List.map2 (mk_mltype_data evdref env_params params) arities indnames in @@ -336,9 +446,24 @@ let interp_mutual_inductive (paramsl,indl) notations finite = (* Try further to solve evars, and instantiate them *) let sigma = solve_remaining_evars all_and_fail_flags env_params Evd.empty !evdref in - let constructors = List.map (fun (idl,cl,impsl) -> (idl,List.map (nf_evar sigma) cl,impsl)) constructors in - let ctx_params = Context.map_rel_context (nf_evar sigma) ctx_params in - let arities = List.map (nf_evar sigma) arities in + evdref := sigma; + (* Compute renewed arities *) + let nf,_ = e_nf_evars_and_universes evdref in + let arities = List.map nf arities in + let constructors = List.map (fun (idl,cl,impsl) -> (idl,List.map nf cl,impsl)) constructors in + let _ = List.iter (fun ty -> make_conclusion_flexible evdref ty) arities in + let arities = inductive_levels env_ar_params evdref arities constructors in + let nf',_ = e_nf_evars_and_universes evdref in + let nf x = nf' (nf x) in + let arities = List.map nf' arities in + let constructors = List.map (fun (idl,cl,impsl) -> (idl,List.map nf' cl,impsl)) constructors in + let ctx_params = map_rel_context nf ctx_params in + let evd = !evdref in + List.iter (check_evars env_params Evd.empty evd) arities; + iter_rel_context (check_evars env0 Evd.empty evd) ctx_params; + List.iter (fun (_,ctyps,_) -> + List.iter (check_evars env_ar_params Evd.empty evd) ctyps) + constructors; (* Build the inductive entries *) let entries = List.map3 (fun ind arity (cnames,ctypes,cimpls) -> { @@ -357,7 +482,9 @@ let interp_mutual_inductive (paramsl,indl) notations finite = { mind_entry_params = List.map prepare_param ctx_params; mind_entry_record = false; mind_entry_finite = finite; - mind_entry_inds = entries }, + mind_entry_inds = entries; + mind_entry_polymorphic = poly; + mind_entry_universes = Evd.universe_context evd }, impls (* Very syntactical equality *) @@ -412,16 +539,19 @@ type one_inductive_impls = Impargs.manual_explicitation list (* for inds *)* Impargs.manual_explicitation list list (* for constrs *) -let do_mutual_inductive indl finite = +type one_inductive_expr = + lident * local_binder list * constr_expr option * constructor_expr list + +let do_mutual_inductive indl poly finite = let indl,coes,ntns = extract_mutual_inductive_declaration_components indl in (* Interpret the types *) - let mie,impls = interp_mutual_inductive indl ntns finite in + let mie,impls = interp_mutual_inductive indl ntns poly finite in (* Declare the mutual inductive block with its associated schemes *) ignore (declare_mutual_inductive_with_eliminations UserVerbose mie impls); (* Declare the possible notations of inductive types *) List.iter Metasyntax.add_notation_interpretation ntns; (* Declare the coercions *) - List.iter (fun qid -> Class.try_add_new_coercion (locate qid) false) coes + List.iter (fun qid -> Class.try_add_new_coercion (locate qid) false poly) coes (* 3c| Fixpoints and co-fixpoints *) @@ -525,11 +655,14 @@ let interp_fix_body evdref env_rec impls (_,ctx) fix ccl = let build_fix_type (_,ctx) ccl = it_mkProd_or_LetIn ccl ctx -let declare_fix kind f def t imps = +let declare_fix (_,poly,_ as kind) ctx f def t imps = let ce = { const_entry_body = Future.from_val def; const_entry_secctx = None; const_entry_type = Some t; + const_entry_polymorphic = poly; + const_entry_universes = ctx; + const_entry_proj = None; const_entry_opaque = false; const_entry_inline_code = false; const_entry_feedback = None; @@ -576,7 +709,7 @@ let fix_sub_ref = make_ref fixsub_module "Fix_sub" let measure_on_R_ref = make_ref fixsub_module "MR" let well_founded = init_constant ["Init"; "Wf"] "well_founded" let mkSubset name typ prop = - mkApp ((delayed_force build_sigma).typ, + mkApp (Universes.constr_of_global (delayed_force build_sigma).typ, [| typ; mkLambda (name, typ, prop) |]) let sigT = Lazy.lazy_from_fun build_sigma_type @@ -591,15 +724,19 @@ let rec telescope = function List.fold_left (fun (ty, tys, (k, constr)) (n, b, t) -> let pred = mkLambda (n, t, ty) in - let sigty = mkApp ((Lazy.force sigT).typ, [|t; pred|]) in - let intro = mkApp ((Lazy.force sigT).intro, [|lift k t; lift k pred; mkRel k; constr|]) in + let ty = Universes.constr_of_global (Lazy.force sigT).typ in + let intro = Universes.constr_of_global (Lazy.force sigT).intro in + let sigty = mkApp (ty, [|t; pred|]) in + let intro = mkApp (intro, [|lift k t; lift k pred; mkRel k; constr|]) in (sigty, pred :: tys, (succ k, intro))) (t, [], (2, mkRel 1)) tl in let (last, subst) = List.fold_right2 (fun pred (n, b, t) (prev, subst) -> - let proj1 = applistc (Lazy.force sigT).proj1 [t; pred; prev] in - let proj2 = applistc (Lazy.force sigT).proj2 [t; pred; prev] in + let p1 = Universes.constr_of_global (Lazy.force sigT).proj1 in + let p2 = Universes.constr_of_global (Lazy.force sigT).proj2 in + let proj1 = applistc p1 [t; pred; prev] in + let proj2 = applistc p2 [t; pred; prev] in (lift 1 proj2, (n, Some proj1, t) :: subst)) (List.rev tys) tl (mkRel 1, []) in ty, ((n, Some last, t) :: subst), constr @@ -648,7 +785,7 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation = it_mkLambda_or_LetIn measure letbinders, it_mkLambda_or_LetIn measure binders in - let comb = constr_of_global (delayed_force measure_on_R_ref) in + let comb = Universes.constr_of_global (delayed_force measure_on_R_ref) in let wf_rel = mkApp (comb, [| argtyp; relargty; rel; measure |]) in let wf_rel_fun x y = mkApp (rel, [| subst1 x measure_body; @@ -663,7 +800,7 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation = in let intern_bl = wfarg 1 :: [arg] in let _intern_env = push_rel_context intern_bl env in - let proj = (delayed_force build_sigma).Coqlib.proj1 in + let proj = (*FIXME*)Universes.constr_of_global (delayed_force build_sigma).Coqlib.proj1 in let wfargpred = mkLambda (Name argid', argtyp, wf_rel_fun (mkRel 1) (mkRel 3)) in let projection = (* in wfarg :: arg :: before *) mkApp (proj, [| argtyp ; wfargpred ; mkRel 1 |]) @@ -676,7 +813,8 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation = let intern_fun_binder = (Name (add_suffix recname "'"), None, intern_fun_arity_prod) in let curry_fun = let wfpred = mkLambda (Name argid', argtyp, wf_rel_fun (mkRel 1) (mkRel (2 * len + 4))) in - let arg = mkApp ((delayed_force build_sigma).intro, [| argtyp; wfpred; lift 1 make; mkRel 1 |]) in + let intro = (*FIXME*)Universes.constr_of_global (delayed_force build_sigma).Coqlib.intro in + let arg = mkApp (intro, [| argtyp; wfpred; lift 1 make; mkRel 1 |]) in let app = mkApp (mkRel (2 * len + 2 (* recproof + orig binders + current binders *)), [| arg |]) in let rcurry = mkApp (rel, [| measure; lift len measure |]) in let lam = (Name (Id.of_string "recproof"), None, rcurry) in @@ -701,7 +839,7 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation = let intern_body_lam = it_mkLambda_or_LetIn intern_body (curry_fun :: lift_lets @ fun_bl) in let prop = mkLambda (Name argname, argtyp, top_arity_let) in let def = - mkApp (constr_of_global (delayed_force fix_sub_ref), + mkApp (Universes.constr_of_global (delayed_force fix_sub_ref), [| argtyp ; wf_rel ; Evarutil.e_new_evar evdref env ~src:(Loc.ghost, Evar_kinds.QuestionMark (Evar_kinds.Define false)) wf_proof; @@ -715,16 +853,20 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation = if List.length binders_rel > 1 then let name = add_suffix recname "_func" in let hook l gr = - let body = it_mkLambda_or_LetIn (mkApp (constr_of_global gr, [|make|])) binders_rel in + let body = it_mkLambda_or_LetIn (mkApp (Universes.constr_of_global gr, [|make|])) binders_rel in let ty = it_mkProd_or_LetIn top_arity binders_rel in let ce = { const_entry_body = Future.from_val (Evarutil.nf_evar !evdref body,Declareops.no_seff); const_entry_secctx = None; const_entry_type = Some ty; - const_entry_opaque = false; - const_entry_inline_code = false; + (* FIXME *) + const_entry_proj = None; + const_entry_polymorphic = false; + const_entry_universes = Evd.universe_context !evdref; const_entry_feedback = None; - } in + const_entry_opaque = false; + const_entry_inline_code = false} + in (** FIXME: include locality *) let c = Declare.declare_constant recname (DefinitionEntry ce, IsDefinition Definition) in let gr = ConstRef c in @@ -746,9 +888,9 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation = let evars, _, evars_def, evars_typ = Obligations.eterm_obligations env recname !evdref 0 fullcoqc fullctyp in - ignore(Obligations.add_definition - recname ~term:evars_def evars_typ evars ~hook) - + let ctx = Evd.get_universe_context_set !evdref in + ignore(Obligations.add_definition recname ~term:evars_def + evars_typ ctx evars ~hook) let interp_recursive isfix fixl notations = let env = Global.env() in @@ -794,8 +936,9 @@ let interp_recursive isfix fixl notations = (* Instantiate evars and check all are resolved *) let evd = consider_remaining_unif_problems env_rec !evdref in - let fixdefs = List.map (Option.map (nf_evar evd)) fixdefs in - let fixtypes = List.map (nf_evar evd) fixtypes in + let evd, nf = nf_evars_and_universes evd in + let fixdefs = List.map (Option.map nf) fixdefs in + let fixtypes = List.map nf fixtypes in let fixctxnames = List.map (fun (_,ctx) -> List.map pi1 ctx) fixctxs in (* Build the fix declaration block *) @@ -811,25 +954,25 @@ let check_recursive isfix env evd (fixnames,fixdefs,_) = let interp_fixpoint l ntns = let (env,_,evd),fix,info = interp_recursive true l ntns in check_recursive true env evd fix; - fix,info + (fix,Evd.get_universe_context_set evd,info) let interp_cofixpoint l ntns = let (env,_,evd),fix,info = interp_recursive false l ntns in check_recursive false env evd fix; - fix,info + fix,Evd.get_universe_context_set evd,info -let declare_fixpoint local ((fixnames,fixdefs,fixtypes),fiximps) indexes ntns = +let declare_fixpoint local poly ((fixnames,fixdefs,fixtypes),ctx,fiximps) indexes ntns = if List.exists Option.is_empty fixdefs then (* Some bodies to define by proof *) let thms = - List.map3 (fun id t (len,imps,_) -> (id,(t,(len,imps)))) fixnames fixtypes fiximps in + List.map3 (fun id t (len,imps,_) -> (id,((t,ctx),(len,imps)))) fixnames fixtypes fiximps in let init_tac = Some (List.map (Option.cata Tacmach.refine_no_check Tacticals.tclIDTAC) fixdefs) in let init_tac = Option.map (List.map Proofview.V82.tactic) init_tac in - Lemmas.start_proof_with_initialization (Global,DefinitionBody Fixpoint) + Lemmas.start_proof_with_initialization (Global,poly,DefinitionBody Fixpoint) (Some(false,indexes,init_tac)) thms None (fun _ _ -> ()) else begin (* We shortcut the proof process *) @@ -841,25 +984,27 @@ let declare_fixpoint local ((fixnames,fixdefs,fixtypes),fiximps) indexes ntns = let fixdecls = List.map_i (fun i _ -> mkFix ((indexes,i),fixdecls)) 0 fixnames in let fixdecls = List.map (fun c -> c, Declareops.no_seff) fixdecls in - ignore (List.map4 (declare_fix (local, Fixpoint)) fixnames fixdecls fixtypes fiximps); + let ctx = Univ.ContextSet.to_context ctx in + ignore (List.map4 (declare_fix (local, poly, Fixpoint) ctx) + fixnames fixdecls fixtypes fiximps); (* Declare the recursive definitions *) fixpoint_message (Some indexes) fixnames; end; (* Declare notations *) List.iter Metasyntax.add_notation_interpretation ntns -let declare_cofixpoint local ((fixnames,fixdefs,fixtypes),fiximps) ntns = +let declare_cofixpoint local poly ((fixnames,fixdefs,fixtypes),ctx,fiximps) ntns = if List.exists Option.is_empty fixdefs then (* Some bodies to define by proof *) let thms = - List.map3 (fun id t (len,imps,_) -> (id,(t,(len,imps)))) fixnames fixtypes fiximps in + List.map3 (fun id t (len,imps,_) -> (id,((t,ctx),(len,imps)))) fixnames fixtypes fiximps in let init_tac = Some (List.map (Option.cata Tacmach.refine_no_check Tacticals.tclIDTAC) fixdefs) in let init_tac = Option.map (List.map Proofview.V82.tactic) init_tac in - Lemmas.start_proof_with_initialization (Global,DefinitionBody CoFixpoint) + Lemmas.start_proof_with_initialization (Global,poly, DefinitionBody CoFixpoint) (Some(true,[],init_tac)) thms None (fun _ _ -> ()) else begin (* We shortcut the proof process *) @@ -868,7 +1013,9 @@ let declare_cofixpoint local ((fixnames,fixdefs,fixtypes),fiximps) ntns = let fixdecls = List.map_i (fun i _ -> mkCoFix (i,fixdecls)) 0 fixnames in let fixdecls = List.map (fun c-> c,Declareops.no_seff) fixdecls in let fiximps = List.map (fun (len,imps,idx) -> imps) fiximps in - ignore (List.map4 (declare_fix (local, CoFixpoint)) fixnames fixdecls fixtypes fiximps); + let ctx = Univ.ContextSet.to_context ctx in + ignore (List.map4 (declare_fix (local, poly, CoFixpoint) ctx) + fixnames fixdecls fixtypes fiximps); (* Declare the recursive definitions *) cofixpoint_message fixnames end; @@ -898,7 +1045,12 @@ let out_def = function | Some def -> def | None -> error "Program Fixpoint needs defined bodies." -let do_program_recursive local fixkind fixl ntns = +let collect_evars_of_term evd c ty = + let evars = Evar.Set.union (evars_of_term c) (evars_of_term ty) in + Evar.Set.fold (fun ev acc -> Evd.add acc ev (Evd.find_undefined evd ev)) + evars Evd.empty + +let do_program_recursive local p fixkind fixl ntns = let isfix = fixkind != Obligations.IsCoFixpoint in let (env, rec_sign, evd), fix, info = interp_recursive isfix fixl ntns @@ -934,13 +1086,14 @@ let do_program_recursive local fixkind fixl ntns = Pretyping.search_guard Loc.ghost (Global.env ()) possible_indexes fixdecls in List.iteri (fun i _ -> Inductive.check_fix env ((indexes,i),fixdecls)) fixl end in + let ctx = Evd.get_universe_context_set evd in let kind = match fixkind with - | Obligations.IsFixpoint _ -> (local, Fixpoint) - | Obligations.IsCoFixpoint -> (local, CoFixpoint) + | Obligations.IsFixpoint _ -> (local, p, Fixpoint) + | Obligations.IsCoFixpoint -> (local, p, CoFixpoint) in - Obligations.add_mutual_definitions defs ~kind ntns fixkind + Obligations.add_mutual_definitions defs ~kind ctx ntns fixkind -let do_program_fixpoint local l = +let do_program_fixpoint local poly l = let g = List.map (fun ((_,wf,_,_,_),_) -> wf) l in match g, l with | [(n, CWfRec r)], [(((_,id),_,bl,typ,def),ntn)] -> @@ -954,30 +1107,30 @@ let do_program_fixpoint local l = | [(n, CMeasureRec (m, r))], [(((_,id),_,bl,typ,def),ntn)] -> build_wellfounded (id, n, bl, typ, out_def def) - (Option.default (CRef lt_ref) r) m ntn + (Option.default (CRef (lt_ref,None)) r) m ntn | _, _ when List.for_all (fun (n, ro) -> ro == CStructRec) g -> let fixl,ntns = extract_fixpoint_components true l in let fixkind = Obligations.IsFixpoint g in - do_program_recursive local fixkind fixl ntns + do_program_recursive local poly fixkind fixl ntns | _, _ -> errorlabstrm "do_program_fixpoint" (str "Well-founded fixpoints not allowed in mutually recursive blocks") -let do_fixpoint local l = - if Flags.is_program_mode () then do_program_fixpoint local l +let do_fixpoint local poly l = + if Flags.is_program_mode () then do_program_fixpoint local poly l else let fixl, ntns = extract_fixpoint_components true l in let fix = interp_fixpoint fixl ntns in let possible_indexes = - List.map compute_possible_guardness_evidences (snd fix) in - declare_fixpoint local fix possible_indexes ntns + List.map compute_possible_guardness_evidences (pi3 fix) in + declare_fixpoint local poly fix possible_indexes ntns -let do_cofixpoint local l = +let do_cofixpoint local poly l = let fixl,ntns = extract_cofixpoint_components l in if Flags.is_program_mode () then - do_program_recursive local Obligations.IsCoFixpoint fixl ntns + do_program_recursive local poly Obligations.IsCoFixpoint fixl ntns else let cofix = interp_cofixpoint fixl ntns in - declare_cofixpoint local cofix ntns + declare_cofixpoint local poly cofix ntns diff --git a/toplevel/command.mli b/toplevel/command.mli index d2ebdc561..b2ba23ef2 100644 --- a/toplevel/command.mli +++ b/toplevel/command.mli @@ -29,7 +29,7 @@ val get_declare_definition_hook : unit -> (definition_entry -> unit) (** {6 Definitions/Let} *) val interp_definition : - local_binder list -> red_expr option -> constr_expr -> + local_binder list -> polymorphic -> red_expr option -> constr_expr -> constr_expr option -> definition_entry * Evd.evar_map * Impargs.manual_implicits val declare_definition : Id.t -> definition_kind -> @@ -42,16 +42,25 @@ val do_definition : Id.t -> definition_kind -> (** {6 Parameters/Assumptions} *) +(* val interp_assumption : env -> evar_map ref -> *) +(* local_binder list -> constr_expr -> *) +(* types Univ.in_universe_context_set * Impargs.manual_implicits *) + (** returns [false] if the assumption is neither local to a section, nor in a module type and meant to be instantiated. *) -val declare_assumption : coercion_flag -> assumption_kind -> types -> +val declare_assumption : coercion_flag -> assumption_kind -> + types Univ.in_universe_context_set -> Impargs.manual_implicits -> bool (** implicit *) -> Vernacexpr.inline -> variable Loc.located -> global_reference * bool -val do_assumptions : locality * assumption_object_kind -> +val do_assumptions : locality * polymorphic * assumption_object_kind -> Vernacexpr.inline -> simple_binder with_coercion list -> bool +(* val declare_assumptions : variable Loc.located list -> *) +(* coercion_flag -> assumption_kind -> types Univ.in_universe_context_set -> *) +(* Impargs.manual_implicits -> bool -> Vernacexpr.inline -> bool *) + (** {6 Inductive and coinductive types} *) (** Extracting the semantical components out of the raw syntax of mutual @@ -77,7 +86,7 @@ type one_inductive_impls = Impargs.manual_implicits list (** for constrs *) val interp_mutual_inductive : - structured_inductive_expr -> decl_notation list -> bool -> + structured_inductive_expr -> decl_notation list -> polymorphic -> bool(*finite*) -> mutual_inductive_entry * one_inductive_impls list (** Registering a mutual inductive definition together with its @@ -90,7 +99,7 @@ val declare_mutual_inductive_with_eliminations : (** Entry points for the vernacular commands Inductive and CoInductive *) val do_mutual_inductive : - (one_inductive_expr * decl_notation list) list -> bool -> unit + (one_inductive_expr * decl_notation list) list -> polymorphic -> bool -> unit (** {6 Fixpoints and cofixpoints} *) @@ -120,33 +129,38 @@ type recursive_preentry = val interp_fixpoint : structured_fixpoint_expr list -> decl_notation list -> - recursive_preentry * (Name.t list * Impargs.manual_implicits * int option) list + recursive_preentry * Univ.universe_context_set * + (Name.t list * Impargs.manual_implicits * int option) list val interp_cofixpoint : structured_fixpoint_expr list -> decl_notation list -> - recursive_preentry * (Name.t list * Impargs.manual_implicits * int option) list + recursive_preentry * Univ.universe_context_set * + (Name.t list * Impargs.manual_implicits * int option) list (** Registering fixpoints and cofixpoints in the environment *) val declare_fixpoint : - locality -> recursive_preentry * (Name.t list * Impargs.manual_implicits * int option) list -> + locality -> polymorphic -> + recursive_preentry * Univ.universe_context_set * + (Name.t list * Impargs.manual_implicits * int option) list -> lemma_possible_guards -> decl_notation list -> unit -val declare_cofixpoint : - locality -> recursive_preentry * (Name.t list * Impargs.manual_implicits * int option) list -> - decl_notation list -> unit +val declare_cofixpoint : locality -> polymorphic -> + recursive_preentry * Univ.universe_context_set * + (Name.t list * Impargs.manual_implicits * int option) list -> + decl_notation list -> unit (** Entry points for the vernacular commands Fixpoint and CoFixpoint *) val do_fixpoint : - locality -> (fixpoint_expr * decl_notation list) list -> unit + locality -> polymorphic -> (fixpoint_expr * decl_notation list) list -> unit val do_cofixpoint : - locality -> (cofixpoint_expr * decl_notation list) list -> unit + locality -> polymorphic -> (cofixpoint_expr * decl_notation list) list -> unit (** Utils *) val check_mutuality : Environ.env -> bool -> (Id.t * types) list -> unit -val declare_fix : definition_kind -> Id.t -> +val declare_fix : definition_kind -> Univ.universe_context -> Id.t -> Entries.proof_output -> types -> Impargs.manual_implicits -> global_reference diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 51dc8d5bb..d772171e5 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -382,6 +382,7 @@ let parse_args arglist = Serialize.document Xml_printer.to_string_fmt; exit 0 |"-ideslave" -> Flags.ide_slave := true |"-impredicative-set" -> set_engagement Declarations.ImpredicativeSet + |"-indices-matter" -> Indtypes.enforce_indices_matter () |"-just-parsing" -> Vernac.just_parsing := true |"-lazy-load-proofs" -> Flags.load_proofs := Flags.Lazy |"-m"|"--memory" -> memory_stat := true diff --git a/toplevel/discharge.ml b/toplevel/discharge.ml index b9ffbaea5..55475a378 100644 --- a/toplevel/discharge.ml +++ b/toplevel/discharge.ml @@ -69,14 +69,9 @@ let abstract_inductive hyps nparams inds = in (params',ind'') let refresh_polymorphic_type_of_inductive (_,mip) = - match mip.mind_arity with - | Monomorphic s -> - s.mind_user_arity - | Polymorphic ar -> - let ctx = List.rev mip.mind_arity_ctxt in - mkArity (List.rev ctx,Termops.new_Type_sort()) + mip.mind_arity.mind_user_arity -let process_inductive sechyps modlist mib = +let process_inductive (sechyps,abs_ctx) modlist mib = let nparams = mib.mind_nparams in let inds = Array.map_to_list @@ -90,7 +85,11 @@ let process_inductive sechyps modlist mib = mib.mind_packets in let sechyps' = map_named_context (expmod_constr modlist) sechyps in let (params',inds') = abstract_inductive sechyps' nparams inds in - { mind_entry_record = mib.mind_record; + let univs = Univ.UContext.union abs_ctx mib.mind_universes in + { mind_entry_record = mib.mind_record <> None; mind_entry_finite = mib.mind_finite; mind_entry_params = params'; - mind_entry_inds = inds' } + mind_entry_inds = inds'; + mind_entry_polymorphic = mib.mind_polymorphic; + mind_entry_universes = univs + } diff --git a/toplevel/discharge.mli b/toplevel/discharge.mli index 6cef31c8a..c074a1cc8 100644 --- a/toplevel/discharge.mli +++ b/toplevel/discharge.mli @@ -12,4 +12,4 @@ open Entries open Opaqueproof val process_inductive : - named_context -> work_list -> mutual_inductive_body -> mutual_inductive_entry + named_context Univ.in_universe_context -> work_list -> mutual_inductive_body -> mutual_inductive_entry diff --git a/toplevel/himsg.ml b/toplevel/himsg.ml index fd74f9c06..9d6e9756d 100644 --- a/toplevel/himsg.ml +++ b/toplevel/himsg.ml @@ -65,7 +65,7 @@ let contract3' env a b c = function contract3 env a b c, ConversionFailed (env',t1,t2) | NotSameArgSize | NotSameHead | NoCanonicalStructure | MetaOccurInBody _ | InstanceNotSameType _ - | UnifUnivInconsistency as x -> contract3 env a b c, x + | UnifUnivInconsistency _ as x -> contract3 env a b c, x (** Printers *) @@ -143,9 +143,15 @@ let rec pr_disjunction pr = function | a::l -> pr a ++ str "," ++ spc () ++ pr_disjunction pr l | [] -> assert false +let pr_puniverses f env (c,u) = + f env c ++ + (if Flags.is_universe_polymorphism () && not (Univ.Instance.is_empty u) then + str"(*" ++ Univ.Instance.pr u ++ str"*)" + else mt()) + let explain_elim_arity env ind sorts c pj okinds = let env = make_all_name_different env in - let pi = pr_inductive env ind in + let pi = pr_inductive env (fst ind) in let pc = pr_lconstr_env env c in let msg = match okinds with | Some(kp,ki,explanation) -> @@ -200,14 +206,14 @@ let explain_number_branches env sigma cj expn = str "expects " ++ int expn ++ str " branches." let explain_ill_formed_branch env sigma c ci actty expty = - let simp t = Reduction.nf_betaiota (Evarutil.nf_evar sigma t) in + let simp t = Reduction.nf_betaiota env (Evarutil.nf_evar sigma t) in let c = Evarutil.nf_evar sigma c in let env = make_all_name_different env in let pc = pr_lconstr_env env c in let pa, pe = pr_explicit env (simp actty) (simp expty) in strbrk "In pattern-matching on term" ++ brk(1,1) ++ pc ++ spc () ++ strbrk "the branch for constructor" ++ spc () ++ - quote (pr_constructor env ci) ++ + quote (pr_puniverses pr_constructor env ci) ++ spc () ++ str "has type" ++ brk(1,1) ++ pa ++ spc () ++ str "which should be" ++ brk(1,1) ++ pe ++ str "." @@ -260,8 +266,12 @@ let explain_unification_error env sigma p1 p2 = function quote (pr_existential_key evk) ++ str ":" ++ spc () ++ str "cannot unify" ++ t ++ spc () ++ str "and" ++ spc () ++ u ++ str ")" - | UnifUnivInconsistency -> - spc () ++ str "(Universe inconsistency)" + | UnifUnivInconsistency p -> + if !Constrextern.print_universes then + spc () ++ str "(Universe inconsistency: " ++ + Univ.explain_universe_inconsistency p ++ str")" + else + spc () ++ str "(Universe inconsistency)" let explain_actual_type env sigma j t reason = let env = make_all_name_different env in @@ -513,7 +523,7 @@ let explain_var_not_found env id = spc () ++ str "was not found" ++ spc () ++ str "in the current" ++ spc () ++ str "environment" ++ str "." -let explain_wrong_case_info env ind ci = +let explain_wrong_case_info env (ind,u) ci = let pi = pr_inductive (Global.env()) ind in if eq_ind ci.ci_ind ind then str "Pattern-matching expression on an object of inductive type" ++ @@ -584,6 +594,10 @@ let explain_non_linear_unification env m t = strbrk " which would require to abstract twice on " ++ pr_lconstr_env env t ++ str "." +let explain_unsatisfied_constraints env cst = + strbrk "Unsatisfied constraints: " ++ Univ.pr_constraints cst ++ + spc () ++ str "(maybe a bugged tactic)." + let explain_type_error env sigma err = let env = make_all_name_different env in match err with @@ -619,6 +633,8 @@ let explain_type_error env sigma err = explain_ill_typed_rec_body env sigma i lna vdefj vargs | WrongCaseInfo (ind,ci) -> explain_wrong_case_info env ind ci + | UnsatisfiedConstraints cst -> + explain_unsatisfied_constraints env cst let explain_pretype_error env sigma err = let env = Evarutil.env_nf_betaiotaevar sigma env in @@ -998,7 +1014,7 @@ let error_not_allowed_case_analysis isrec kind i = str (if isrec then "Induction" else "Case analysis") ++ strbrk " on sort " ++ pr_sort kind ++ strbrk " is not allowed for inductive definition " ++ - pr_inductive (Global.env()) i ++ str "." + pr_inductive (Global.env()) (fst i) ++ str "." let error_not_mutual_in_scheme ind ind' = if eq_ind ind ind' then diff --git a/toplevel/ind_tables.ml b/toplevel/ind_tables.ml index f5ee027f1..2a408e03d 100644 --- a/toplevel/ind_tables.ml +++ b/toplevel/ind_tables.ml @@ -27,13 +27,18 @@ open Decl_kinds (**********************************************************************) (* Registering schemes in the environment *) -type mutual_scheme_object_function = mutual_inductive -> constr array * Declareops.side_effects -type individual_scheme_object_function = inductive -> constr * Declareops.side_effects + +type mutual_scheme_object_function = + mutual_inductive -> constr array Evd.in_evar_universe_context * Declareops.side_effects +type individual_scheme_object_function = + inductive -> constr Evd.in_evar_universe_context * Declareops.side_effects type 'a scheme_kind = string let scheme_map = Summary.ref Indmap.empty ~name:"Schemes" +let pr_scheme_kind = Pp.str + let cache_one_scheme kind (ind,const) = let map = try Indmap.find ind !scheme_map with Not_found -> String.Map.empty in scheme_map := Indmap.add ind (String.Map.add kind const map) !scheme_map @@ -41,9 +46,9 @@ let cache_one_scheme kind (ind,const) = let cache_scheme (_,(kind,l)) = Array.iter (cache_one_scheme kind) l -let subst_one_scheme subst ((mind,i),const) = +let subst_one_scheme subst (ind,const) = (* Remark: const is a def: the result of substitution is a constant *) - ((subst_ind subst mind,i),fst (subst_con subst const)) + (subst_ind subst ind,subst_constant subst const) let subst_scheme (subst,(kind,l)) = (kind,Array.map (subst_one_scheme subst) l) @@ -67,8 +72,8 @@ type individual type mutual type scheme_object_function = - | MutualSchemeFunction of (mutual_inductive -> constr array * Declareops.side_effects) - | IndividualSchemeFunction of (inductive -> constr * Declareops.side_effects) + | MutualSchemeFunction of mutual_scheme_object_function + | IndividualSchemeFunction of individual_scheme_object_function let scheme_object_table = (Hashtbl.create 17 : (string, string * scheme_object_function) Hashtbl.t) @@ -111,31 +116,37 @@ let compute_name internal id = | KernelSilent -> Namegen.next_ident_away_from (add_prefix "internal_" id) is_visible_name -let define internal id c = +let define internal id c p univs = let fd = declare_constant ~internal in let id = compute_name internal id in + let ctx = Evd.normalize_evar_universe_context univs in + let c = Vars.subst_univs_fn_constr + (Universes.make_opt_subst (Evd.evar_universe_context_subst ctx)) c in let entry = { const_entry_body = Future.from_val (c,Declareops.no_seff); const_entry_secctx = None; const_entry_type = None; + const_entry_proj = None; + const_entry_polymorphic = p; + const_entry_universes = Evd.evar_context_universe_context ctx; const_entry_opaque = false; const_entry_inline_code = false; const_entry_feedback = None; } in let kn = fd id (DefinitionEntry entry, Decl_kinds.IsDefinition Scheme) in let () = match internal with - | KernelSilent -> () - | _-> definition_message id + | KernelSilent -> () + | _-> definition_message id in kn let define_individual_scheme_base kind suff f internal idopt (mind,i as ind) = - let c, eff = f ind in + let (c, ctx), eff = f ind in let mib = Global.lookup_mind mind in let id = match idopt with | Some id -> id | None -> add_suffix mib.mind_packets.(i).mind_typename suff in - let const = define internal id c in + let const = define internal id c mib.mind_polymorphic ctx in declare_scheme kind [|ind,const|]; const, Declareops.cons_side_effects (Safe_typing.sideff_of_scheme kind (Global.safe_env()) [ind,const]) eff @@ -147,12 +158,14 @@ let define_individual_scheme kind internal names (mind,i as ind) = define_individual_scheme_base kind s f internal names ind let define_mutual_scheme_base kind suff f internal names mind = - let cl, eff = f mind in + let (cl, ctx), eff = f mind in let mib = Global.lookup_mind mind in let ids = Array.init (Array.length mib.mind_packets) (fun i -> try Int.List.assoc i names with Not_found -> add_suffix mib.mind_packets.(i).mind_typename suff) in - let consts = Array.map2 (define internal) ids cl in + + let consts = Array.map2 (fun id cl -> + define internal id cl mib.mind_polymorphic ctx) ids cl in let schemes = Array.mapi (fun i cst -> ((mind,i),cst)) consts in declare_scheme kind schemes; consts, @@ -185,4 +198,3 @@ let find_scheme kind (mind,i as ind) = let check_scheme kind ind = try let _ = find_scheme_on_env_too kind ind in true with Not_found -> false - diff --git a/toplevel/ind_tables.mli b/toplevel/ind_tables.mli index d57f1556d..7f84843a9 100644 --- a/toplevel/ind_tables.mli +++ b/toplevel/ind_tables.mli @@ -19,9 +19,9 @@ type individual type 'a scheme_kind type mutual_scheme_object_function = - mutual_inductive -> constr array * Declareops.side_effects + mutual_inductive -> constr array Evd.in_evar_universe_context * Declareops.side_effects type individual_scheme_object_function = - inductive -> constr * Declareops.side_effects + inductive -> constr Evd.in_evar_universe_context * Declareops.side_effects (** Main functions to register a scheme builder *) @@ -49,3 +49,6 @@ val define_mutual_scheme : mutual scheme_kind -> Declare.internal_flag (** inter val find_scheme : 'a scheme_kind -> inductive -> constant * Declareops.side_effects val check_scheme : 'a scheme_kind -> inductive -> bool + + +val pr_scheme_kind : 'a scheme_kind -> Pp.std_ppcmds diff --git a/toplevel/indschemes.ml b/toplevel/indschemes.ml index 2cc98feea..c139f1910 100644 --- a/toplevel/indschemes.ml +++ b/toplevel/indschemes.ml @@ -113,13 +113,16 @@ let _ = (* Util *) -let define id internal c t = +let define id internal ctx c t = let f = declare_constant ~internal in let kn = f id (DefinitionEntry { const_entry_body = c; const_entry_secctx = None; const_entry_type = t; + const_entry_proj = None; + const_entry_polymorphic = true; + const_entry_universes = Evd.universe_context ctx; (* FIXME *) const_entry_opaque = false; const_entry_inline_code = false; const_entry_feedback = None; @@ -292,6 +295,7 @@ let declare_sym_scheme ind = (* Scheme command *) +let smart_global_inductive y = smart_global_inductive y let rec split_scheme l = let env = Global.env() in match l with @@ -311,7 +315,7 @@ requested let names inds recs isdep y z = let ind = smart_global_inductive y in let sort_of_ind = inductive_sort_family (snd (lookup_mind_specif env ind)) in - let z' = family_of_sort (interp_sort z) in + let z' = interp_elimination_sort z in let suffix = ( match sort_of_ind with | InProp -> @@ -345,19 +349,20 @@ requested let do_mutual_induction_scheme lnamedepindsort = let lrecnames = List.map (fun ((_,f),_,_,_) -> f) lnamedepindsort - and sigma = Evd.empty and env0 = Global.env() in - let lrecspec = - List.map - (fun (_,dep,ind,sort) -> (ind,dep,interp_elimination_sort sort)) - lnamedepindsort + let sigma, lrecspec = + List.fold_left + (fun (evd, l) (_,dep,ind,sort) -> + let evd, indu = Evd.fresh_inductive_instance env0 evd ind in + (evd, (indu,dep,interp_elimination_sort sort) :: l)) + (Evd.from_env env0,[]) lnamedepindsort in - let listdecl = Indrec.build_mutual_induction_scheme env0 sigma lrecspec in + let sigma, listdecl = Indrec.build_mutual_induction_scheme env0 sigma lrecspec in let declare decl fi lrecref = - let decltype = Retyping.get_type_of env0 Evd.empty decl in - let decltype = refresh_universes decltype in + let decltype = Retyping.get_type_of env0 sigma decl in + (* let decltype = refresh_universes decltype in *) let proof_output = Future.from_val (decl,Declareops.no_seff) in - let cst = define fi UserVerbose proof_output (Some decltype) in + let cst = define fi UserVerbose sigma proof_output (Some decltype) in ConstRef cst :: lrecref in let _ = List.fold_right2 declare listdecl lrecnames [] in @@ -407,7 +412,9 @@ let fold_left' f = function | hd :: tl -> List.fold_left f hd tl let build_combined_scheme env schemes = - let defs = List.map (fun cst -> (cst, Typeops.type_of_constant env cst)) schemes in + let defs = List.map (fun cst -> (* FIXME *) + let evd, c = Evd.fresh_constant_instance env Evd.empty cst in + (c, Typeops.type_of_constant_in env c)) schemes in (* let nschemes = List.length schemes in *) let find_inductive ty = let (ctx, arity) = decompose_prod ty in @@ -415,7 +422,7 @@ let build_combined_scheme env schemes = match kind_of_term last with | App (ind, args) -> let ind = destInd ind in - let (_,spec) = Inductive.lookup_mind_specif env ind in + let (_,spec) = Inductive.lookup_mind_specif env (fst ind) in ctx, ind, spec.mind_nrealargs | _ -> ctx, destInd last, 0 in @@ -426,8 +433,8 @@ let build_combined_scheme env schemes = let coqand = Coqlib.build_coq_and () and coqconj = Coqlib.build_coq_conj () in let relargs = rel_vect 0 prods in let concls = List.rev_map - (fun (cst, t) -> - mkApp(mkConst cst, relargs), + (fun (cst, t) -> (* FIXME *) + mkApp(mkConstU cst, relargs), snd (decompose_prod_n prods t)) defs in let concl_bod, concl_typ = fold_left' @@ -451,10 +458,9 @@ let do_combined_scheme name schemes = with Not_found -> error ((string_of_qualid (snd qualid))^" is not declared.")) schemes in - let env = Global.env () in - let body,typ = build_combined_scheme env csts in + let body,typ = build_combined_scheme (Global.env ()) csts in let proof_output = Future.from_val (body,Declareops.no_seff) in - ignore (define (snd name) UserVerbose proof_output (Some typ)); + ignore (define (snd name) UserVerbose Evd.empty proof_output (Some typ)); fixpoint_message None [snd name] (**********************************************************************) @@ -464,7 +470,7 @@ let map_inductive_block f kn n = for i=0 to n-1 do f (kn,i) done let declare_default_schemes kn = let mib = Global.lookup_mind kn in let n = Array.length mib.mind_packets in - if !elim_flag && (not mib.mind_record || !record_elim_flag) then + if !elim_flag && (mib.mind_record = None || !record_elim_flag) then declare_induction_schemes kn; if !case_flag then map_inductive_block declare_one_case_analysis_scheme kn n; if is_eq_flag() then try_declare_beq_scheme kn; diff --git a/toplevel/metasyntax.ml b/toplevel/metasyntax.ml index 761f9c214..3b86cf72f 100644 --- a/toplevel/metasyntax.ml +++ b/toplevel/metasyntax.ml @@ -1269,7 +1269,7 @@ let add_notation local c ((loc,df),modifiers) sc = (* Infix notations *) -let inject_var x = CRef (Ident (Loc.ghost, Id.of_string x)) +let inject_var x = CRef (Ident (Loc.ghost, Id.of_string x),None) let add_infix local ((loc,inf),modifiers) pr sc = check_infix_modifiers modifiers; @@ -1323,7 +1323,7 @@ let add_class_scope scope cl = (* Check if abbreviation to a name and avoid early insertion of maximal implicit arguments *) let try_interp_name_alias = function - | [], CRef ref -> intern_reference ref + | [], CRef (ref,_) -> intern_reference ref | _ -> raise Not_found let add_syntactic_definition ident (vars,c) local onlyparse = diff --git a/toplevel/obligations.ml b/toplevel/obligations.ml index d772af3c1..d937c400a 100644 --- a/toplevel/obligations.ml +++ b/toplevel/obligations.ml @@ -21,7 +21,7 @@ open Pp open Errors open Util -let declare_fix_ref = ref (fun _ _ _ _ _ -> assert false) +let declare_fix_ref = ref (fun _ _ _ _ _ _ -> assert false) let declare_definition_ref = ref (fun _ _ _ _ _ -> assert false) let trace s = @@ -298,11 +298,15 @@ type obligation_info = (Names.Id.t * Term.types * Evar_kinds.t Loc.located * Evar_kinds.obligation_definition_status * Int.Set.t * unit Proofview.tactic option) array +type 'a obligation_body = + | DefinedObl of 'a + | TermObl of constr + type obligation = { obl_name : Id.t; obl_type : types; obl_location : Evar_kinds.t Loc.located; - obl_body : constr option; + obl_body : constant obligation_body option; obl_status : Evar_kinds.obligation_definition_status; obl_deps : Int.Set.t; obl_tac : unit Proofview.tactic option; @@ -320,6 +324,8 @@ type program_info = { prg_name: Id.t; prg_body: constr; prg_type: constr; + prg_ctx: Univ.universe_context_set; + prg_subst : Universes.universe_opt_subst; prg_obligations: obligations; prg_deps : Id.t list; prg_fixkind : fixpoint_kind option ; @@ -383,27 +389,43 @@ let _ = let evar_of_obligation o = make_evar (Global.named_context_val ()) o.obl_type -let get_obligation_body expand obl = - let c = Option.get obl.obl_body in +let get_body subst obl = + match obl.obl_body with + | None -> assert false + | Some (DefinedObl c) -> + let _, ctx = Environ.constant_type_in_ctx (Global.env ()) c in + let pc = subst_univs_fn_puniverses (Univ.level_subst_of subst) (c, Univ.UContext.instance ctx) in + DefinedObl pc + | Some (TermObl c) -> + TermObl (subst_univs_fn_constr subst c) + +let get_obligation_body expand subst obl = + let c = get_body subst obl in + let c' = if expand && obl.obl_status == Evar_kinds.Expand then - match kind_of_term c with - | Const c -> constant_value (Global.env ()) c - | _ -> c - else c - -let obl_substitution expand obls deps = + (match c with + | DefinedObl pc -> constant_value_in (Global.env ()) pc + | TermObl c -> c) + else (match c with + | DefinedObl pc -> mkConstU pc + | TermObl c -> c) + in c' + +let obl_substitution expand subst obls deps = Int.Set.fold (fun x acc -> let xobl = obls.(x) in let oblb = - try get_obligation_body expand xobl + try get_obligation_body expand subst xobl with e when Errors.noncritical e -> assert false in (xobl.obl_name, (xobl.obl_type, oblb)) :: acc) deps [] -let subst_deps expand obls deps t = - let subst = obl_substitution expand obls deps in - Vars.replace_vars (List.map (fun (n, (_, b)) -> n, b) subst) t +let subst_deps expand subst obls deps t = + let subst = Universes.make_opt_subst subst in + let osubst = obl_substitution expand subst obls deps in + Vars.subst_univs_fn_constr subst + (Vars.replace_vars (List.map (fun (n, (_, b)) -> n, b) osubst) t) let rec prod_app t n = match kind_of_term (strip_outer_cast t) with @@ -431,17 +453,18 @@ let replace_appvars subst = in map_constr aux let subst_prog expand obls ints prg = - let subst = obl_substitution expand obls ints in + let usubst = Universes.make_opt_subst prg.prg_subst in + let subst = obl_substitution expand usubst obls ints in if get_hide_obligations () then (replace_appvars subst prg.prg_body, - replace_appvars subst (Termops.refresh_universes prg.prg_type)) + replace_appvars subst ((* Termops.refresh_universes *) prg.prg_type)) else let subst' = List.map (fun (n, (_, b)) -> n, b) subst in (Vars.replace_vars subst' prg.prg_body, - Vars.replace_vars subst' (Termops.refresh_universes prg.prg_type)) + Vars.replace_vars subst' ((* Termops.refresh_universes *) prg.prg_type)) -let subst_deps_obl obls obl = - let t' = subst_deps true obls obl.obl_deps obl.obl_type in +let subst_deps_obl subst obls obl = + let t' = subst_deps true subst obls obl.obl_deps obl.obl_type in { obl with obl_type = t' } module ProgMap = Map.Make(Id) @@ -509,6 +532,9 @@ let declare_definition prg = { const_entry_body = Future.from_val (body,Declareops.no_seff); const_entry_secctx = None; const_entry_type = Some typ; + const_entry_proj = None; + const_entry_polymorphic = pi2 prg.prg_kind; + const_entry_universes = Univ.ContextSet.to_context prg.prg_ctx; const_entry_opaque = false; const_entry_inline_code = false; const_entry_feedback = None; @@ -556,10 +582,9 @@ let declare_mutual_definition l = let fixkind = Option.get first.prg_fixkind in let arrrec, recvec = Array.of_list fixtypes, Array.of_list fixdefs in let fixdecls = (Array.of_list (List.map (fun x -> Name x.prg_name) l), arrrec, recvec) in + let (local,poly,kind) = first.prg_kind in let fixnames = first.prg_deps in - let kind = - fst first.prg_kind, - if fixkind != IsCoFixpoint then Fixpoint else CoFixpoint in + let kind = if fixkind != IsCoFixpoint then Fixpoint else CoFixpoint in let indexes, fixdecls = match fixkind with | IsFixpoint wfl -> @@ -578,13 +603,15 @@ let declare_mutual_definition l = mkCoFix (i,fixdecls),Declareops.no_seff) 0 l in (* Declare the recursive definitions *) - let kns = List.map4 (!declare_fix_ref kind) fixnames fixdecls fixtypes fiximps in + let ctx = Univ.ContextSet.to_context first.prg_ctx in + let kns = List.map4 (!declare_fix_ref (local, poly, kind) ctx) + fixnames fixdecls fixtypes fiximps in (* Declare notations *) List.iter Metasyntax.add_notation_interpretation first.prg_notations; Declare.recursive_message (fixkind != IsCoFixpoint) indexes fixnames; let gr = List.hd kns in let kn = match gr with ConstRef kn -> kn | _ -> assert false in - first.prg_hook (fst first.prg_kind) gr; + first.prg_hook local gr; List.iter progmap_remove l; kn let shrink_body c = @@ -597,20 +624,25 @@ let shrink_body c = (b, 1, []) ctx in List.map (fun (c,t) -> (c,None,t)) ctx, b', Array.of_list args -let declare_obligation prg obl body = +let declare_obligation prg obl body uctx = let body = prg.prg_reduce body in let ty = prg.prg_reduce obl.obl_type in match obl.obl_status with - | Evar_kinds.Expand -> { obl with obl_body = Some body } + | Evar_kinds.Expand -> { obl with obl_body = Some (TermObl body) } | Evar_kinds.Define opaque -> let opaque = if get_proofs_transparency () then false else opaque in + let poly = pi2 prg.prg_kind in let ctx, body, args = - if get_shrink_obligations () then shrink_body body else [], body, [||] + if get_shrink_obligations () && not poly then + shrink_body body else [], body, [||] in let ce = { const_entry_body = Future.from_val(body,Declareops.no_seff); const_entry_secctx = None; const_entry_type = if List.is_empty ctx then Some ty else None; + const_entry_proj = None; + const_entry_polymorphic = poly; + const_entry_universes = uctx; const_entry_opaque = opaque; const_entry_inline_code = false; const_entry_feedback = None; @@ -623,9 +655,13 @@ let declare_obligation prg obl body = Auto.add_hints false [Id.to_string prg.prg_name] (Auto.HintsUnfoldEntry [EvalConstRef constant]); definition_message obl.obl_name; - { obl with obl_body = Some (it_mkLambda_or_LetIn (mkApp (mkConst constant, args)) ctx) } + { obl with obl_body = + if poly then + Some (DefinedObl constant) + else + Some (TermObl (it_mkLambda_or_LetIn (mkApp (mkConst constant, args)) ctx)) } -let init_prog_info n b t deps fixkind notations obls impls k reduce hook = +let init_prog_info n b t ctx deps fixkind notations obls impls kind reduce hook = let obls', b = match b with | None -> @@ -645,9 +681,10 @@ let init_prog_info n b t deps fixkind notations obls impls k reduce hook = obls, b in { prg_name = n ; prg_body = b; prg_type = reduce t; + prg_ctx = ctx; prg_subst = Univ.LMap.empty; prg_obligations = (obls', Array.length obls'); prg_deps = deps; prg_fixkind = fixkind ; prg_notations = notations ; - prg_implicits = impls; prg_kind = k; prg_reduce = reduce; + prg_implicits = impls; prg_kind = kind; prg_reduce = reduce; prg_hook = hook; } let get_prog name = @@ -734,14 +771,14 @@ let dependencies obls n = obls; !res -let goal_kind = Decl_kinds.Local, Decl_kinds.DefinitionBody Decl_kinds.Definition +let goal_kind poly = Decl_kinds.Local, poly, Decl_kinds.DefinitionBody Decl_kinds.Definition -let goal_proof_kind = Decl_kinds.Local, Decl_kinds.Proof Decl_kinds.Lemma +let goal_proof_kind poly = Decl_kinds.Local, poly, Decl_kinds.Proof Decl_kinds.Lemma -let kind_of_opacity o = +let kind_of_obligation poly o = match o with - | Evar_kinds.Define false | Evar_kinds.Expand -> goal_kind - | _ -> goal_proof_kind + | Evar_kinds.Define false | Evar_kinds.Expand -> goal_kind poly + | _ -> goal_proof_kind poly let not_transp_msg = str "Obligation should be transparent but was declared opaque." ++ spc () ++ @@ -755,17 +792,37 @@ let rec string_of_list sep f = function | x :: ((y :: _) as tl) -> f x ^ sep ^ string_of_list sep f tl (* Solve an obligation using tactics, return the corresponding proof term *) -let solve_by_tac evi t = + +let solve_by_tac evi t poly subst ctx = let id = Id.of_string "H" in + let concl = Universes.subst_opt_univs_constr subst evi.evar_concl in (* spiwack: the status is dropped *) - let (entry,_) = Pfedit.build_constant_by_tactic - id ~goal_kind evi.evar_hyps evi.evar_concl (Tacticals.New.tclCOMPLETE t) in + let (entry,_,subst) = Pfedit.build_constant_by_tactic + id ~goal_kind:(goal_kind poly) evi.evar_hyps (concl, ctx) (Tacticals.New.tclCOMPLETE t) in let env = Global.env () in let entry = Term_typing.handle_side_effects env entry in let body, eff = Future.force entry.Entries.const_entry_body in assert(Declareops.side_effects_is_empty eff); Inductiveops.control_only_guard (Global.env ()) body; - body + body, subst, entry.Entries.const_entry_universes + + (* try *) + (* let substref = ref (Univ.LMap.empty, Univ.UContext.empty) in *) + (* Pfedit.start_proof id (goal_kind poly) evi.evar_hyps *) + (* (Universes.subst_opt_univs_constr subst evi.evar_concl, ctx) *) + (* (fun subst-> substref:=subst; fun _ _ -> ()); *) + (* Pfedit.by (tclCOMPLETE t); *) + (* let _,(const,_,_,_) = Pfedit.cook_proof ignore in *) + (* Pfedit.delete_current_proof (); *) + (* Inductiveops.control_only_guard (Global.env ()) *) + (* const.Entries.const_entry_body; *) + (* let subst, ctx = !substref in *) + (* subst_univs_fn_constr (Universes.make_opt_subst subst) const.Entries.const_entry_body, *) + (* subst, const.Entries.const_entry_universes *) + (* with reraise -> *) + (* let reraise = Errors.push reraise in *) + (* Pfedit.delete_current_proof(); *) + (* raise reraise *) let rec solve_obligation prg num tac = let user_num = succ num in @@ -776,9 +833,12 @@ let rec solve_obligation prg num tac = else match deps_remaining obls obl.obl_deps with | [] -> - let obl = subst_deps_obl obls obl in - Lemmas.start_proof obl.obl_name (kind_of_opacity obl.obl_status) obl.obl_type - (fun strength gr -> + let ctx = prg.prg_ctx in + let obl = subst_deps_obl prg.prg_subst obls obl in + let kind = kind_of_obligation (pi2 prg.prg_kind) obl.obl_status in + Lemmas.start_proof obl.obl_name kind + (Universes.subst_opt_univs_constr prg.prg_subst obl.obl_type, ctx) + (fun strength gr -> let cst = match gr with ConstRef cst -> cst | _ -> assert false in let obl = let transparent = evaluable_constant cst (Global.env ()) in @@ -786,10 +846,10 @@ let rec solve_obligation prg num tac = match obl.obl_status with | Evar_kinds.Expand -> if not transparent then error_not_transp () - else constant_value (Global.env ()) cst + else DefinedObl cst | Evar_kinds.Define opaque -> if not opaque && not transparent then error_not_transp () - else Globnames.constr_of_global gr + else DefinedObl cst in if transparent then Auto.add_hints true [Id.to_string prg.prg_name] @@ -798,8 +858,15 @@ let rec solve_obligation prg num tac = in let obls = Array.copy obls in let _ = obls.(num) <- obl in - let res = - try update_obls prg obls (pred rem) +(* let ctx = Univ.ContextSet.of_context ctx in *) + let subst = Univ.LMap.empty (** FIXME *) in + let res = + try update_obls + {prg with prg_body = Universes.subst_opt_univs_constr subst prg.prg_body; + prg_type = Universes.subst_opt_univs_constr subst prg.prg_type; + prg_ctx = ctx; + prg_subst = Univ.LMap.union prg.prg_subst subst} + obls (pred rem) with e when Errors.noncritical e -> pperror (Errors.print (Cerrors.process_vernac_interp_error e)) in @@ -835,7 +902,7 @@ and solve_obligation_by_tac prg obls i tac = | None -> try if List.is_empty (deps_remaining obls obl.obl_deps) then - let obl = subst_deps_obl obls obl in + let obl = subst_deps_obl prg.prg_subst obls obl in let tac = match tac with | Some t -> t @@ -844,8 +911,11 @@ and solve_obligation_by_tac prg obls i tac = | Some t -> t | None -> snd (get_default_tactic ()) in - let t = solve_by_tac (evar_of_obligation obl) tac in - obls.(i) <- declare_obligation prg obl t; + let t, subst, ctx = + solve_by_tac (evar_of_obligation obl) tac + (pi2 prg.prg_kind) prg.prg_subst prg.prg_ctx + in + obls.(i) <- declare_obligation {prg with prg_subst = subst} obl t ctx; true else false with e when Errors.noncritical e -> @@ -929,10 +999,10 @@ let show_term n = Printer.pr_constr_env (Global.env ()) prg.prg_type ++ spc () ++ str ":=" ++ fnl () ++ Printer.pr_constr_env (Global.env ()) prg.prg_body) -let add_definition n ?term t ?(implicits=[]) ?(kind=Global,Definition) ?tactic +let add_definition n ?term t ctx ?(implicits=[]) ?(kind=Global,false,Definition) ?tactic ?(reduce=reduce) ?(hook=fun _ _ -> ()) obls = let info = str (Id.to_string n) ++ str " has type-checked" in - let prg = init_prog_info n term t [] None [] obls implicits kind reduce hook in + let prg = init_prog_info n term t ctx [] None [] obls implicits kind reduce hook in let obls,_ = prg.prg_obligations in if Int.equal (Array.length obls) 0 then ( Flags.if_verbose msg_info (info ++ str "."); @@ -947,12 +1017,12 @@ let add_definition n ?term t ?(implicits=[]) ?(kind=Global,Definition) ?tactic | Remain rem -> Flags.if_verbose (fun () -> show_obligations ~msg:false (Some n)) (); res | _ -> res) -let add_mutual_definitions l ?tactic ?(kind=Global,Definition) ?(reduce=reduce) +let add_mutual_definitions l ctx ?tactic ?(kind=Global,false,Definition) ?(reduce=reduce) ?(hook=fun _ _ -> ()) notations fixkind = let deps = List.map (fun (n, b, t, imps, obls) -> n) l in List.iter (fun (n, b, t, imps, obls) -> - let prg = init_prog_info n (Some b) t deps (Some fixkind) + let prg = init_prog_info n (Some b) t ctx deps (Some fixkind) notations obls imps kind reduce hook in progmap_add n prg) l; let _defined = @@ -975,13 +1045,13 @@ let admit_prog prg = (fun i x -> match x.obl_body with | None -> - let x = subst_deps_obl obls x in - (** ppedrot: seems legit to have admitted obligations as local *) + let x = subst_deps_obl prg.prg_subst obls x in + let ctx = Univ.ContextSet.to_context prg.prg_ctx in let kn = Declare.declare_constant x.obl_name ~local:true - (ParameterEntry (None, x.obl_type,None), IsAssumption Conjectural) + (ParameterEntry (None,false,(x.obl_type,ctx),None), IsAssumption Conjectural) in assumption_message x.obl_name; - obls.(i) <- { x with obl_body = Some (mkConst kn) } + obls.(i) <- { x with obl_body = Some (DefinedObl kn) } | Some _ -> ()) obls; ignore(update_obls prg obls 0) diff --git a/toplevel/obligations.mli b/toplevel/obligations.mli index 746b4ed14..f03e6c446 100644 --- a/toplevel/obligations.mli +++ b/toplevel/obligations.mli @@ -17,7 +17,7 @@ open Decl_kinds open Tacexpr (** Forward declaration. *) -val declare_fix_ref : (definition_kind -> Id.t -> +val declare_fix_ref : (definition_kind -> Univ.universe_context -> Id.t -> Entries.proof_output -> types -> Impargs.manual_implicits -> global_reference) ref val declare_definition_ref : @@ -64,6 +64,7 @@ val set_proofs_transparency : bool -> unit (* true = All transparent, false = Op val get_proofs_transparency : unit -> bool val add_definition : Names.Id.t -> ?term:Term.constr -> Term.types -> + Univ.universe_context_set -> ?implicits:(Constrexpr.explicitation * (bool * bool * bool)) list -> ?kind:Decl_kinds.definition_kind -> ?tactic:unit Proofview.tactic -> @@ -80,6 +81,7 @@ type fixpoint_kind = val add_mutual_definitions : (Names.Id.t * Term.constr * Term.types * (Constrexpr.explicitation * (bool * bool * bool)) list * obligation_info) list -> + Univ.universe_context_set -> ?tactic:unit Proofview.tactic -> ?kind:Decl_kinds.definition_kind -> ?reduce:(Term.constr -> Term.constr) -> diff --git a/toplevel/record.ml b/toplevel/record.ml index dc38d2519..7411a6377 100644 --- a/toplevel/record.ml +++ b/toplevel/record.ml @@ -13,6 +13,7 @@ open Names open Globnames open Nameops open Term +open Context open Vars open Environ open Declarations @@ -23,9 +24,21 @@ open Decl_kinds open Type_errors open Constrexpr open Constrexpr_ops +open Goptions (********** definition d'un record (structure) **************) +(** Flag governing use of primitive projections. Disabled by default. *) +let primitive_flag = ref false +let _ = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "use of primitive projections"; + optkey = ["Primitive";"Projections"]; + optread = (fun () -> !primitive_flag) ; + optwrite = (fun b -> primitive_flag := b) } + let interp_fields_evars evars env impls_env nots l = List.fold_left2 (fun (env, uimpls, params, impls) no ((loc, i), b, t) -> @@ -41,15 +54,25 @@ let interp_fields_evars evars env impls_env nots l = (push_rel d env, impl :: uimpls, d::params, impls)) (env, [], [], impls_env) nots l +let compute_constructor_level evars env l = + List.fold_right (fun (n,b,t as d) (env, univ) -> + let univ = + if b = None then + let s = Retyping.get_sort_of env evars t in + Univ.sup (univ_of_sort s) univ + else univ + in (push_rel d env, univ)) + l (env, Univ.type0m_univ) + let binder_of_decl = function | Vernacexpr.AssumExpr(n,t) -> (n,None,t) | Vernacexpr.DefExpr(n,c,t) -> (n,Some c, match t with Some c -> c | None -> CHole (fst n, None, None)) let binders_of_decls = List.map binder_of_decl -let typecheck_params_and_fields id t ps nots fs = +let typecheck_params_and_fields def id t ps nots fs = let env0 = Global.env () in - let evars = ref Evd.empty in + let evars = ref (Evd.from_env ~ctx:(Univ.ContextSet.empty) env0) in let _ = let error bk (loc, name) = match bk, name with @@ -62,15 +85,48 @@ let typecheck_params_and_fields id t ps nots fs = | LocalRawAssum (ls, bk, ce) -> List.iter (error bk) ls) ps in let impls_env, ((env1,newps), imps) = interp_context_evars evars env0 ps in - let fullarity = it_mkProd_or_LetIn (Option.cata (fun x -> x) (Termops.new_Type ()) t) newps in + let t' = match t with + | Some t -> + let env = push_rel_context newps env0 in + let s = interp_type_evars evars env ~impls:empty_internalization_env t in + let sred = Reductionops.whd_betadeltaiota env !evars s in + (match kind_of_term sred with + | Sort s' -> + (match Evd.is_sort_variable !evars s' with + | Some (l, _) -> evars := Evd.make_flexible_variable !evars true (* (not def) *) l; sred + | None -> s) + | _ -> user_err_loc (constr_loc t,"", str"Sort expected.")) + | None -> + let uvarkind = if (* not def *) true then Evd.univ_flexible_alg else Evd.univ_flexible in + mkSort (Evarutil.evd_comb0 (Evd.new_sort_variable uvarkind) evars) + in + let fullarity = it_mkProd_or_LetIn t' newps in let env_ar = push_rel_context newps (push_rel (Name id,None,fullarity) env0) in let env2,impls,newfs,data = interp_fields_evars evars env_ar impls_env nots (binders_of_decls fs) in - let sigma = Pretyping.solve_remaining_evars Pretyping.all_and_fail_flags env_ar Evd.empty !evars in - let newps = Evarutil.nf_rel_context_evar sigma newps in - let newfs = Evarutil.nf_rel_context_evar sigma newfs in - imps, newps, impls, newfs + let sigma = + Pretyping.solve_remaining_evars Pretyping.all_and_fail_flags env_ar Evd.empty !evars in + let evars, nf = Evarutil.nf_evars_and_universes sigma in + let arity = nf t' in + let evars = + let _, univ = compute_constructor_level evars env_ar newfs in + let aritysort = destSort arity in + if Sorts.is_prop aritysort || + (Sorts.is_set aritysort && engagement env0 = Some ImpredicativeSet) then + evars + else Evd.set_leq_sort evars (Type univ) aritysort + (* try Evarconv.the_conv_x_leq env_ar ty arity evars *) + (* with Reduction.NotConvertible -> *) + (* Pretype_errors.error_cannot_unify env_ar evars (ty, arity) *) + in + let evars, nf = Evarutil.nf_evars_and_universes evars in + let newps = map_rel_context nf newps in + let newfs = map_rel_context nf newfs in + let ce t = Evarutil.check_evars env0 Evd.empty evars t in + List.iter (fun (n, b, t) -> Option.iter ce b; ce t) (List.rev newps); + List.iter (fun (n, b, t) -> Option.iter ce b; ce t) (List.rev newfs); + Evd.universe_context evars, nf arity, imps, newps, impls, newfs let degenerate_decl (na,b,t) = let id = match na with @@ -147,21 +203,25 @@ let subst_projection fid l c = raise (NotDefinable (MissingProj (fid,List.rev !bad_projs))); c'' -let instantiate_possibly_recursive_type indsp paramdecls fields = +let instantiate_possibly_recursive_type indu paramdecls fields = let subst = List.map_i (fun i _ -> mkRel i) 1 paramdecls in - Termops.substl_rel_context (subst@[mkInd indsp]) fields + Termops.substl_rel_context (subst@[mkIndU indu]) fields (* We build projections *) let declare_projections indsp ?(kind=StructureComponent) ?name coers fieldimpls fields = let env = Global.env() in let (mib,mip) = Global.lookup_inductive indsp in let paramdecls = mib.mind_params_ctxt in - let r = mkInd indsp in + let poly = mib.mind_polymorphic and ctx = mib.mind_universes in + let u = Inductive.inductive_instance mib in + let indu = indsp, u in + let r = mkIndU (indsp,u) in let rp = applist (r, Termops.extended_rel_list 0 paramdecls) in let paramargs = Termops.extended_rel_list 1 paramdecls in (*def in [[params;x:rp]]*) let x = match name with Some n -> Name n | None -> Namegen.named_hd (Global.env()) r Anonymous in - let fields = instantiate_possibly_recursive_type indsp paramdecls fields in + let fields = instantiate_possibly_recursive_type indu paramdecls fields in let lifted_fields = Termops.lift_rel_context 1 fields in + let nfields = List.length fields in let (_,kinds,sp_projs,_) = List.fold_left3 (fun (nfi,kinds,sp_projs,subst) coe (fi,optci,ti) impls -> @@ -181,18 +241,29 @@ let declare_projections indsp ?(kind=StructureComponent) ?name coers fieldimpls let p = mkLambda (x, lift 1 rp, ccl') in let branch = it_mkLambda_or_LetIn (mkRel nfi) lifted_fields in let ci = Inductiveops.make_case_info env indsp LetStyle in - mkCase (ci, p, mkRel 1, [|branch|]) in + mkCase (ci, p, mkRel 1, [|branch|]) + in let proj = it_mkLambda_or_LetIn (mkLambda (x,rp,body)) paramdecls in let projtyp = it_mkProd_or_LetIn (mkProd (x,rp,ccl)) paramdecls in let kn = try + let projinfo = + (fst indsp, mib.mind_nparams, nfields - nfi, ccl) + in + let projinfo = + if !primitive_flag && optci = None then Some projinfo + else None + in let cie = { const_entry_body = Future.from_val (proj,Declareops.no_seff); const_entry_secctx = None; const_entry_type = Some projtyp; + const_entry_polymorphic = poly; + const_entry_universes = ctx; + const_entry_proj = projinfo; const_entry_opaque = false; const_entry_inline_code = false; const_entry_feedback = None; @@ -204,15 +275,18 @@ let declare_projections indsp ?(kind=StructureComponent) ?name coers fieldimpls with Type_errors.TypeError (ctx,te) -> raise (NotDefinable (BadTypedProj (fid,ctx,te))) in let refi = ConstRef kn in - let constr_fi = mkConst kn in Impargs.maybe_declare_manual_implicits false refi impls; if coe then begin let cl = Class.class_of_global (IndRef indsp) in - Class.try_add_new_coercion_with_source refi ~local:false ~source:cl + Class.try_add_new_coercion_with_source refi ~local:false poly ~source:cl end; - let proj_args = (*Rel 1 refers to "x"*) paramargs@[mkRel 1] in - let constr_fip = applist (constr_fi,proj_args) in - (Some kn::sp_projs, Projection constr_fip::subst) + let constr_fip = + if !primitive_flag then mkProj (kn,mkRel 1) + else + let proj_args = (*Rel 1 refers to "x"*) paramargs@[mkRel 1] in + applist (mkConstU (kn,u),proj_args) + in + (Some kn::sp_projs, Projection constr_fip::subst) with NotDefinable why -> warning_or_error coe indsp why; (None::sp_projs,NoProjection fi::subst) in @@ -238,7 +312,7 @@ let structure_signature ctx = open Typeclasses -let declare_structure finite infer id idbuild paramimpls params arity fieldimpls fields +let declare_structure finite infer poly ctx id idbuild paramimpls params arity fieldimpls fields ?(kind=StructureComponent) ?name is_coe coers sign = let nparams = List.length params and nfields = List.length fields in let args = Termops.extended_rel_list nfields params in @@ -256,20 +330,23 @@ let declare_structure finite infer id idbuild paramimpls params arity fieldimpls begin match finite with | BiFinite -> if Termops.dependent (mkRel (nparams+1)) (it_mkProd_or_LetIn mkProp fields) then - error "Records declared with the keyword Record or Structure cannot be recursive. You can, however, define recursive records using the Inductive or CoInductive command." + error ("Records declared with the keyword Record or Structure cannot be recursive." ^ + "You can, however, define recursive records using the Inductive or CoInductive command.") | _ -> () end; let mie = { mind_entry_params = List.map degenerate_decl params; mind_entry_record = true; mind_entry_finite = finite != CoFinite; - mind_entry_inds = [mie_ind] } in + mind_entry_inds = [mie_ind]; + mind_entry_polymorphic = poly; + mind_entry_universes = ctx } in let kn = Command.declare_mutual_inductive_with_eliminations KernelVerbose mie [(paramimpls,[])] in let rsp = (kn,0) in (* This is ind path of idstruc *) let cstr = (rsp,1) in let kinds,sp_projs = declare_projections rsp ~kind ?name coers fieldimpls fields in let build = ConstructRef cstr in - let () = if is_coe then Class.try_add_new_coercion build ~local:false in + let () = if is_coe then Class.try_add_new_coercion build ~local:false poly in Recordops.declare_structure(rsp,cstr,List.rev kinds,List.rev sp_projs); rsp @@ -282,43 +359,34 @@ let implicits_of_context ctx = in ExplByPos (i, explname), (true, true, true)) 1 (List.rev (Anonymous :: (List.map pi1 ctx))) -let declare_class finite def infer id idbuild paramimpls params arity fieldimpls fields +let declare_class finite def infer poly ctx id idbuild paramimpls params arity fieldimpls fields ?(kind=StructureComponent) ?name is_coe coers priorities sign = let fieldimpls = - (* Make the class and all params implicits in the projections *) - let ctx_impls = implicits_of_context params in - let len = succ (List.length params) in - List.map (fun x -> ctx_impls @ Impargs.lift_implicits len x) fieldimpls + (* Make the class implicit in the projections, and the params if applicable. *) + (* if def then *) + let len = List.length params in + let impls = implicits_of_context params in + List.map (fun x -> impls @ Impargs.lift_implicits (succ len) x) fieldimpls + (* else List.map (fun x -> (ExplByPos (1, None), (true, true, true)) :: *) + (* Impargs.lift_implicits 1 x) fieldimpls *) in let impl, projs = match fields with | [(Name proj_name, _, field)] when def -> let class_body = it_mkLambda_or_LetIn field params in - let class_type = Option.map (fun ar -> it_mkProd_or_LetIn ar params) arity in - let class_entry = - { const_entry_body = - Future.from_val (class_body,Declareops.no_seff); - const_entry_secctx = None; - const_entry_type = class_type; - const_entry_opaque = false; - const_entry_inline_code = false; - const_entry_feedback = None; - } in + let _class_type = it_mkProd_or_LetIn arity params in + let class_entry = + Declare.definition_entry (* ?types:class_type *) ~poly ~univs:ctx class_body in let cst = Declare.declare_constant (snd id) (DefinitionEntry class_entry, IsDefinition Definition) in - let inst_type = appvectc (mkConst cst) (Termops.rel_vect 0 (List.length params)) in - let proj_type = it_mkProd_or_LetIn (mkProd(Name (snd id), inst_type, lift 1 field)) params in - let proj_body = it_mkLambda_or_LetIn (mkLambda (Name (snd id), inst_type, mkRel 1)) params in - let proj_entry = - { const_entry_body = - Future.from_val (proj_body,Declareops.no_seff); - const_entry_secctx = None; - const_entry_type = Some proj_type; - const_entry_opaque = false; - const_entry_inline_code = false; - const_entry_feedback = None; - } in + let cstu = (cst, if poly then Univ.UContext.instance ctx else Univ.Instance.empty) in + let inst_type = appvectc (mkConstU cstu) (Termops.rel_vect 0 (List.length params)) in + let proj_type = + it_mkProd_or_LetIn (mkProd(Name (snd id), inst_type, lift 1 field)) params in + let proj_body = + it_mkLambda_or_LetIn (mkLambda (Name (snd id), inst_type, mkRel 1)) params in + let proj_entry = Declare.definition_entry ~types:proj_type ~poly ~univs:ctx proj_body in let proj_cst = Declare.declare_constant proj_name (DefinitionEntry proj_entry, IsDefinition Definition) in @@ -326,16 +394,20 @@ let declare_class finite def infer id idbuild paramimpls params arity fieldimpls Impargs.declare_manual_implicits false cref [paramimpls]; Impargs.declare_manual_implicits false (ConstRef proj_cst) [List.hd fieldimpls]; Classes.set_typeclass_transparency (EvalConstRef cst) false false; - let sub = match List.hd coers with Some b -> Some ((if b then Backward else Forward), List.hd priorities) | None -> None in + let sub = match List.hd coers with + | Some b -> Some ((if b then Backward else Forward), List.hd priorities) + | None -> None + in cref, [Name proj_name, sub, Some proj_cst] | _ -> let idarg = Namegen.next_ident_away (snd id) (Termops.ids_of_context (Global.env())) in - let ind = declare_structure BiFinite infer (snd id) idbuild paramimpls - params (Option.default (Termops.new_Type ()) arity) fieldimpls fields + let ind = declare_structure BiFinite infer poly ctx (snd id) idbuild paramimpls + params arity fieldimpls fields ~kind:Method ~name:idarg false (List.map (fun _ -> false) fields) sign in let coers = List.map2 (fun coe pri -> - Option.map (fun b -> if b then Backward, pri else Forward, pri) coe) + Option.map (fun b -> + if b then Backward, pri else Forward, pri) coe) coers priorities in IndRef ind, (List.map3 (fun (id, _, _) b y -> (id, b, y)) @@ -344,7 +416,7 @@ let declare_class finite def infer id idbuild paramimpls params arity fieldimpls let ctx_context = List.map (fun (na, b, t) -> match Typeclasses.class_of_constr t with - | Some (_, (cl, _)) -> Some (cl.cl_impl, true) (*List.exists (fun (_, n) -> n = na) supnames)*) + | Some (_, ((cl,_), _)) -> Some (cl.cl_impl, true) (*FIXME: ignore universes?*) | None -> None) params, params in @@ -359,19 +431,12 @@ let declare_class finite def infer id idbuild paramimpls params arity fieldimpls (* k.cl_projs coers priorities; *) add_class k; impl -let interp_and_check_sort sort = - Option.map (fun sort -> - let env = Global.env() and sigma = Evd.empty in - let s = interp_constr sigma env sort in - if isSort (Reductionops.whd_betadeltaiota env sigma s) then s - else user_err_loc (constr_loc sort,"", str"Sort expected.")) sort - open Vernacexpr (* [fs] corresponds to fields and [ps] to parameters; [coers] is a list telling if the corresponding fields must me declared as coercions or subinstances *) -let definition_structure (kind,finite,infer,(is_coe,(loc,idstruc)),ps,cfs,idbuild,s) = +let definition_structure (kind,poly,finite,infer,(is_coe,(loc,idstruc)),ps,cfs,idbuild,s) = let cfs,notations = List.split cfs in let cfs,priorities = List.split cfs in let coers,fs = List.split cfs in @@ -386,20 +451,20 @@ let definition_structure (kind,finite,infer,(is_coe,(loc,idstruc)),ps,cfs,idbuil if isnot_class && List.exists (fun opt -> not (Option.is_empty opt)) priorities then error "Priorities only allowed for type class substructures"; (* Now, younger decl in params and fields is on top *) - let sc = interp_and_check_sort s in - let implpars, params, implfs, fields = + let ctx, arity, implpars, params, implfs, fields = States.with_state_protection (fun () -> - typecheck_params_and_fields idstruc sc ps notations fs) () in + typecheck_params_and_fields (kind = Class true) idstruc s ps notations fs) () in let sign = structure_signature (fields@params) in match kind with | Class def -> - let gr = declare_class finite def infer (loc,idstruc) idbuild - implpars params sc implfs fields is_coe coers priorities sign in + let gr = declare_class finite def infer poly ctx (loc,idstruc) idbuild + implpars params arity implfs fields is_coe coers priorities sign in gr | _ -> - let arity = Option.default (Termops.new_Type ()) sc in let implfs = List.map - (fun impls -> implpars @ Impargs.lift_implicits (succ (List.length params)) impls) implfs in - let ind = declare_structure finite infer idstruc idbuild implpars params arity implfs + (fun impls -> implpars @ Impargs.lift_implicits + (succ (List.length params)) impls) implfs in + let ind = declare_structure finite infer poly ctx idstruc + idbuild implpars params arity implfs fields is_coe (List.map (fun coe -> not (Option.is_empty coe)) coers) sign in IndRef ind diff --git a/toplevel/record.mli b/toplevel/record.mli index 018366667..dac8636cb 100644 --- a/toplevel/record.mli +++ b/toplevel/record.mli @@ -14,6 +14,8 @@ open Constrexpr open Impargs open Globnames +val primitive_flag : bool ref + (** [declare_projections ref name coers params fields] declare projections of record [ref] (if allowed) using the given [name] as argument, and put them as coercions accordingly to [coers]; it returns the absolute names of projections *) @@ -24,7 +26,8 @@ val declare_projections : (Name.t * bool) list * constant option list val declare_structure : Decl_kinds.recursivity_kind -> - bool (**infer?*) -> Id.t -> Id.t -> + bool (**infer?*) -> bool (** polymorphic?*) -> Univ.universe_context -> + Id.t -> Id.t -> manual_explicitation list -> rel_context -> (** params *) constr -> (** arity *) Impargs.manual_explicitation list list -> rel_context -> (** fields *) ?kind:Decl_kinds.definition_object_kind -> ?name:Id.t -> @@ -34,6 +37,6 @@ val declare_structure : Decl_kinds.recursivity_kind -> inductive val definition_structure : - inductive_kind * Decl_kinds.recursivity_kind * bool(**infer?*)* lident with_coercion * local_binder list * + inductive_kind * Decl_kinds.polymorphic * Decl_kinds.recursivity_kind * bool(**infer?*)* lident with_coercion * local_binder list * (local_decl_expr with_instance with_priority with_notation) list * Id.t * constr_expr option -> global_reference diff --git a/toplevel/search.ml b/toplevel/search.ml index 38717850c..1535ae617 100644 --- a/toplevel/search.ml +++ b/toplevel/search.ml @@ -45,7 +45,7 @@ module SearchBlacklist = let iter_constructors indsp fn env nconstr = for i = 1 to nconstr do - let typ = Inductiveops.type_of_constructor env (indsp, i) in + let typ, _ = Inductiveops.type_of_constructor_in_ctx env (indsp, i) in fn (ConstructRef (indsp, i)) env typ done @@ -60,14 +60,15 @@ let iter_declarations (fn : global_reference -> env -> constr -> unit) = with Not_found -> (* we are in a section *) () end | "CONSTANT" -> let cst = Global.constant_of_delta_kn kn in - let typ = Typeops.type_of_constant env cst in + let typ, _ = Environ.constant_type_in_ctx env cst in fn (ConstRef cst) env typ | "INDUCTIVE" -> let mind = Global.mind_of_delta_kn kn in let mib = Global.lookup_mind mind in let iter_packet i mip = let ind = (mind, i) in - let typ = Inductiveops.type_of_inductive env ind in + let i = (ind, Univ.UContext.instance mib.mind_universes) in + let typ = Inductiveops.type_of_inductive env i in let () = fn (IndRef ind) env typ in let len = Array.length mip.mind_user_lc in iter_constructors ind fn env len diff --git a/toplevel/usage.ml b/toplevel/usage.ml index 73a509577..9851cfe87 100644 --- a/toplevel/usage.ml +++ b/toplevel/usage.ml @@ -66,6 +66,7 @@ let print_usage_channel co command = \n -dump-glob f dump globalizations in file f (to be used by coqdoc)\ \n -with-geoproof (yes|no) to (de)activate special functions for Geoproof within Coqide (default is yes)\ \n -impredicative-set set sort Set impredicative\ +\n -indices-matter levels of indices (and nonuniform parameters) contribute to the level of inductives\ \n -force-load-proofs load opaque proofs in memory initially\ \n -lazy-load-proofs load opaque proofs in memory by necessity (default)\ diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index d5559f976..2e9bfedc7 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -252,11 +252,7 @@ let print_namespace ns = print_list pr_id qn in let print_constant k body = - let t = - match body.Declarations.const_type with - | Declarations.PolymorphicArity (ctx,a) -> mkArity (ctx, Term.Type a.Declarations.poly_level) - | Declarations.NonPolymorphicType t -> t - in + let t = body.Declarations.const_type in print_kn k ++ str":" ++ spc() ++ Printer.pr_type t in let matches mp = match match_modulepath ns mp with @@ -457,22 +453,22 @@ let start_proof_and_print k l hook = let no_hook _ _ = () -let vernac_definition_hook = function -| Coercion -> Class.add_coercion_hook -| CanonicalStructure -> (fun _ -> Recordops.declare_canonical_structure) -| SubClass -> Class.add_subclass_hook +let vernac_definition_hook p = function +| Coercion -> Class.add_coercion_hook p +| CanonicalStructure -> fun _ -> Recordops.declare_canonical_structure +| SubClass -> Class.add_subclass_hook p | _ -> no_hook -let vernac_definition locality (local,k) (loc,id as lid) def = +let vernac_definition locality p (local,k) (loc,id as lid) def = let local = enforce_locality_exp locality local in - let hook = vernac_definition_hook k in + let hook = vernac_definition_hook p k in let () = match local with | Discharge -> Dumpglob.dump_definition lid true "var" | Local | Global -> Dumpglob.dump_definition lid false "def" in (match def with | ProveBody (bl,t) -> (* local binders, typ *) - start_proof_and_print (local,DefinitionBody Definition) + start_proof_and_print (local,p,DefinitionBody Definition) [Some lid, (bl,t,None)] no_hook | DefineBody (bl,red_option,c,typ_opt) -> let red_option = match red_option with @@ -480,9 +476,9 @@ let vernac_definition locality (local,k) (loc,id as lid) def = | Some r -> let (evc,env)= get_current_context () in Some (snd (interp_redexp env evc r)) in - do_definition id (local,k) bl red_option c typ_opt hook) + do_definition id (local,p,k) bl red_option c typ_opt hook) -let vernac_start_proof kind l lettop = +let vernac_start_proof p kind l lettop = if Dumpglob.dump () then List.iter (fun (id, _) -> match id with @@ -492,7 +488,7 @@ let vernac_start_proof kind l lettop = if lettop then errorlabstrm "Vernacentries.StartProof" (str "Let declarations can only be used in proof editing mode."); - start_proof_and_print (Global, Proof kind) l no_hook + start_proof_and_print (Global, p, Proof kind) l no_hook let qed_display_script = ref true @@ -512,10 +508,10 @@ let vernac_exact_proof c = save_proof (Vernacexpr.Proved(true,None)); if not status then Pp.feedback Interface.AddedAxiom -let vernac_assumption locality (local, kind) l nl = +let vernac_assumption locality poly (local, kind) l nl = let local = enforce_locality_exp locality local in let global = local == Global in - let kind = local, kind in + let kind = local, poly, kind in List.iter (fun (is_coe,(idl,c)) -> if Dumpglob.dump () then List.iter (fun lid -> @@ -524,7 +520,7 @@ let vernac_assumption locality (local, kind) l nl = let status = do_assumptions kind nl l in if not status then Pp.feedback Interface.AddedAxiom -let vernac_record k finite infer struc binders sort nameopt cfs = +let vernac_record k poly finite infer struc binders sort nameopt cfs = let const = match nameopt with | None -> add_prefix "Build_" (snd (snd struc)) | Some (_,id as lid) -> @@ -535,9 +531,9 @@ let vernac_record k finite infer struc binders sort nameopt cfs = match x with | Vernacexpr.AssumExpr ((loc, Name id), _) -> Dumpglob.dump_definition (loc,id) false "proj" | _ -> ()) cfs); - ignore(Record.definition_structure (k,finite,infer,struc,binders,cfs,const,sort)) + ignore(Record.definition_structure (k,poly,finite,infer,struc,binders,cfs,const,sort)) -let vernac_inductive finite infer indl = +let vernac_inductive poly finite infer indl = if Dumpglob.dump () then List.iter (fun (((coe,lid), _, _, _, cstrs), _) -> match cstrs with @@ -550,13 +546,13 @@ let vernac_inductive finite infer indl = match indl with | [ ( id , bl , c , b, RecordDecl (oc,fs) ), [] ] -> vernac_record (match b with Class true -> Class false | _ -> b) - finite infer id bl c oc fs + poly finite infer id bl c oc fs | [ ( id , bl , c , Class true, Constructors [l]), _ ] -> let f = let (coe, ((loc, id), ce)) = l in let coe' = if coe then Some true else None in (((coe', AssumExpr ((loc, Name id), ce)), None), []) - in vernac_record (Class true) finite infer id bl c None [f] + in vernac_record (Class true) poly finite infer id bl c None [f] | [ ( id , bl , c , Class true, _), _ ] -> Errors.error "Definitional classes must have a single method" | [ ( id , bl , c , Class false, Constructors _), _ ] -> @@ -568,19 +564,19 @@ let vernac_inductive finite infer indl = | _ -> Errors.error "Cannot handle mutually (co)inductive records." in let indl = List.map unpack indl in - do_mutual_inductive indl (finite != CoFinite) + do_mutual_inductive indl poly (finite != CoFinite) -let vernac_fixpoint locality local l = +let vernac_fixpoint locality poly local l = let local = enforce_locality_exp locality local in if Dumpglob.dump () then List.iter (fun ((lid, _, _, _, _), _) -> Dumpglob.dump_definition lid false "def") l; - do_fixpoint local l + do_fixpoint local poly l -let vernac_cofixpoint locality local l = +let vernac_cofixpoint locality poly local l = let local = enforce_locality_exp locality local in if Dumpglob.dump () then List.iter (fun ((lid, _, _, _), _) -> Dumpglob.dump_definition lid false "def") l; - do_cofixpoint local l + do_cofixpoint local poly l let vernac_scheme l = if Dumpglob.dump () then @@ -766,27 +762,26 @@ let vernac_require import qidl = let vernac_canonical r = Recordops.declare_canonical_structure (smart_global r) -let vernac_coercion locality local ref qids qidt = +let vernac_coercion locality poly local ref qids qidt = let local = enforce_locality locality local in let target = cl_of_qualid qidt in let source = cl_of_qualid qids in let ref' = smart_global ref in - Class.try_add_new_coercion_with_target ref' ~local ~source ~target; + Class.try_add_new_coercion_with_target ref' ~local poly ~source ~target; if_verbose msg_info (pr_global ref' ++ str " is now a coercion") -let vernac_identity_coercion locality local id qids qidt = +let vernac_identity_coercion locality poly local id qids qidt = let local = enforce_locality locality local in let target = cl_of_qualid qidt in let source = cl_of_qualid qids in - Class.try_add_new_identity_coercion id ~local ~source ~target + Class.try_add_new_identity_coercion id ~local poly ~source ~target (* Type classes *) -let vernac_instance abst locality sup inst props pri = +let vernac_instance abst locality poly sup inst props pri = let global = not (make_section_locality locality) in Dumpglob.dump_constraint inst false "inst"; - ignore(Classes.new_instance - ~abstract:abst ~global sup inst props pri) + ignore(Classes.new_instance ~abstract:abst ~global poly sup inst props pri) let vernac_context l = if not (Classes.context l) then Pp.feedback Interface.AddedAxiom @@ -909,9 +904,9 @@ let vernac_remove_hints locality dbs ids = let local = make_module_locality locality in Auto.remove_hints local dbs (List.map Smartlocate.global_with_alias ids) -let vernac_hints locality local lb h = +let vernac_hints locality poly local lb h = let local = enforce_module_locality locality local in - Auto.add_hints local lb (Auto.interp_hints h) + Auto.add_hints local lb (Auto.interp_hints poly h) let vernac_syntactic_definition locality lid x local y = Dumpglob.dump_definition lid false "syndef"; @@ -938,7 +933,8 @@ let vernac_declare_arguments locality r l nargs flags = then error "Arguments names must be distinct."; let sr = smart_global r in let inf_names = - Impargs.compute_implicits_names (Global.env()) (Global.type_of_global sr) in + let ty = Global.type_of_global_unsafe sr in + Impargs.compute_implicits_names (Global.env ()) ty in let string_of_name = function Anonymous -> "_" | Name id -> Id.to_string id in let rec check li ld ls = match li, ld, ls with | [], [], [] -> () @@ -1051,7 +1047,7 @@ let default_env () = { let vernac_reserve bl = let sb_decl = (fun (idl,c) -> - let t = Constrintern.interp_type Evd.empty (Global.env()) c in + let t,ctx = Constrintern.interp_type Evd.empty (Global.env()) c in let t = Detyping.detype false [] [] t in let t = Notation_ops.notation_constr_of_glob_constr (default_env ()) t in Reserve.declare_reserved_type idl t) @@ -1218,6 +1214,15 @@ let _ = declare_bool_option { optsync = true; optdepr = false; + optname = "universe polymorphism"; + optkey = ["Universe"; "Polymorphism"]; + optread = Flags.is_universe_polymorphism; + optwrite = Flags.make_universe_polymorphism } + +let _ = + declare_bool_option + { optsync = true; + optdepr = false; optname = "use of virtual machine inside the kernel"; optkey = ["Virtual";"Machine"]; optread = (fun () -> Vconv.use_vm ()); @@ -1378,7 +1383,10 @@ let get_current_context_of_args = function let vernac_check_may_eval redexp glopt rc = let (sigma, env) = get_current_context_of_args glopt in let sigma', c = interp_open_constr sigma env rc in - Evarconv.check_problems_are_solved sigma'; + let sigma' = Evarconv.consider_remaining_unif_problems env sigma' in + Evarconv.check_problems_are_solved env sigma'; + let sigma',nf = Evarutil.nf_evars_and_universes sigma' in + let c = nf c in let j = try Evarutil.check_evars env sigma sigma' c; @@ -1402,8 +1410,9 @@ let vernac_declare_reduction locality s r = let vernac_global_check c = let evmap = Evd.empty in let env = Global.env() in - let c = interp_constr evmap env c in + let c,ctx = interp_constr evmap env c in let senv = Global.safe_env() in + let senv = Safe_typing.add_constraints (snd ctx) senv in let j = Safe_typing.typing senv c in msg_notice (print_safe_judgment env j) @@ -1453,7 +1462,7 @@ let vernac_print = function dump_global qid; msg_notice (print_impargs qid) | PrintAssumptions (o,t,r) -> (* Prints all the axioms and section variables used by a term *) - let cstr = constr_of_global (smart_global r) in + let cstr = printable_constr_of_global (smart_global r) in let st = Conv_oracle.get_transp_state (Environ.oracle (Global.env())) in let nassums = Assumptions.assumptions st ~add_opaque:o ~add_transparent:t cstr in @@ -1522,7 +1531,7 @@ let vernac_register id r = error "Register inline: a constant is expected"; let kn = destConst t in match r with - | RegisterInline -> Global.register_inline kn + | RegisterInline -> Global.register_inline (Univ.out_punivs kn) (********************) (* Proof management *) @@ -1651,7 +1660,7 @@ let vernac_load interp fname = (* "locality" is the prefix "Local" attribute, while the "local" component * is the outdated/deprecated "Local" attribute of some vernacular commands * still parsed as the obsolete_locality grammar entry for retrocompatibility *) -let interp ?proof locality c = +let interp ?proof locality poly c = prerr_endline ("interpreting: " ^ Pp.string_of_ppcmds (Ppvernac.pr_vernac c)); match c with (* Done later in this file *) @@ -1678,14 +1687,14 @@ let interp ?proof locality c = vernac_notation locality local c infpl sc (* Gallina *) - | VernacDefinition (k,lid,d) -> vernac_definition locality k lid d - | VernacStartTheoremProof (k,l,top) -> vernac_start_proof k l top + | VernacDefinition (k,lid,d) -> vernac_definition locality poly k lid d + | VernacStartTheoremProof (k,l,top) -> vernac_start_proof poly k l top | VernacEndProof e -> vernac_end_proof ?proof e | VernacExactProof c -> vernac_exact_proof c - | VernacAssumption (stre,nl,l) -> vernac_assumption locality stre l nl - | VernacInductive (finite,infer,l) -> vernac_inductive finite infer l - | VernacFixpoint (local, l) -> vernac_fixpoint locality local l - | VernacCoFixpoint (local, l) -> vernac_cofixpoint locality local l + | VernacAssumption (stre,nl,l) -> vernac_assumption locality poly stre l nl + | VernacInductive (finite,infer,l) -> vernac_inductive poly finite infer l + | VernacFixpoint (local, l) -> vernac_fixpoint locality poly local l + | VernacCoFixpoint (local, l) -> vernac_cofixpoint locality poly local l | VernacScheme l -> vernac_scheme l | VernacCombinedScheme (id, l) -> vernac_combined_scheme id l @@ -1706,13 +1715,13 @@ let interp ?proof locality c = | VernacRequire (export, qidl) -> vernac_require export qidl | VernacImport (export,qidl) -> vernac_import export qidl | VernacCanonical qid -> vernac_canonical qid - | VernacCoercion (local,r,s,t) -> vernac_coercion locality local r s t + | VernacCoercion (local,r,s,t) -> vernac_coercion locality poly local r s t | VernacIdentityCoercion (local,(_,id),s,t) -> - vernac_identity_coercion locality local id s t + vernac_identity_coercion locality poly local id s t (* Type classes *) | VernacInstance (abst, sup, inst, props, pri) -> - vernac_instance abst locality sup inst props pri + vernac_instance abst locality poly sup inst props pri | VernacContext sup -> vernac_context sup | VernacDeclareInstances (ids, pri) -> vernac_declare_instances locality ids pri | VernacDeclareClass id -> vernac_declare_class id @@ -1744,7 +1753,7 @@ let interp ?proof locality c = | VernacCreateHintDb (dbname,b) -> vernac_create_hintdb locality dbname b | VernacRemoveHints (dbnames,ids) -> vernac_remove_hints locality dbnames ids | VernacHints (local,dbnames,hints) -> - vernac_hints locality local dbnames hints + vernac_hints locality poly local dbnames hints | VernacSyntacticDefinition (id,c,local,b) -> vernac_syntactic_definition locality id c local b | VernacDeclareImplicits (qid,l) -> @@ -1772,7 +1781,7 @@ let interp ?proof locality c = | VernacNop -> () (* Proof management *) - | VernacGoal t -> vernac_start_proof Theorem [None,([],t,None)] false + | VernacGoal t -> vernac_start_proof poly Theorem [None,([],t,None)] false | VernacAbort id -> anomaly (str "VernacAbort not handled by Stm") | VernacAbortAll -> anomaly (str "VernacAbortAll not handled by Stm") | VernacRestart -> anomaly (str "VernacRestart not handled by Stm") @@ -1801,6 +1810,7 @@ let interp ?proof locality c = (* Handled elsewhere *) | VernacProgram _ + | VernacPolymorphic _ | VernacLocal _ -> assert false (* Vernaculars that take a locality flag *) @@ -1827,6 +1837,24 @@ let check_vernac_supports_locality c l = | VernacExtend _ ) -> () | Some _, _ -> Errors.error "This command does not support Locality" +(* Vernaculars that take a polymorphism flag *) +let check_vernac_supports_polymorphism c p = + match p, c with + | None, _ -> () + | Some _, ( + VernacDefinition _ | VernacFixpoint _ | VernacCoFixpoint _ + | VernacAssumption _ | VernacInductive _ + | VernacStartTheoremProof _ + | VernacCoercion _ | VernacIdentityCoercion _ + | VernacInstance _ | VernacDeclareInstances _ + | VernacHints _ + | VernacExtend _ ) -> () + | Some _, _ -> Errors.error "This command does not support Polymorphism" + +let enforce_polymorphism = function + | None -> Flags.is_universe_polymorphism () + | Some b -> b + (** A global default timeout, controled by option "Set Default Timeout n". Use "Unset Default Timeout" to deactivate it (or set it to 0). *) @@ -1883,13 +1911,17 @@ exception HasFailed of string let interp ?(verbosely=true) ?proof (loc,c) = let orig_program_mode = Flags.is_program_mode () in - let rec aux ?locality isprogcmd = function - | VernacProgram c when not isprogcmd -> aux ?locality true c + let rec aux ?locality ?polymorphism isprogcmd = function + | VernacProgram c when not isprogcmd -> aux ?locality ?polymorphism true c | VernacProgram _ -> Errors.error "Program mode specified twice" - | VernacLocal (b, c) when Option.is_empty locality -> aux ~locality:b isprogcmd c + | VernacLocal (b, c) when Option.is_empty locality -> + aux ~locality:b ?polymorphism isprogcmd c + | VernacPolymorphic (b, c) when polymorphism = None -> + aux ?locality ~polymorphism:b isprogcmd c + | VernacPolymorphic (b, c) -> Errors.error "Polymorphism specified twice" | VernacLocal _ -> Errors.error "Locality specified twice" - | VernacStm (Command c) -> aux ?locality isprogcmd c - | VernacStm (PGLast c) -> aux ?locality isprogcmd c + | VernacStm (Command c) -> aux ?locality ?polymorphism isprogcmd c + | VernacStm (PGLast c) -> aux ?locality ?polymorphism isprogcmd c | VernacStm _ -> assert false (* Done by Stm *) | VernacFail v -> begin try @@ -1899,7 +1931,7 @@ let interp ?(verbosely=true) ?proof (loc,c) = Future.purify (fun v -> try - aux ?locality isprogcmd v; + aux ?locality ?polymorphism isprogcmd v; raise HasNotFailed with | HasNotFailed as e -> raise e @@ -1919,10 +1951,10 @@ let interp ?(verbosely=true) ?proof (loc,c) = end | VernacTimeout (n,v) -> current_timeout := Some n; - aux ?locality isprogcmd v + aux ?locality ?polymorphism isprogcmd v | VernacTime v -> let tstart = System.get_time() in - aux ?locality isprogcmd v; + aux ?locality ?polymorphism isprogcmd v; let tend = System.get_time() in let msg = if !Flags.time then "" else "Finished transaction in " in msg_info (str msg ++ System.fmt_time_difference tstart tend) @@ -1930,11 +1962,13 @@ let interp ?(verbosely=true) ?proof (loc,c) = | VernacLoad (_,fname) -> vernac_load (aux false) fname | c -> check_vernac_supports_locality c locality; + check_vernac_supports_polymorphism c polymorphism; + let poly = enforce_polymorphism polymorphism in Obligations.set_program_mode isprogcmd; let psh = default_set_timeout () in try - if verbosely then Flags.verbosely (interp ?proof locality) c - else Flags.silently (interp ?proof locality) c; + if verbosely then Flags.verbosely (interp ?proof locality poly) c + else Flags.silently (interp ?proof locality poly) c; restore_timeout psh; if orig_program_mode || not !Flags.program_mode || isprogcmd then Flags.program_mode := orig_program_mode diff --git a/toplevel/whelp.ml4 b/toplevel/whelp.ml4 index 79673df32..2da4058c8 100644 --- a/toplevel/whelp.ml4 +++ b/toplevel/whelp.ml4 @@ -126,9 +126,9 @@ let uri_params f = function let get_discharged_hyp_names sp = List.map basename (get_discharged_hyps sp) let section_parameters = function - | GRef (_,(ConstructRef ((induri,_),_) | IndRef (induri,_))) -> + | GRef (_,(ConstructRef ((induri,_),_) | IndRef (induri,_)),_) -> get_discharged_hyp_names (path_of_global (IndRef(induri,0))) - | GRef (_,(ConstRef cst as ref)) -> + | GRef (_,(ConstRef cst as ref),_) -> get_discharged_hyp_names (path_of_global ref) | _ -> [] @@ -141,10 +141,10 @@ let merge vl al = let rec uri_of_constr c = match c with | GVar (_,id) -> url_id id - | GRef (_,ref) -> uri_of_global ref + | GRef (_,ref,_) -> uri_of_global ref | GHole _ | GEvar _ -> url_string "?" | GSort (_,s) -> url_string (whelp_of_glob_sort s) - | _ -> url_paren (fun () -> match c with + | GProj _ -> assert false | GApp (_,f,args) -> let inst,rest = merge (section_parameters f) args in uri_of_constr f; url_char ' '; uri_params uri_of_constr inst; @@ -164,10 +164,10 @@ let rec uri_of_constr c = uri_of_constr c; url_string ":"; uri_of_constr t | GRec _ | GIf _ | GLetTuple _ | GCases _ -> error "Whelp does not support pattern-matching and (co-)fixpoint." - | GVar _ | GRef _ | GHole _ | GEvar _ | GSort _ | GCast (_,_, CastCoerce) -> + | GCast (_,_, CastCoerce) -> anomaly (Pp.str "Written w/o parenthesis") | GPatVar _ -> - anomaly (Pp.str "Found constructors not supported in constr")) () + anomaly (Pp.str "Found constructors not supported in constr") let make_string f x = Buffer.reset b; f x; Buffer.contents b |