Fix declarations of instances to perform restriction of universe

instances as definitions and lemmas do (fixes bug# 4121).

3 files changed, 23 insertions, 3 deletions

diff --git a/test-suite/bugs/closed/4121.v b/test-suite/bugs/closed/4121.v
new file mode 100644
index 0000000000..5f8c411ca8
--- /dev/null
+++ b/test-suite/bugs/closed/4121.v
@@ -0,0 +1,15 @@
+(* -*- coq-prog-args: ("-emacs" "-nois") -*- *)
+(* File reduced by coq-bug-finder from original input, then from 830 lines to 47 lines, then from 25 lines to 11 lines *)
+(* coqc version 8.5beta1 (March 2015) compiled on Mar 11 2015 18:51:36 with OCaml 4.01.0
+   coqtop version cagnode15:/afs/csail.mit.edu/u/j/jgross/coq-8.5,v8.5 (8dbfee5c5f897af8186cb1bdfb04fd4f88eca677) *)
+
+Set Universe Polymorphism.
+Class Contr_internal (A : Type) := BuildContr { center : A }.
+Arguments center A {_}.
+Class Contr (A : Type) : Type := Contr_is_trunc : Contr_internal A.
+Hint Extern 0 => progress change Contr_internal with Contr in * : typeclass_instances.
+Definition contr_paths_contr0 {A} `{Contr A} : Contr A := {| center := center A |}.
+Instance contr_paths_contr1 {A} `{Contr A} : Contr A := {| center := center A |}.
+Check @contr_paths_contr0@{i}.
+Check @contr_paths_contr1@{i}. (* Error: Universe instance should have length 2 *)
+(** It should have length 1, just like contr_paths_contr0 *)
\ No newline at end of file
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