From a5d124dd7c3d43a5ead81cfac30c7d1448002d56 Mon Sep 17 00:00:00 2001
From: Gaëtan Gilbert
Date: Fri, 15 Nov 2019 15:53:48 +0100
Subject: Fix #11039: proof of False with template poly and nonlinear universes

Using the parameter universes in the constructor causes implicit
equality constraints, so those universes may not be template
polymorphic.

A couple types in the stdlib were erroneously marked template, which
is now detected. Removing the marking doesn't actually change
behaviour though.

Also fixes #10504.
---
 kernel/indTyping.ml  | 28 +++++++++++++++++++++++++---
 kernel/indTyping.mli |  1 +
 2 files changed, 26 insertions(+), 3 deletions(-)

(limited to 'kernel')

diff --git a/kernel/indTyping.ml b/kernel/indTyping.ml
index 06d2e1bb21..2b5409c1ab 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,7 +303,28 @@ 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"
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 ->
-- 
cgit v1.2.3


From 1db8720bf624c202dcc4f1eecdcde803fed4efc2 Mon Sep 17 00:00:00 2001
From: Gaëtan Gilbert
Date: Tue, 19 Nov 2019 14:28:37 +0100
Subject: indTyping: error instead of anomaly for ill-formed template

and do not run template_candidate in the upper layers when the
template attribute is given.

This means we can use an over-approximation in the upper layer
implementation of template_candidate (returning false even in cases
which the kernel may accept) if we ever want to.
---
 kernel/indTyping.ml | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'kernel')

diff --git a/kernel/indTyping.ml b/kernel/indTyping.ml
index 2b5409c1ab..c91cb39fe2 100644
--- a/kernel/indTyping.ml
+++ b/kernel/indTyping.ml
@@ -327,7 +327,7 @@ let abstract_packets ~template_check univs usubst params ((arity,lc),(indices,sp
       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}
-- 
cgit v1.2.3