+and check_allowed_sort_elimination ~subst ~metasenv r =
+ let mkapp he arg =
+ match he with
+ | C.Appl l -> C.Appl (l @ [arg])
+ | t -> C.Appl [t;arg] in
+ let rec aux context ind arity1 arity2 =
+ let arity1 = R.whd ~subst context arity1 in
+ let arity2 = R.whd ~subst context arity2 in
+ match arity1,arity2 with
+ | C.Prod (name,so1,de1), C.Prod (_,so2,de2) ->
+ if not (R.are_convertible ~subst context so1 so2) then
+ raise (TypeCheckerFailure (lazy (Printf.sprintf
+ "In outtype: expected %s, found %s"
+ (PP.ppterm ~subst ~metasenv ~context so1)
+ (PP.ppterm ~subst ~metasenv ~context so2)
+ )));
+ aux ((name, C.Decl so1)::context)
+ (mkapp (S.lift 1 ind) (C.Rel 1)) de1 de2
+ | C.Sort _, C.Prod (name,so,ta) ->
+ if not (R.are_convertible ~subst context so ind) then
+ raise (TypeCheckerFailure (lazy (Printf.sprintf
+ "In outtype: expected %s, found %s"
+ (PP.ppterm ~subst ~metasenv ~context ind)
+ (PP.ppterm ~subst ~metasenv ~context so)
+ )));
+ (match arity1, R.whd ~subst ((name,C.Decl so)::context) ta with
+ | (C.Sort C.Type _, C.Sort _)
+ | (C.Sort C.Prop, C.Sort C.Prop) -> ()
+ | (C.Sort C.Prop, C.Sort C.Type _) ->
+ (* TODO: we should pass all these parameters since we
+ * have them already *)
+ let _,leftno,itl,_,i = E.get_checked_indtys r in
+ let itl_len = List.length itl in
+ let _,itname,ittype,cl = List.nth itl i in
+ let cl_len = List.length cl in
+ (* is it a singleton, non recursive and non informative
+ definition or an empty one? *)
+ if not
+ (cl_len = 0 ||
+ (itl_len = 1 && cl_len = 1 &&
+ let _,_,constrty = List.hd cl in
+ is_non_recursive_singleton r itname ittype constrty &&
+ is_non_informative leftno constrty))
+ then
+ raise (TypeCheckerFailure (lazy
+ ("Sort elimination not allowed")));
+ | _,_ -> ())
+ | _,_ -> ()
+ in
+ aux
+
+and eat_prods ~subst ~metasenv context he ty_he args_with_ty =
+ let rec aux ty_he = function
+ | [] -> ty_he
+ | (arg, ty_arg)::tl ->
+ match R.whd ~subst context ty_he with
+ | C.Prod (_,s,t) ->
+ if R.are_convertible ~subst context ty_arg s then
+ aux (S.subst ~avoid_beta_redexes:true arg t) tl
+ else
+ raise
+ (TypeCheckerFailure
+ (lazy (Printf.sprintf
+ ("Appl: wrong application of %s: the parameter %s has type"^^
+ "\n%s\nbut it should have type \n%s\nContext:\n%s\n")
+ (PP.ppterm ~subst ~metasenv ~context he)
+ (PP.ppterm ~subst ~metasenv ~context arg)
+ (PP.ppterm ~subst ~metasenv ~context ty_arg)
+ (PP.ppterm ~subst ~metasenv ~context s)
+ (PP.ppcontext ~subst ~metasenv context))))
+ | _ ->
+ raise
+ (TypeCheckerFailure
+ (lazy (Printf.sprintf
+ "Appl: %s is not a function, it cannot be applied"
+ (PP.ppterm ~subst ~metasenv ~context
+ (let res = List.length tl in
+ let eaten = List.length args_with_ty - res in
+ (C.Appl
+ (he::List.map fst
+ (fst (HExtlib.split_nth eaten args_with_ty)))))))))
+ in
+ aux ty_he args_with_ty
+
+and is_non_recursive_singleton (Ref.Ref (uri,_)) iname ity cty =
+ let ctx = [iname, C.Decl ity] in
+ let cty = debruijn uri 1 [] cty in
+ let len = List.length ctx in
+ let rec aux ctx n nn t =
+ match R.whd ctx t with
+ | C.Prod (name, src, tgt) ->
+ does_not_occur ~subst:[] ctx n nn src &&
+ aux ((name, C.Decl src) :: ctx) (n+1) (nn+1) tgt
+ | C.Rel k | C.Appl (C.Rel k :: _) when k = nn -> true
+ | _ -> assert false
+ in
+ aux ctx (len-1) len cty
+
+and is_non_informative paramsno c =
+ let rec aux context c =
+ match R.whd context c with
+ | C.Prod (n,so,de) ->
+ let s = typeof ~metasenv:[] ~subst:[] context so in
+ s = C.Sort C.Prop && aux ((n,(C.Decl so))::context) de
+ | _ -> true in
+ let context',dx = split_prods ~subst:[] [] paramsno c in
+ aux context' dx
+
+and check_mutual_inductive_defs uri ~metasenv ~subst leftno tyl =