+ let add_params
+ metasenv subst context uri tyno cty outty leftno i
+ =
+ let mytl = function [] -> [] | _::tl -> tl in
+ let rec aux context outty par k = function
+ | Cic.Prod (name, src, tgt) ->
+ Cic.Prod (name, src,
+ aux
+ (Some (name, Cic.Decl src) :: context)
+ (CS.lift 1 outty) (Cic.Rel k::par) (k+1) tgt)
+ | Cic.MutInd _ ->
+ let par = mytl par in
+ let k =
+ let k = Cic.MutConstruct (uri,tyno,i,[]) in
+ if par <> [] then Cic.Appl (k::par) else k
+ in
+ CR.head_beta_reduce ~delta:false
+ (Cic.Appl [outty;k])
+ | Cic.Appl (Cic.MutInd _::pl) ->
+ let left_p,_ = HExtlib.split_nth leftno pl in
+ let k =
+ let k = Cic.MutConstruct (uri,tyno,i,[]) in
+ Cic.Appl (k::left_p@par)
+ in
+ let right_p =
+ try match
+ CicTypeChecker.type_of_aux' ~subst metasenv context k
+ CicUniv.oblivion_ugraph
+ with
+ | Cic.Appl (Cic.MutInd _::args),_ ->
+ snd (HExtlib.split_nth leftno args)
+ | _ -> assert false
+ with CicTypeChecker.TypeCheckerFailure _ -> assert false
+ in
+ CR.head_beta_reduce ~delta:false
+ (Cic.Appl (outty ::right_p @ [k]))
+ | _ -> assert false
+ in
+ aux context outty [] 1 cty
+ in
+ (* constructors types with left params already instantiated *)
+ let outty = CicMetaSubst.apply_subst subst outty in
+ let cl, left_p, leftno,rno,ugraph =
+ get_cl_and_left_p uri tyno outty ugraph
+ in
+ let right_p =
+ try
+ match
+ CicTypeChecker.type_of_aux' ~subst metasenv context m
+ CicUniv.oblivion_ugraph
+ with
+ | Cic.MutInd _,_ -> []
+ | Cic.Appl (Cic.MutInd _::args),_ ->
+ snd (HExtlib.split_nth leftno args)
+ | _ -> assert false
+ with CicTypeChecker.TypeCheckerFailure _ ->
+ let rec foo =
+ function 0 -> [] | n -> Cic.Implicit None :: foo (n-1)
+ in
+ foo rno
+ in
+ let new_outty =
+ keep_lambdas_and_put_expty context outty expty right_p m (rno+1)
+ in
+ let _,pl,subst,metasenv,ugraph =
+ List.fold_right2
+ (fun cty pbo (i, acc, s, m, ugraph) ->
+ (* Pi k_par, (naw_)outty right_par (K_i left_par k_par) *)
+ let infty_pbo =
+ add_params m s context uri tyno cty outty leftno i in
+ let expty_pbo =
+ add_params m s context uri tyno cty new_outty leftno i in
+ let (pbo, _), subst, metasenv, ugraph =
+ coerce_to_something_aux pbo infty_pbo expty_pbo
+ s m context ugraph
+ in
+ (i-1, pbo::acc, subst, metasenv, ugraph))
+ cl pl (List.length pl, [], subst, metasenv, ugraph)
+ in
+ let t = Cic.MutCase(uri, tyno, new_outty, m, pl) in
+ (t, expty), subst, metasenv, ugraph
+ | Cic.Prod (nameprod, src, ty),Cic.Prod (_, src2, ty2), _ ->
+ let name_con =
+ FreshNamesGenerator.mk_fresh_name
+ ~subst metasenv context Cic.Anonymous ~typ:src2
+ in
+ let context_src2 = (Some (name_con, Cic.Decl src2) :: context) in
+ (* contravariant part: the argument of f:src->ty *)