From a7ed091b6842cc78f0480504e84c3cfa261860bd Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 25 May 2016 13:38:51 +0200 Subject: Move is_prim... to Inductiveops and correct Scheme Now scheme will not try to build ill-typed dependent analyses on recursive records with primitive projections but report a proper error. Minor change of the API (adding one error case to recursion_scheme_error). --- pretyping/indrec.ml | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) (limited to 'pretyping/indrec.ml') diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml index 0c80bd019..012c97549 100644 --- a/pretyping/indrec.ml +++ b/pretyping/indrec.ml @@ -36,6 +36,7 @@ type dep_flag = bool type recursion_scheme_error = | NotAllowedCaseAnalysis of (*isrec:*) bool * sorts * pinductive | NotMutualInScheme of inductive * inductive + | NotAllowedDependentAnalysis of (*isrec:*) bool * inductive exception RecursionSchemeError of recursion_scheme_error @@ -483,6 +484,8 @@ let mis_make_indrec env sigma listdepkind mib u = let build_case_analysis_scheme env sigma pity dep kind = let (mib,mip) = lookup_mind_specif env (fst pity) in + if dep && Inductiveops.is_primitive_record_without_eta mib then + raise (RecursionSchemeError (NotAllowedDependentAnalysis (false, fst pity))); mis_make_case_com dep env sigma pity (mib,mip) kind let is_in_prop mip = @@ -492,7 +495,7 @@ let is_in_prop mip = let build_case_analysis_scheme_default env sigma pity kind = let (mib,mip) = lookup_mind_specif env (fst pity) in - let dep = not (is_in_prop mip) in + let dep = not (is_in_prop mip || Inductiveops.is_primitive_record_without_eta mib) in mis_make_case_com dep env sigma pity (mib,mip) kind (**********************************************************************) @@ -553,6 +556,8 @@ let check_arities env listdepkind = let build_mutual_induction_scheme env sigma = function | ((mind,u),dep,s)::lrecspec -> let (mib,mip) = lookup_mind_specif env mind in + if dep && Inductiveops.is_primitive_record_without_eta mib then + raise (RecursionSchemeError (NotAllowedDependentAnalysis (true, mind))); let (sp,tyi) = mind in let listdepkind = ((mind,u),mib,mip,dep,s):: @@ -572,6 +577,8 @@ let build_mutual_induction_scheme env sigma = function let build_induction_scheme env sigma pind dep kind = let (mib,mip) = lookup_mind_specif env (fst pind) in + if dep && Inductiveops.is_primitive_record_without_eta mib then + raise (RecursionSchemeError (NotAllowedDependentAnalysis (true, fst pind))); let sigma, l = mis_make_indrec env sigma [(pind,mib,mip,dep,kind)] mib (snd pind) in sigma, List.hd l -- cgit v1.2.3