diff options
| author | Matthieu Sozeau | 2015-04-09 17:49:42 +0200 |
|---|---|---|
| committer | Matthieu Sozeau | 2015-04-09 17:50:32 +0200 |
| commit | 6158ec51adc31814fde0293f54151c19a5f3b1e4 (patch) | |
| tree | 284a751d8ded260dce6dba330e42ee20be9b0d91 /toplevel | |
| parent | 968c8af13deaa3871aca7fc7086f1a5dc5769fde (diff) | |
Fix declarations of instances to perform restriction of universe
instances as definitions and lemmas do (fixes bug# 4121).
Diffstat (limited to 'toplevel')
| -rw-r--r-- | toplevel/classes.ml | 9 | ||||
| -rw-r--r-- | toplevel/classes.mli | 2 |
2 files changed, 8 insertions, 3 deletions
diff --git a/toplevel/classes.ml b/toplevel/classes.ml index 07f881721d..33891ad94c 100644 --- a/toplevel/classes.ml +++ b/toplevel/classes.ml @@ -103,8 +103,13 @@ let instance_hook k pri global imps ?hook cst = let declare_instance_constant k pri global imps ?hook id poly uctx term termtype = let kind = IsDefinition Instance in + let uctx = + let levels = Univ.LSet.union (Universes.universes_of_constr termtype) + (Universes.universes_of_constr term) in + Universes.restrict_universe_context uctx levels + in let entry = - Declare.definition_entry ~types:termtype ~poly ~univs:uctx term + Declare.definition_entry ~types:termtype ~poly ~univs:(Univ.ContextSet.to_context uctx) term in let cdecl = (DefinitionEntry entry, kind) in let kn = Declare.declare_constant id cdecl in @@ -277,7 +282,7 @@ let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) pro 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 + let ctx = Evd.universe_context_set evm in declare_instance_constant k pri global imps ?hook id poly ctx (Option.get term) termtype else if !refine_instance || Option.is_empty term then begin diff --git a/toplevel/classes.mli b/toplevel/classes.mli index cb88ae564d..2b7e9e4fe2 100644 --- a/toplevel/classes.mli +++ b/toplevel/classes.mli @@ -32,7 +32,7 @@ val declare_instance_constant : ?hook:(Globnames.global_reference -> unit) -> Id.t -> (** name *) bool -> (* polymorphic *) - Univ.universe_context -> (* Universes *) + Univ.universe_context_set -> (* Universes *) Constr.t -> (** body *) Term.types -> (** type *) Names.Id.t |