Merge PR #11128: Fix #11039: proof of False with template poly and nonlinear universes

Reviewed-by: Zimmi48
Reviewed-by: mattam82
Reviewed-by: ppedrot

2 files changed, 27 insertions, 4 deletions

diff --git a/kernel/indTyping.ml b/kernel/indTyping.ml
index 06d2e1bb21..c91cb39fe2 100644
--- a/kernel/indTyping.ml
+++ b/kernel/indTyping.ml
@@ -253,10 +253,11 @@ let unbounded_from_below u cstrs =
    (starting from the most recent and ignoring let-definitions) is not
    contributing to the inductive type's sort or is Some u_k if its level
    is u_k and is contributing. *)
-let template_polymorphic_univs ~template_check uctx paramsctxt concl =
+let template_polymorphic_univs ~template_check ~ctor_levels uctx paramsctxt concl =
   let check_level l =
     if Univ.LSet.mem l (Univ.ContextSet.levels uctx) &&
-       unbounded_from_below l (Univ.ContextSet.constraints uctx) then
+       unbounded_from_below l (Univ.ContextSet.constraints uctx) &&
+       not (Univ.LSet.mem l ctor_levels) then
       Some l
     else None
   in
@@ -302,10 +303,31 @@ let abstract_packets ~template_check univs usubst params ((arity,lc),(indices,sp
           | Polymorphic _ ->
             CErrors.anomaly ~label:"polymorphic_template_ind"
               Pp.(strbrk "Template polymorphism and full polymorphism are incompatible.") in
-      let param_levels, concl_levels = template_polymorphic_univs ~template_check ctx params min_univ in
+      let ctor_levels =
+        let add_levels c levels = Univ.LSet.union levels (Vars.universes_of_constr c) in
+        let param_levels =
+          List.fold_left (fun levels d -> match d with
+              | LocalAssum _ -> levels
+              | LocalDef (_,b,t) -> add_levels b (add_levels t levels))
+            Univ.LSet.empty params
+        in
+        Array.fold_left
+          (fun levels (d,c) ->
+             let levels =
+               List.fold_left (fun levels d ->
+                   Context.Rel.Declaration.fold_constr add_levels d levels)
+                 levels d
+             in
+             add_levels c levels)
+          param_levels
+          splayed_lc
+      in
+      let param_levels, concl_levels =
+        template_polymorphic_univs ~template_check ~ctor_levels ctx params min_univ
+      in
       if template_check && List.for_all (fun x -> Option.is_empty x) param_levels
          && Univ.LSet.is_empty concl_levels then
-        CErrors.anomaly ~label:"polymorphic_template_ind"
+        CErrors.user_err
           Pp.(strbrk "Ill-formed template inductive declaration: not polymorphic on any universe.")
       else
         TemplateArity {template_param_levels = param_levels; template_level = min_univ}
diff --git a/kernel/indTyping.mli b/kernel/indTyping.mli
index 8da4e2885c..5c04e860a2 100644
--- a/kernel/indTyping.mli
+++ b/kernel/indTyping.mli
@@ -38,6 +38,7 @@ val typecheck_inductive : env -> mutual_inductive_entry ->
    of a template polymorphic inductive *)
 val template_polymorphic_univs :
   template_check:bool ->
+  ctor_levels:Univ.LSet.t ->
   Univ.ContextSet.t ->
   Constr.rel_context ->
   Univ.Universe.t ->