diff options
Diffstat (limited to 'kernel/indtypes.ml')
| -rw-r--r-- | kernel/indtypes.ml | 37 |
1 files changed, 12 insertions, 25 deletions
diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index e63f43849a..d7eb865e0a 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -120,16 +120,6 @@ let mind_check_names mie = (* Typing the arities and constructor types *) -(* An inductive definition is a "unit" if it has only one constructor - and that all arguments expected by this constructor are - logical, this is the case for equality, conjunction of logical properties -*) -let is_unit constrsinfos = - match constrsinfos with (* One info = One constructor *) - | [level] -> is_type0m_univ level - | [] -> (* type without constructors *) true - | _ -> false - let infos_and_sort env t = let rec aux env t max = let t = whd_all env t in @@ -174,10 +164,9 @@ let infer_constructor_packet env_ar_par params lc = let lc'' = Array.map (fun j -> Term.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) 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 - (lc'', (isunit, level)) + (lc'', level) (* If indices matter *) let cumulate_arity_large_levels env sign = @@ -354,7 +343,7 @@ let typecheck_inductive env mie = (* Compute/check the sorts of the inductive types *) let inds = - Array.map (fun ((id,full_arity,sign,expltype,def_level,inf_level),cn,lc,(is_unit,clev)) -> + Array.map (fun ((id,full_arity,sign,expltype,def_level,inf_level),cn,lc,clev) -> let infu = (** Inferred level, with parameters and constructors. *) match inf_level with @@ -425,7 +414,7 @@ let typecheck_inductive env mie = type ill_formed_ind = | LocalNonPos of int | LocalNotEnoughArgs of int - | LocalNotConstructor of Context.Rel.t * int + | LocalNotConstructor of Constr.rel_context * int | LocalNonPar of int * int * int exception IllFormedInd of ill_formed_ind @@ -807,7 +796,6 @@ let compute_projections (kn, i as ind) mib = let subst = List.init mib.mind_ntypes (fun i -> mkIndU ((kn, mib.mind_ntypes - i - 1), u)) in let rctx, _ = decompose_prod_assum (substl subst pkt.mind_nf_lc.(0)) in let ctx, paramslet = List.chop pkt.mind_consnrealdecls.(0) rctx in - let mp, dp, l = MutInd.repr3 kn 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. *) @@ -821,7 +809,7 @@ let compute_projections (kn, i as ind) mib = mkRel 1 :: List.map (lift 1) subst in subst in - let projections decl (i, j, kns, pbs, letsubst) = + let projections decl (i, j, labs, pbs, letsubst) = match decl with | LocalDef (na,c,t) -> (* From [params, field1,..,fieldj |- c(params,field1,..,fieldj)] @@ -833,11 +821,12 @@ let compute_projections (kn, i as ind) mib = (* 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, letsubst) + (i, j+1, labs, pbs, letsubst) | LocalAssum (na,t) -> match na with | Name id -> - let kn = Constant.make1 (KerName.make mp dp (Label.of_id id)) in + let lab = Label.of_id id in + let kn = Projection.Repr.make ind ~proj_npars:mib.mind_nparams ~proj_arg:i lab 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 @@ -847,15 +836,13 @@ let compute_projections (kn, i as ind) mib = (* from [params, x:I, field1,..,fieldj |- t(field1,..,fieldj)] to [params, x:I |- t(proj1 x,..,projj x)] *) let fterm = mkProj (Projection.make kn false, mkRel 1) in - let body = { proj_ind = ind; proj_npars = mib.mind_nparams; - proj_arg = i; proj_type = projty; } in - (i + 1, j + 1, kn :: kns, body :: pbs, fterm :: letsubst) + (i + 1, j + 1, lab :: labs, projty :: pbs, fterm :: letsubst) | Anonymous -> raise UndefinableExpansion in - let (_, _, kns, pbs, letsubst) = + let (_, _, labs, pbs, letsubst) = List.fold_right projections ctx (0, 1, [], [], paramsletsubst) in - Array.of_list (List.rev kns), + Array.of_list (List.rev labs), Array.of_list (List.rev pbs) let abstract_inductive_universes iu = @@ -965,8 +952,8 @@ let build_inductive env prv iu env_ar paramsctxt kn isrecord isfinite inds nmr r (** The elimination criterion ensures that all projections can be defined. *) if Array.for_all is_record packets then let map i id = - let kn, projs = compute_projections (kn, i) mib in - (id, kn, projs) + let labs, projs = compute_projections (kn, i) mib in + (id, labs, projs) in try PrimRecord (Array.mapi map rid) with UndefinableExpansion -> FakeRecord |