aboutsummaryrefslogtreecommitdiff
path: root/kernel/indtypes.ml
diff options
context:
space:
mode:
Diffstat (limited to 'kernel/indtypes.ml')
-rw-r--r--kernel/indtypes.ml237
1 files changed, 135 insertions, 102 deletions
diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml
index 92e121402a..33abfe5b76 100644
--- a/kernel/indtypes.ml
+++ b/kernel/indtypes.ml
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -12,7 +12,6 @@ open Names
open Univ
open Term
open Vars
-open Context
open Declarations
open Declareops
open Inductive
@@ -21,6 +20,7 @@ open Reduction
open Typeops
open Entries
open Pp
+open Context.Rel.Declaration
(* Tell if indices (aka real arguments) contribute to size of inductive type *)
(* If yes, this is compatible with the univalent model *)
@@ -117,18 +117,18 @@ let is_unit constrsinfos =
| [] -> (* type without constructors *) true
| _ -> false
-let infos_and_sort env ctx t =
- let rec aux env ctx t max =
+let infos_and_sort env t =
+ let rec aux env 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 env1 = Environ.push_rel (LocalAssum (name,varj.utj_val)) env in
let max = Universe.sup max (univ_of_sort varj.utj_type) in
- aux env1 ctx c2 max
+ aux env1 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
+ in aux env t Universe.type0m
(* Computing the levels of polymorphic inductive types
@@ -153,14 +153,14 @@ let infos_and_sort env ctx t =
(* This (re)computes informations relevant to extraction and the sort of an
arity or type constructor; we do not to recompute universes constraints *)
-let infer_constructor_packet env_ar_par ctx params lc =
+let infer_constructor_packet env_ar_par params lc =
(* type-check the constructors *)
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 constructors types *)
- let levels = List.map (infos_and_sort env_ar_par ctx) lc in
+ let levels = List.map (infos_and_sort env_ar_par) lc in
let isunit = is_unit levels in
let min = if Array.length jlc > 1 then Universe.type0 else Universe.type0m in
let level = List.fold_left (fun max l -> Universe.sup max l) min levels in
@@ -169,47 +169,32 @@ let infer_constructor_packet env_ar_par ctx params lc =
(* If indices matter *)
let cumulate_arity_large_levels env sign =
fst (List.fold_right
- (fun (_,b,t as d) (lev,env) ->
- if Option.is_empty b then
+ (fun d (lev,env) ->
+ match d with
+ | LocalAssum (_,t) ->
let tj = infer_type env t in
let u = univ_of_sort tj.utj_type in
(Universe.sup u lev, push_rel d env)
- else lev, push_rel d env)
+ | LocalDef _ ->
+ 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)
+ is_type0m_univ u || (is_type0_univ u && is_impredicative_set env)
+(* Returns the list [x_1, ..., x_n] of levels contributing to template
+ polymorphism. The elements x_k is None if the k-th parameter (starting
+ from the most recent and ignoring let-definitions) is not contributing
+ or is Some u_k if its level is u_k and is contributing. *)
let param_ccls params =
- let has_some_univ u = function
- | Some v when Univ.Level.equal u v -> true
- | _ -> false
+ let fold acc = function (LocalAssum (_, p)) ->
+ (let c = strip_prod_assum p in
+ match kind_of_term c with
+ | Sort (Type u) -> Univ.Universe.level u
+ | _ -> None) :: acc
+ | LocalDef _ -> acc
in
- let remove_some_univ u = function
- | Some v when Univ.Level.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) ->
- (match Univ.Universe.level u with
- | Some u ->
- if List.exists (has_some_univ u) l then
- None :: List.map (remove_some_univ u) l
- else
- Some u :: l
- | None -> None :: l)
- | _ ->
- None :: l
- end
- | _ -> l
- in
- List.fold_left fold [] params
+ List.fold_left fold [] params
(* Type-check an inductive definition. Does not check positivity
conditions. *)
@@ -267,7 +252,7 @@ let typecheck_inductive env mie =
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) env_ar in
+ push_rel (LocalAssum (Name id, full_arity)) env_ar in
(* (add_constraints cst2 env_ar) in *)
(env_ar', (id,full_arity,sign @ params,expltype,deflev,inflev)::l))
(env',[])
@@ -283,8 +268,7 @@ let typecheck_inductive env mie =
List.fold_right2
(fun ind arity_data inds ->
let (lc',cstrs_univ) =
- infer_constructor_packet env_ar_par ContextSet.empty
- params ind.mind_entry_lc in
+ infer_constructor_packet env_ar_par params ind.mind_entry_lc in
let consnames = ind.mind_entry_consnames in
let ind' = (arity_data,consnames,lc',cstrs_univ) in
ind'::inds)
@@ -307,8 +291,7 @@ let typecheck_inductive env mie =
let full_polymorphic () =
let defu = Term.univ_of_sort def_level in
let is_natural =
- type_in_type env || (check_leq (universes env') infu defu &&
- not (is_type0m_univ defu && not is_unit))
+ type_in_type env || (UGraph.check_leq (universes env') infu defu)
in
let _ =
(** Impredicative sort, always allow *)
@@ -334,7 +317,7 @@ let typecheck_inductive env mie =
(* conclusions of the parameters *)
(* We enforce [u >= lev] in case [lev] has a strict upper *)
(* constraints over [u] *)
- let b = type_in_type env || check_leq (universes env') infu u in
+ let b = type_in_type env || UGraph.check_leq (universes env') infu u in
if not b then
anomaly ~label:"check_inductive"
(Pp.str"Incorrect universe " ++
@@ -360,8 +343,8 @@ let typecheck_inductive env mie =
type ill_formed_ind =
| LocalNonPos of int
| LocalNotEnoughArgs of int
- | LocalNotConstructor
- | LocalNonPar of int * int
+ | LocalNotConstructor of Context.Rel.t * int
+ | LocalNonPar of int * int * int
exception IllFormedInd of ill_formed_ind
@@ -371,7 +354,7 @@ exception IllFormedInd of ill_formed_ind
let mind_extract_params = decompose_prod_n_assum
-let explain_ind_err id ntyp env nbpar c nargs err =
+let explain_ind_err id ntyp env nbpar c err =
let (lpar,c') = mind_extract_params nbpar c in
match err with
| LocalNonPos kt ->
@@ -379,12 +362,13 @@ let explain_ind_err id ntyp env nbpar c nargs err =
| LocalNotEnoughArgs kt ->
raise (InductiveError
(NotEnoughArgs (env,c',mkRel (kt+nbpar))))
- | LocalNotConstructor ->
+ | LocalNotConstructor (paramsctxt,nargs)->
+ let nparams = Context.Rel.nhyps paramsctxt in
raise (InductiveError
- (NotConstructor (env,id,c',mkRel (ntyp+nbpar),nbpar,nargs)))
- | LocalNonPar (n,l) ->
+ (NotConstructor (env,id,c',mkRel (ntyp+nbpar),nparams,nargs)))
+ | LocalNonPar (n,i,l) ->
raise (InductiveError
- (NonPar (env,c',n,mkRel (nbpar-n+1), mkRel (l+nbpar))))
+ (NonPar (env,c',n,mkRel i, mkRel (l+nbpar))))
let failwith_non_pos n ntypes c =
for k = n to n + ntypes - 1 do
@@ -401,7 +385,7 @@ let failwith_non_pos_list n ntypes l =
(* Check the inductive type is called with the expected parameters *)
let check_correct_par (env,n,ntypes,_) hyps l largs =
- let nparams = rel_context_nhyps hyps in
+ let nparams = Context.Rel.nhyps hyps in
let largs = Array.of_list largs in
if Array.length largs < nparams then
raise (IllFormedInd (LocalNotEnoughArgs l));
@@ -409,11 +393,11 @@ let check_correct_par (env,n,ntypes,_) hyps l largs =
let nhyps = List.length hyps in
let rec check k index = function
| [] -> ()
- | (_,Some _,_)::hyps -> check k (index+1) hyps
+ | LocalDef _ :: hyps -> check k (index+1) hyps
| _::hyps ->
match kind_of_term (whd_betadeltaiota env lpar.(k)) with
| Rel w when Int.equal w index -> check (k-1) (index+1) hyps
- | _ -> raise (IllFormedInd (LocalNonPar (k+1,l)))
+ | _ -> raise (IllFormedInd (LocalNonPar (k+1, index-n+nhyps+1, l)))
in check (nparams-1) (n-nhyps) hyps;
if not (Array.for_all (noccur_between n ntypes) largs') then
failwith_non_pos_vect n ntypes largs'
@@ -431,7 +415,7 @@ if Int.equal nmr 0 then 0 else
function
([],_) -> nmr
| (_,[]) -> assert false (* |hyps|>=nmr *)
- | (lp,(_,Some _,_)::hyps) -> find k (index-1) (lp,hyps)
+ | (lp, LocalDef _ :: hyps) -> find k (index-1) (lp,hyps)
| (p::lp,_::hyps) ->
( match kind_of_term (whd_betadeltaiota env p) with
| Rel w when Int.equal w index -> find (k+1) (index-1) (lp,hyps)
@@ -445,15 +429,15 @@ if Int.equal nmr 0 then 0 else
[lra] is the list of recursive tree of each variable
*)
let ienv_push_var (env, n, ntypes, lra) (x,a,ra) =
- (push_rel (x,None,a) env, n+1, ntypes, (Norec,ra)::lra)
+ (push_rel (LocalAssum (x,a)) env, n+1, ntypes, (Norec,ra)::lra)
let ienv_push_inductive (env, n, ntypes, ra_env) ((mi,u),lpar) =
let auxntyp = 1 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 ty lpar) env in
+ let decl = LocalAssum (Anonymous, hnf_prod_applist env ty lpar) in
+ push_rel decl 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
@@ -481,9 +465,9 @@ let array_min nmr a = if Int.equal nmr 0 then 0 else
considered sub-terms) as well as the number of of non-uniform
arguments (used to generate induction schemes, so a priori less
relevant to the kernel). *)
-let check_positivity_one (env,_,ntypes,_ as ienv) hyps (_,i as ind) nargs lcnames indlc =
- let lparams = rel_context_length hyps in
- let nmr = rel_context_nhyps hyps in
+let check_positivity_one recursive (env,_,ntypes,_ as ienv) hyps (_,i as ind) nargs lcnames indlc =
+ let lparams = Context.Rel.length hyps in
+ let nmr = Context.Rel.nhyps hyps in
(** Positivity of one argument [c] of a constructor (i.e. the
constructor [cn] has a type of the shape [… -> c … -> P], where,
more generally, the arrows may be dependent). *)
@@ -596,6 +580,8 @@ let check_positivity_one (env,_,ntypes,_ as ienv) hyps (_,i as ind) nargs lcname
| Prod (na,b,d) ->
let () = assert (List.is_empty largs) in
+ if not recursive && not (noccur_between n ntypes b) then
+ raise (InductiveError BadEntry);
let nmr',recarg = check_pos ienv nmr b in
let ienv' = ienv_push_var ienv (na,b,mk_norec) in
check_constr_rec ienv' nmr' (recarg::lrec) d
@@ -605,7 +591,7 @@ let check_positivity_one (env,_,ntypes,_ as ienv) hyps (_,i as ind) nargs lcname
begin match hd with
| Rel j when Int.equal j (n + ntypes - i - 1) ->
check_correct_par ienv hyps (ntypes - i) largs
- | _ -> raise (IllFormedInd LocalNotConstructor)
+ | _ -> raise (IllFormedInd (LocalNotConstructor(hyps,nargs)))
end
else
if not (List.for_all (noccur_between n ntypes) largs)
@@ -621,7 +607,7 @@ let check_positivity_one (env,_,ntypes,_ as ienv) hyps (_,i as ind) nargs lcname
try
check_constructors ienv true nmr rawc
with IllFormedInd err ->
- explain_ind_err id (ntypes-i) env lparams c nargs err)
+ explain_ind_err id (ntypes-i) env lparams c err)
(Array.of_list lcnames) indlc
in
let irecargs = Array.map snd irecargs_nmr
@@ -630,18 +616,20 @@ let check_positivity_one (env,_,ntypes,_ as ienv) hyps (_,i as ind) nargs lcname
(** [check_positivity kn env_ar params] checks that the mutually
inductive block [inds] is strictly positive. *)
-let check_positivity kn env_ar params inds =
+let check_positivity kn env_ar params finite inds =
let ntypes = Array.length inds in
- let rc = Array.mapi (fun j t -> (Mrec (kn,j),t)) (Rtree.mk_rec_calls ntypes) in
+ let recursive = finite != Decl_kinds.BiFinite in
+ let rc = Array.mapi (fun j t -> (Mrec (kn,j),t))
+ (Rtree.mk_rec_calls ntypes) in
let lra_ind = Array.rev_to_list rc in
- let lparams = rel_context_length params in
- let nmr = rel_context_nhyps params in
+ let lparams = Context.Rel.length params in
+ let nmr = Context.Rel.nhyps params in
let check_one i (_,lcnames,lc,(sign,_)) =
let ra_env =
List.init lparams (fun _ -> (Norec,mk_norec)) @ lra_ind in
let ienv = (env_ar, 1+lparams, ntypes, ra_env) in
- let nargs = rel_context_nhyps sign - nmr in
- check_positivity_one ienv params (kn,i) nargs lcnames lc
+ let nargs = Context.Rel.nhyps sign - nmr in
+ check_positivity_one recursive ienv params (kn,i) nargs lcnames lc
in
let irecargs_nmr = Array.mapi check_one inds in
let irecargs = Array.map snd irecargs_nmr
@@ -698,6 +686,7 @@ let used_section_variables env inds =
keep_hyps env ids
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)
exception UndefinableExpansion
@@ -705,13 +694,28 @@ exception UndefinableExpansion
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_projections ((kn, _ as ind), u as indsp) n x nparamargs params
- mind_consnrealdecls mind_consnrealargs ctx =
+let compute_projections ((kn, _ as ind), u as indu) n x nparamargs params
+ mind_consnrealdecls mind_consnrealargs paramslet ctx =
let mp, dp, l = repr_mind kn in
- let rp = mkApp (mkIndU indsp, rel_vect 0 nparamargs) in
+ (** We build a substitution smashing the lets in the record parameters so
+ that typechecking projections requires just a substitution and not
+ matching with a parameter context. *)
+ let indty, paramsletsubst =
+ (* [ty] = [Ind inst] is typed in context [params] *)
+ let inst = Context.Rel.to_extended_vect 0 paramslet in
+ let ty = mkApp (mkIndU indu, inst) in
+ (* [Ind inst] is typed in context [params-wo-let] *)
+ let inst' = rel_list 0 nparamargs in
+ (* {params-wo-let |- subst:params] *)
+ let subst = subst_of_rel_context_instance paramslet inst' in
+ (* {params-wo-let, x:Ind inst' |- subst':(params,x:Ind inst)] *)
+ let subst = (* For the record parameter: *)
+ mkRel 1 :: List.map (lift 1) subst in
+ ty, subst
+ in
let ci =
let print_info =
- { ind_tags = []; cstr_tags = [|rel_context_tags ctx|]; style = LetStyle } in
+ { ind_tags = []; cstr_tags = [|Context.Rel.to_tags ctx|]; style = LetStyle } in
{ ci_ind = ind;
ci_npar = nparamargs;
ci_cstr_ndecls = mind_consnrealdecls;
@@ -721,34 +725,62 @@ let compute_projections ((kn, _ as ind), u as indsp) n x nparamargs params
let len = List.length ctx in
let x = Name x in
let compat_body ccl i =
- (* [ccl] is defined in context [params;x:rp] *)
- (* [ccl'] is defined in context [params;x:rp;x:rp] *)
+ (* [ccl] is defined in context [params;x:indty] *)
+ (* [ccl'] is defined in context [params;x:indty;x:indty] *)
let ccl' = liftn 1 2 ccl in
- let p = mkLambda (x, lift 1 rp, ccl') in
+ let p = mkLambda (x, lift 1 indty, ccl') in
let branch = it_mkLambda_or_LetIn (mkRel (len - i)) ctx in
let body = mkCase (ci, p, mkRel 1, [|lift 1 branch|]) in
- it_mkLambda_or_LetIn (mkLambda (x,rp,body)) params
+ it_mkLambda_or_LetIn (mkLambda (x,indty,body)) params
in
- let projections (na, b, t) (i, j, kns, pbs, subst) =
- match b with
- | Some c -> (i, j+1, kns, pbs, substl subst c :: subst)
- | None ->
+ let projections decl (i, j, kns, pbs, subst, letsubst) =
+ match decl with
+ | LocalDef (na,c,t) ->
+ (* From [params, field1,..,fieldj |- c(params,field1,..,fieldj)]
+ to [params, x:I, field1,..,fieldj |- c(params,field1,..,fieldj)] *)
+ let c = liftn 1 j c in
+ (* From [params, x:I, field1,..,fieldj |- c(params,field1,..,fieldj)]
+ to [params, x:I |- c(params,proj1 x,..,projj x)] *)
+ let c1 = substl subst c in
+ (* From [params, x:I |- subst:field1,..,fieldj]
+ to [params, x:I |- subst:field1,..,fieldj+1] where [subst]
+ is represented with instance of field1 last *)
+ let subst = c1 :: subst in
+ (* From [params, x:I, field1,..,fieldj |- c(params,field1,..,fieldj)]
+ to [params-wo-let, x:I |- c(params,proj1 x,..,projj x)] *)
+ let c2 = substl letsubst c in
+ (* From [params-wo-let, x:I |- subst:(params, x:I, field1,..,fieldj)]
+ to [params-wo-let, x:I |- subst:(params, x:I, field1,..,fieldj+1)] *)
+ let letsubst = c2 :: letsubst in
+ (i, j+1, kns, pbs, subst, letsubst)
+ | LocalAssum (na,t) ->
match na with
| Name id ->
let kn = Constant.make1 (KerName.make mp dp (Label.of_id id)) in
- let ty = substl subst (liftn 1 j t) in
+ (* from [params, field1,..,fieldj |- t(params,field1,..,fieldj)]
+ to [params, x:I, field1,..,fieldj |- t(params,field1,..,fieldj] *)
+ let t = liftn 1 j t in
+ (* from [params, x:I, field1,..,fieldj |- t(params,field1,..,fieldj)]
+ to [params-wo-let, x:I |- t(params,proj1 x,..,projj x)] *)
+ let projty = substl letsubst t in
+ (* from [params, x:I, field1,..,fieldj |- t(field1,..,fieldj)]
+ to [params, x:I |- t(proj1 x,..,projj x)] *)
+ let ty = substl subst t in
let term = mkProj (Projection.make kn true, mkRel 1) in
let fterm = mkProj (Projection.make kn false, mkRel 1) in
let compat = compat_body ty (j - 1) in
- let etab = it_mkLambda_or_LetIn (mkLambda (x, rp, term)) params in
- let etat = it_mkProd_or_LetIn (mkProd (x, rp, ty)) params in
+ let etab = it_mkLambda_or_LetIn (mkLambda (x, indty, term)) params in
+ let etat = it_mkProd_or_LetIn (mkProd (x, indty, ty)) params in
let body = { proj_ind = fst ind; proj_npars = nparamargs;
- proj_arg = i; proj_type = ty; proj_eta = etab, etat;
+ proj_arg = i; proj_type = projty; proj_eta = etab, etat;
proj_body = compat } in
- (i + 1, j + 1, kn :: kns, body :: pbs, fterm :: subst)
+ (i + 1, j + 1, kn :: kns, body :: pbs,
+ fterm :: subst, fterm :: letsubst)
| Anonymous -> raise UndefinableExpansion
in
- let (_, _, kns, pbs, subst) = List.fold_right projections ctx (0, 1, [], [], []) in
+ let (_, _, kns, pbs, subst, letsubst) =
+ List.fold_right projections ctx (0, 1, [], [], [], paramsletsubst)
+ in
Array.of_list (List.rev kns),
Array.of_list (List.rev pbs)
@@ -756,8 +788,8 @@ let build_inductive env p prv ctx env_ar params kn isrecord isfinite inds nmr re
let ntypes = Array.length inds in
(* Compute the set of used section variables *)
let hyps = used_section_variables env inds in
- let nparamargs = rel_context_nhyps params in
- let nparamdecls = rel_context_length params in
+ let nparamargs = Context.Rel.nhyps params in
+ let nparamdecls = Context.Rel.length params in
let subst, ctx = Univ.abstract_universes p ctx in
let params = Vars.subst_univs_level_context subst params in
let env_ar =
@@ -772,10 +804,10 @@ let build_inductive env p prv ctx env_ar params kn isrecord isfinite inds nmr re
let splayed_lc = Array.map (dest_prod_assum env_ar) lc in
let nf_lc = Array.map (fun (d,b) -> it_mkProd_or_LetIn b d) splayed_lc in
let consnrealdecls =
- Array.map (fun (d,_) -> rel_context_length d - rel_context_length params)
+ Array.map (fun (d,_) -> Context.Rel.length d - Context.Rel.length params)
splayed_lc in
let consnrealargs =
- Array.map (fun (d,_) -> rel_context_nhyps d - rel_context_nhyps params)
+ Array.map (fun (d,_) -> Context.Rel.nhyps d - Context.Rel.nhyps params)
splayed_lc in
(* Elimination sorts *)
let arkind,kelim =
@@ -808,8 +840,8 @@ let build_inductive env p prv ctx env_ar params kn isrecord isfinite inds nmr re
{ mind_typename = id;
mind_arity = arkind;
mind_arity_ctxt = Vars.subst_univs_level_context subst ar_sign;
- mind_nrealargs = rel_context_nhyps ar_sign - nparamargs;
- mind_nrealdecls = rel_context_length ar_sign - nparamdecls;
+ mind_nrealargs = Context.Rel.nhyps ar_sign - nparamargs;
+ mind_nrealdecls = Context.Rel.length ar_sign - nparamdecls;
mind_kelim = kelim;
mind_consnames = Array.of_list cnames;
mind_consnrealdecls = consnrealdecls;
@@ -822,10 +854,11 @@ let build_inductive env p prv ctx env_ar params kn isrecord isfinite inds nmr re
mind_reloc_tbl = rtbl;
} in
let packets = Array.map2 build_one_packet inds recargs in
- let pkt = packets.(0) in
+ let pkt = packets.(0) in
let isrecord =
match isrecord with
- | Some (Some rid) when pkt.mind_kelim == all_sorts && Array.length pkt.mind_consnames == 1
+ | Some (Some rid) when pkt.mind_kelim == all_sorts
+ && Array.length pkt.mind_consnames == 1
&& pkt.mind_consnrealargs.(0) > 0 ->
(** The elimination criterion ensures that all projections can be defined. *)
let u =
@@ -834,12 +867,12 @@ let build_inductive env p prv ctx env_ar params kn isrecord isfinite inds nmr re
else Univ.Instance.empty
in
let indsp = ((kn, 0), u) in
- let rctx, _ = decompose_prod_assum (subst1 (mkIndU indsp) pkt.mind_nf_lc.(0)) in
+ let rctx, indty = decompose_prod_assum (subst1 (mkIndU indsp) pkt.mind_nf_lc.(0)) in
(try
- let fields = List.firstn pkt.mind_consnrealdecls.(0) rctx in
+ let fields, paramslet = List.chop pkt.mind_consnrealdecls.(0) rctx in
let kns, projs =
compute_projections indsp pkt.mind_typename rid nparamargs params
- pkt.mind_consnrealdecls pkt.mind_consnrealargs fields
+ pkt.mind_consnrealdecls pkt.mind_consnrealargs paramslet fields
in Some (Some (rid, kns, projs))
with UndefinableExpansion -> Some None)
| Some _ -> Some None
@@ -866,7 +899,7 @@ let check_inductive env kn mie =
(* First type-check the inductive definition *)
let (env_ar, env_ar_par, params, inds) = typecheck_inductive env mie in
(* Then check positivity conditions *)
- let (nmr,recargs) = check_positivity kn env_ar_par params inds in
+ let (nmr,recargs) = check_positivity kn env_ar_par params mie.mind_entry_finite inds in
(* Build the inductive packets *)
build_inductive env mie.mind_entry_polymorphic mie.mind_entry_private
mie.mind_entry_universes