diff options
Diffstat (limited to 'pretyping/inductiveops.ml')
| -rw-r--r-- | pretyping/inductiveops.ml | 40 |
1 files changed, 21 insertions, 19 deletions
diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index 1003f86c5..576073344 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -277,8 +277,8 @@ let projection_nparams p = projection_nparams_env (Global.env ()) p let has_dependent_elim mib = match mib.mind_record with - | Some (Some _) -> mib.mind_finite == BiFinite - | _ -> true + | PrimRecord _ -> mib.mind_finite == BiFinite + | NotRecord | FakeRecord -> true (* Annotation for cases *) let make_case_info env ind style = @@ -303,7 +303,7 @@ type constructor_summary = { cs_cstr : pconstructor; cs_params : constr list; cs_nargs : int; - cs_args : Context.Rel.t; + cs_args : Constr.rel_context; cs_concl_realargs : constr array } @@ -346,8 +346,10 @@ let get_constructors env (ind,params) = let get_projections env (ind,params) = let (mib,mip) = Inductive.lookup_mind_specif env (fst ind) in match mib.mind_record with - | Some (Some (id, projs, pbs)) -> Some projs - | _ -> None + | PrimRecord infos -> + let (_, projs, _) = infos.(snd (fst ind)) in + Some projs + | NotRecord | FakeRecord -> None let make_case_or_project env sigma indf ci pred c branches = let open EConstr in @@ -460,25 +462,24 @@ let build_branch_type env sigma dep p cs = 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 env (kn, _ as ind) = +let compute_projections env (kn, i as ind) = let open Term in let mib = Environ.lookup_mind kn env in - let indu = match mib.mind_universes with - | Monomorphic_ind _ -> mkInd ind - | Polymorphic_ind ctx -> mkIndU (ind, make_abstract_instance ctx) - | Cumulative_ind ctx -> - mkIndU (ind, make_abstract_instance (ACumulativityInfo.univ_context ctx)) + let u = match mib.mind_universes with + | Monomorphic_ind _ -> Instance.empty + | Polymorphic_ind auctx -> make_abstract_instance auctx + | Cumulative_ind acumi -> + make_abstract_instance (ACumulativityInfo.univ_context acumi) in let x = match mib.mind_record with - | None | Some None -> + | NotRecord | FakeRecord -> anomaly Pp.(str "Trying to build primitive projections for a non-primitive record") - | Some (Some (id, _, _)) -> Name id + | PrimRecord info-> Name (pi1 (info.(i))) in - (** FIXME: handle mutual records *) - let pkt = mib.mind_packets.(0) in - let { mind_consnrealargs; mind_consnrealdecls } = pkt in + let pkt = mib.mind_packets.(i) in let { mind_nparams = nparamargs; mind_params_ctxt = params } = mib in - let rctx, _ = decompose_prod_assum (subst1 indu pkt.mind_nf_lc.(0)) in + 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 @@ -487,6 +488,7 @@ let compute_projections env (kn, _ as ind) = let indty = (* [ty] = [Ind inst] is typed in context [params] *) let inst = Context.Rel.to_extended_vect mkRel 0 paramslet in + let indu = mkIndU (ind, u) in let ty = mkApp (indu, inst) in (* [Ind inst] is typed in context [params-wo-let] *) ty @@ -496,8 +498,8 @@ let compute_projections env (kn, _ as ind) = { ind_tags = []; cstr_tags = [|Context.Rel.to_tags ctx|]; style = LetStyle } in { ci_ind = ind; ci_npar = nparamargs; - ci_cstr_ndecls = mind_consnrealdecls; - ci_cstr_nargs = mind_consnrealargs; + ci_cstr_ndecls = pkt.mind_consnrealdecls; + ci_cstr_nargs = pkt.mind_consnrealargs; ci_pp_info = print_info } in let len = List.length ctx in |