diff options
| -rw-r--r-- | kernel/indtypes.ml | 2 | ||||
| -rw-r--r-- | pretyping/detyping.ml | 3 | ||||
| -rw-r--r-- | pretyping/detyping.mli | 8 | ||||
| -rw-r--r-- | printing/prettyp.ml | 8 |
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 |