Fix issue in printing due to de Bruijn bug when constructing compatibility

constr for primitive records (not used anywhere else than printing).
Problem reported by P. LeFanu Lumsdaine on HoTT/HoTT.
Also add some minor fixes in detyping and pretty printing related to universes.

4 files changed, 12 insertions, 9 deletions

diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml
index 635c5c4bf..99d9f52c9 100644
--- a/kernel/indtypes.ml
+++ b/kernel/indtypes.ml
@@ -683,7 +683,7 @@ let compute_projections ((kn, _ as ind), u as indsp) n x nparamargs params
     let ccl' = liftn 1 2 ccl in
     let p = mkLambda (x, lift 1 rp, ccl') in
     let branch = it_mkLambda_or_LetIn (mkRel (len - i)) ctx in
-    let body = mkCase (ci, p, mkRel 1, [|branch|]) in
+    let body = mkCase (ci, p, mkRel 1, [|lift 1 branch|]) in
       it_mkLambda_or_LetIn (mkLambda (x,rp,body)) params
   in
   let projections (na, b, t) (i, j, kns, pbs, subst) =
diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml
index a91c4f5ac..2df197546 100644
--- a/pretyping/detyping.ml
+++ b/pretyping/detyping.ml
@@ -487,8 +487,9 @@ let rec detype flags avoid env sigma t =
 	      let pb = Environ.lookup_projection p (snd env) in
 	      let body = pb.Declarations.proj_body in
 	      let ty = Retyping.get_type_of (snd env) sigma c in
-	      let (ind, args) = Inductiveops.find_mrectype (snd env) sigma ty in
+	      let ((ind,u), args) = Inductiveops.find_mrectype (snd env) sigma ty in
 	      let body' = strip_lam_assum body in
+	      let body' = subst_instance_constr u body' in
 		substl (c :: List.rev args) body'
 	    with Retyping.RetypeError _ | Not_found -> 
 	      anomaly (str"Cannot detype an unfolded primitive projection.")
diff --git a/pretyping/detyping.mli b/pretyping/detyping.mli
index b9fdb5cbe..725fff5b2 100644
--- a/pretyping/detyping.mli
+++ b/pretyping/detyping.mli
@@ -36,12 +36,12 @@ val detype_names : bool -> Id.t list -> names_context -> env -> evar_map -> cons
 val detype : ?lax:bool -> bool -> Id.t list -> env -> evar_map -> constr -> glob_constr
 
 val detype_case :
-  bool -> ('a -> glob_constr) ->
-  (constructor array -> bool list array -> 'a array ->
+  bool -> (constr -> glob_constr) ->
+  (constructor array -> bool list array -> constr array ->
     (Loc.t * Id.t list * cases_pattern list * glob_constr) list) ->
-  ('a -> bool list -> bool) ->
+  (constr -> bool list -> bool) ->
   Id.t list -> inductive * case_style * bool list array * bool list ->
-    'a option -> 'a -> 'a array -> glob_constr
+    constr option -> constr -> constr array -> glob_constr
 
 val detype_sort : sorts -> glob_sort
 
diff --git a/printing/prettyp.ml b/printing/prettyp.ml
index 3cade3b7b..223377c27 100644
--- a/printing/prettyp.ml
+++ b/printing/prettyp.ml
@@ -472,7 +472,9 @@ let print_constant with_values sep sp =
   let val_0 = Global.body_of_constant_body cb in
   let typ = Declareops.type_of_constant cb in
   let typ = ungeneralized_type_of_constant_type typ in
-  let univs = Univ.instantiate_univ_context (Global.universes_of_constant_body cb) in
+  let univs = Univ.instantiate_univ_context 
+    (Global.universes_of_constant_body cb)
+  in
   hov 0 (pr_polymorphic cb.const_polymorphic ++
     match val_0 with
     | None ->
@@ -720,8 +722,8 @@ let print_opaque_name qid =
 	  error "Not a defined constant."
     | IndRef (sp,_) ->
         print_inductive sp
-    | ConstructRef cstr ->
-	let ty = Inductiveops.type_of_constructor env (cstr,Univ.Instance.empty) in
+    | ConstructRef cstr as gr ->
+	let ty = Universes.unsafe_type_of_global gr in
 	print_typed_value (mkConstruct cstr, ty)
     | VarRef id ->
         let (_,c,ty) = lookup_named id env in