1 files changed, 47 insertions, 36 deletions

diff --git a/kernel/inductive.ml b/kernel/inductive.ml
index d751d9875a..ce12d65614 100644
--- a/kernel/inductive.ml
+++ b/kernel/inductive.ml
@@ -330,33 +330,45 @@ let check_allowed_sort ksort specif =
     let s = inductive_sort_family (snd specif) in
     raise (LocalArity (Some(elim_sort specif, ksort,s,error_elim_explain ksort s)))
 
-let is_correct_arity env c pj ind specif params =
+let check_correct_arity env c pj ind specif params =
+  (* We use l2r:true for compat with old versions which used CONV
+     instead of CUMUL called with arguments flipped. It is relevant
+     for performance eg in bedrock / Kami. *)
   let arsign,_ = get_instantiated_arity ind specif params in
-  let rec srec env pt ar =
+  let rec srec env ar pt =
     let pt' = whd_all env pt in
-    match kind pt', ar with
-      | Prod (na1,a1,t), (LocalAssum (_,a1'))::ar' ->
-          let () =
-            try conv env a1 a1'
-            with NotConvertible -> raise (LocalArity None) in
-          srec (push_rel (LocalAssum (na1,a1)) env) t ar'
-      (* The last Prod domain is the type of the scrutinee *)
-      | Prod (na1,a1,a2), [] -> (* whnf of t was not needed here! *)
-         let env' = push_rel (LocalAssum (na1,a1)) env in
-         let ksort = match kind (whd_all env' a2) with
-         | Sort s -> Sorts.family s
-         | _ -> raise (LocalArity None) in
-         let dep_ind = build_dependent_inductive ind specif params in
-         let _ =
-           try conv env a1 dep_ind
-           with NotConvertible -> raise (LocalArity None) in
-           check_allowed_sort ksort specif
-      | _, (LocalDef _ as d)::ar' ->
-          srec (push_rel d env) (lift 1 pt') ar'
-      | _ ->
-          raise (LocalArity None)
+    match ar, kind pt' with
+    | (LocalAssum (_,a1))::ar', Prod (na1,a1',t) ->
+      let () =
+        try conv_leq ~l2r:true env a1 a1'
+        with NotConvertible -> raise (LocalArity None) in
+      srec (push_rel (LocalAssum (na1,a1)) env) ar' t
+    (* The last Prod domain is the type of the scrutinee *)
+    | [], Prod (na1,a1',a2) ->
+      let env' = push_rel (LocalAssum (na1,a1')) env in
+      let ksort = match kind (whd_all env' a2) with
+      | Sort s -> Sorts.family s
+      | _ -> raise (LocalArity None)
+      in
+      let dep_ind = build_dependent_inductive ind specif params in
+      let () =
+        (* This ensures that the type of the scrutinee is <= the
+           inductive type declared in the predicate. *)
+        try conv_leq ~l2r:true env dep_ind a1'
+        with NotConvertible -> raise (LocalArity None)
+      in
+      let () = check_allowed_sort ksort specif in
+      (* We return the "higher" inductive universe instance from the predicate,
+         the branches must be typeable using these universes.
+         The find_rectype call cannot fail due to the cumulativity check above. *)
+      let (pind, _args) = find_rectype env a1' in
+      pind
+    | (LocalDef _ as d)::ar', _ ->
+      srec (push_rel d env) ar' (lift 1 pt')
+    | _ ->
+      raise (LocalArity None)
   in
-  try srec env pj.uj_type (List.rev arsign)
+  try srec env (List.rev arsign) pj.uj_type
   with LocalArity kinds ->
     error_elim_arity env ind c pj kinds
 
@@ -387,24 +399,23 @@ let build_branches_type (ind,u) (_,mip as specif) params p =
 let build_case_type env n p c realargs =
   whd_betaiota env (Term.lambda_appvect_assum (n+1) p (Array.of_list (realargs@[c])))
 
-let type_case_branches env (pind,largs) pj c =
-  let specif = lookup_mind_specif env (fst pind) in
+let type_case_branches env ((ind, _ as pind),largs) pj c =
+  let specif = lookup_mind_specif env ind in
   let nparams = inductive_params specif in
   let (params,realargs) = List.chop nparams largs in
   let p = pj.uj_val in
-  let () = is_correct_arity env c pj pind specif params in
+  let pind = check_correct_arity env c pj pind specif params in
   let lc = build_branches_type pind specif params p in
   let ty = build_case_type env (snd specif).mind_nrealdecls p c realargs in
   (lc, ty)
 
-
 (************************************************************************)
 (* Checking the case annotation is relevant *)
 
 let check_case_info env (indsp,u) r ci =
   let (mib,mip as spec) = lookup_mind_specif env indsp in
   if
-    not (eq_ind indsp ci.ci_ind) ||
+    not (Ind.CanOrd.equal indsp ci.ci_ind) ||
     not (Int.equal mib.mind_nparams ci.ci_npar) ||
     not (Array.equal Int.equal mip.mind_consnrealdecls ci.ci_cstr_ndecls) ||
     not (Array.equal Int.equal mip.mind_consnrealargs ci.ci_cstr_nargs) ||
@@ -467,12 +478,12 @@ let inter_recarg r1 r2 = match r1, r2 with
 | Norec, _ -> None
 | Mrec i1, Mrec i2
 | Nested (NestedInd i1), Nested (NestedInd i2)
-| Mrec i1, (Nested (NestedInd i2)) -> if Names.eq_ind i1 i2 then Some r1 else None
+| Mrec i1, (Nested (NestedInd i2)) -> if Names.Ind.CanOrd.equal i1 i2 then Some r1 else None
 | Mrec _, _ -> None
-| Nested (NestedInd i1), Mrec i2 -> if Names.eq_ind i1 i2 then Some r2 else None
+| Nested (NestedInd i1), Mrec i2 -> if Names.Ind.CanOrd.equal i1 i2 then Some r2 else None
 | Nested (NestedInd _), _ -> None
 | Nested (NestedPrimitive c1), Nested (NestedPrimitive c2) ->
-  if Names.Constant.equal c1 c2 then Some r1 else None
+  if Names.Constant.CanOrd.equal c1 c2 then Some r1 else None
 | Nested (NestedPrimitive _), _ -> None
 
 let inter_wf_paths = Rtree.inter Declareops.eq_recarg inter_recarg Norec
@@ -556,7 +567,7 @@ let lookup_subterms env ind =
 
 let match_inductive ind ra =
   match ra with
-    | Mrec i | Nested (NestedInd i) -> eq_ind ind i
+    | Mrec i | Nested (NestedInd i) -> Ind.CanOrd.equal ind i
     | Norec | Nested (NestedPrimitive _) -> false
 
 (* In {match c as z in ci y_s return P with |C_i x_s => t end}
@@ -644,7 +655,7 @@ let abstract_mind_lc ntyps npars lc =
 
 let is_primitive_positive_container env c =
   match env.retroknowledge.Retroknowledge.retro_array with
-  | Some c' when Constant.equal c c' -> true
+  | Some c' when QConstant.equal env c c' -> true
   | _ -> false
 
 (* [get_recargs_approx env tree ind args] builds an approximation of the recargs
@@ -667,13 +678,13 @@ let get_recargs_approx env tree ind args =
        (* When the inferred tree allows it, we consider that we have a potential
        nested inductive type *)
        begin match dest_recarg tree with
-             | Nested (NestedInd kn') | Mrec kn' when eq_ind (fst ind_kn) kn' ->
+             | Nested (NestedInd kn') | Mrec kn' when Ind.CanOrd.equal (fst ind_kn) kn' ->
                build_recargs_nested ienv tree (ind_kn, largs)
              | _ -> mk_norec
        end
     | Const (c,_) when is_primitive_positive_container env c ->
        begin match dest_recarg tree with
-             | Nested (NestedPrimitive c') when Constant.equal c c' ->
+             | Nested (NestedPrimitive c') when QConstant.equal env c c' ->
                build_recargs_nested_primitive ienv tree (c, largs)
              | _ -> mk_norec
        end