+ NCic.Appl (t:: aux (List.length ctx,rels))
+;;
+
+let splat_args ctx t n_fix rels =
+ let bound, free, _, primo_ce_dopo_fix = context_tassonomy ctx in
+ if ctx = [] then t
+ else
+ let rec aux = function
+ | 0,[] -> []
+ | n,he::tl ->
+ (match List.nth ctx (n-1) with
+ | Ce ((_, NCic.Decl _),_) when n <= bound -> NCic.Rel he:: aux (n-1,tl)
+ | Fix (refe, _, _) when n < primo_ce_dopo_fix ->
+ splat_args_for_rel ctx (NCic.Const refe) ~rels n_fix :: aux (n-1,tl)
+ | Fix _ | Ce ((_, NCic.Decl _),_) -> NCic.Rel (he - n_fix)::aux(n-1,tl)
+ | Ce ((_, NCic.Def _),_) -> aux (n - 1,tl)
+ )
+ | _,_ -> assert false
+ in
+ NCic.Appl (t:: aux ((List.length ctx,rels)))
+;;
+
+exception Nothing_to_do;;
+
+let fix_outty curi tyno t context outty =
+ let leftno,rightno =
+ match fst (CicEnvironment.get_obj CicUniv.oblivion_ugraph curi) with
+ Cic.InductiveDefinition (tyl,_,leftno,_) ->
+ let _,_,arity,_ = List.nth tyl tyno in
+ let rec count_prods leftno context arity =
+ match leftno, CicReduction.whd context arity with
+ 0, Cic.Sort _ -> 0
+ | 0, Cic.Prod (name,so,ty) ->
+ 1 + count_prods 0 (Some (name, Cic.Decl so)::context) ty
+ | n, Cic.Prod (name,so,ty) ->
+ count_prods (leftno - 1) (Some (name, Cic.Decl so)::context) ty
+ | _,_ -> assert false
+ in
+(*prerr_endline (UriManager.string_of_uri curi);
+prerr_endline ("LEFTNO: " ^ string_of_int leftno ^ " " ^ CicPp.ppterm arity);*)
+ leftno, count_prods leftno [] arity
+ | _ -> assert false in
+ let ens,args =
+ let tty,_= CicTypeChecker.type_of_aux' [] context t CicUniv.oblivion_ugraph in
+ match CicReduction.whd context tty with
+ Cic.MutInd (_,_,ens) -> ens,[]
+ | Cic.Appl (Cic.MutInd (_,_,ens)::args) ->
+ ens,fst (HExtlib.split_nth leftno args)
+ | _ -> assert false
+ in
+ let rec aux n irl context outsort =
+ match n, CicReduction.whd context outsort with
+ 0, Cic.Prod _ -> raise Nothing_to_do
+ | 0, _ ->
+ let irl = List.rev irl in
+ let ty = CicSubstitution.lift rightno (Cic.MutInd (curi,tyno,ens)) in
+ let ty =
+ if args = [] && irl = [] then ty
+ else
+ Cic.Appl (ty::(List.map (CicSubstitution.lift rightno) args)@irl) in
+ let he = CicSubstitution.lift (rightno + 1) outty in
+ let t =
+ if irl = [] then he
+ else Cic.Appl (he::List.map (CicSubstitution.lift 1) irl)
+ in
+ Cic.Lambda (Cic.Anonymous, ty, t)
+ | n, Cic.Prod (name,so,ty) ->
+ let ty' =
+ aux (n - 1) (Cic.Rel n::irl) (Some (name, Cic.Decl so)::context) ty
+ in
+ Cic.Lambda (name,so,ty')
+ | _,_ -> assert false
+ in
+(*prerr_endline ("RIGHTNO = " ^ string_of_int rightno ^ " OUTTY = " ^ CicPp.ppterm outty);*)
+ let outsort =
+ fst (CicTypeChecker.type_of_aux' [] context outty CicUniv.oblivion_ugraph)
+ in
+ try aux rightno [] context outsort
+ with Nothing_to_do -> outty
+(*prerr_endline (CicPp.ppterm outty ^ " <==> " ^ CicPp.ppterm outty');*)
+;;
+
+let fix_outtype t =
+ let module C = Cic in
+ let rec aux context =
+ function
+ C.Rel _ as t -> t
+ | C.Var (uri,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function i,t -> i, (aux context t)) exp_named_subst in
+ C.Var (uri,exp_named_subst')
+ | C.Implicit _
+ | C.Meta _ -> assert false
+ | C.Sort _ as t -> t
+ | C.Cast (v,t) -> C.Cast (aux context v, aux context t)
+ | C.Prod (n,s,t) ->
+ C.Prod (n, aux context s, aux ((Some (n, C.Decl s))::context) t)
+ | C.Lambda (n,s,t) ->
+ C.Lambda (n, aux context s, aux ((Some (n, C.Decl s))::context) t)
+ | C.LetIn (n,s,ty,t) ->
+ C.LetIn
+ (n, aux context s, aux context ty,
+ aux ((Some (n, C.Def(s,ty)))::context) t)
+ | C.Appl l -> C.Appl (List.map (aux context) l)
+ | C.Const (uri,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function i,t -> i, (aux context t)) exp_named_subst
+ in
+ C.Const (uri,exp_named_subst')
+ | C.MutInd (uri,tyno,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function i,t -> i, (aux context t)) exp_named_subst
+ in
+ C.MutInd (uri, tyno, exp_named_subst')
+ | C.MutConstruct (uri,tyno,consno,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function i,t -> i, (aux context t)) exp_named_subst
+ in
+ C.MutConstruct (uri, tyno, consno, exp_named_subst')
+ | C.MutCase (uri, tyno, outty, term, patterns) ->
+ let outty = fix_outty uri tyno term context outty in
+ C.MutCase (uri, tyno, aux context outty,
+ aux context term, List.map (aux context) patterns)
+ | C.Fix (funno, funs) ->
+ let tys,_ =
+ List.fold_left
+ (fun (types,len) (n,_,ty,_) ->
+ ((Some (C.Name n,(C.Decl (CicSubstitution.lift len ty)))))::types,
+ len+1
+ ) ([],0) funs
+ in
+ C.Fix (funno,
+ List.map
+ (fun (name, indidx, ty, bo) ->
+ (name, indidx, aux context ty, aux (tys@context) bo)
+ ) funs
+ )
+ | C.CoFix (funno, funs) ->
+ let tys,_ =
+ List.fold_left
+ (fun (types,len) (n,ty,_) ->
+ ((Some (C.Name n,(C.Decl (CicSubstitution.lift len ty)))))::types,
+ len+1
+ ) ([],0) funs
+ in
+ C.CoFix (funno,
+ List.map
+ (fun (name, ty, bo) ->
+ (name, aux context ty, aux (tys@context) bo)
+ ) funs
+ )
+ in
+ aux [] t