+
+let rec first f l1 l2 =
+ match l1,l2 with
+ | x1::tl1, x2::tl2 ->
+ (try f x1 x2 with Not_found -> first f tl1 tl2)
+ | _ -> raise Not_found
+;;
+
+let rec find add dt t =
+ if dt == add then t
+ else
+ let dl, l =
+ match dt, t with
+ | C.Meta (_,(_,C.Ctx dl)), C.Meta (_,(_,C.Ctx l))
+ | C.Appl dl,C.Appl l -> dl,l
+ | C.Lambda (_,ds,dt), C.Lambda (_,s,t)
+ | C.Prod (_,ds,dt), C.Prod (_,s,t) -> [ds;dt],[s;t]
+ | C.LetIn (_,ds,db,dt), C.LetIn (_,s,b,t) -> [ds;db;dt],[s;b;t]
+ | C.Match (_,dot,dt,dl), C.Match (_,ot,t,l) -> (dot::dt::dl),(ot::t::l)
+ | _ -> raise Not_found
+ in
+ first (find add) dl l
+;;
+
+let relocalise old_localise dt t add =
+ old_localise
+ (try find add dt t with Not_found -> assert false)
+;;
+
+let undebruijnate inductive ref t rev_fl =
+ NCicSubstitution.psubst (fun x -> x)
+ (List.rev (HExtlib.list_mapi
+ (fun (_,_,rno,_,_,_) i ->
+ NCic.Const
+ (if inductive then NReference.mk_fix i rno ref
+ else NReference.mk_cofix i ref))
+ rev_fl))
+ t
+;;
+
+
+let typeof_obj hdb
+ ?(localise=fun _ -> Stdpp.dummy_loc)
+ ~look_for_coercion (uri,height,metasenv,subst,obj)
+=
+prerr_endline ("===============\n" ^ NCicPp.ppobj (uri,height,metasenv,subst,obj));
+ let check_type metasenv subst context (ty as orig_ty) = (* XXX fattorizza *)
+ let metasenv, subst, ty, sort =
+ typeof hdb ~localise ~look_for_coercion metasenv subst context ty None
+ in
+ let metasenv, subst, ty, sort =
+ force_to_sort hdb ~look_for_coercion
+ metasenv subst context ty orig_ty localise sort
+ in
+ metasenv, subst, ty, sort
+ in
+ match obj with
+ | C.Constant (relevance, name, bo, ty , attr) ->
+ let metasenv, subst, ty, _ = check_type metasenv subst [] ty in
+ let metasenv, subst, bo, ty, height =
+ match bo with
+ | Some bo ->
+ let metasenv, subst, bo, ty =
+ typeof hdb ~localise ~look_for_coercion
+ metasenv subst [] bo (Some ty)
+ in
+ let height = (* XXX recalculate *) height in
+ metasenv, subst, Some bo, ty, height
+ | None -> metasenv, subst, None, ty, 0
+ in
+ uri, height, metasenv, subst,
+ C.Constant (relevance, name, bo, ty, attr)
+ | C.Fixpoint (inductive, fl, attr) ->
+ let len = List.length fl in
+ let types, metasenv, subst, rev_fl =
+ List.fold_left
+ (fun (types, metasenv, subst, fl) (relevance,name,k,ty,bo) ->
+ let metasenv, subst, ty, _ = check_type metasenv subst [] ty in
+ let dbo = NCicTypeChecker.debruijn uri len [] bo in
+ let localise = relocalise localise dbo bo in
+ (name,C.Decl ty)::types,
+ metasenv, subst, (relevance,name,k,ty,dbo,localise)::fl
+ ) ([], metasenv, subst, []) fl (* XXX kl rimosso nel nucleo *)
+ in
+ let metasenv, subst, fl =
+ List.fold_left
+ (fun (metasenv,subst,fl) (relevance,name,k,ty,dbo,localise) ->
+ let metasenv, subst, dbo, ty =
+ typeof hdb ~localise ~look_for_coercion
+ metasenv subst types dbo (Some ty)
+ in
+ metasenv, subst, (relevance,name,k,ty,dbo)::fl)
+ (metasenv, subst, []) rev_fl
+ in
+ let height = (* XXX recalculate *) height in
+ let fl =
+ List.map
+ (fun (relevance,name,k,ty,dbo) ->
+ let bo =
+ undebruijnate inductive
+ (NReference.reference_of_spec uri
+ (if inductive then NReference.Fix (0,k,0)
+ else NReference.CoFix 0)) dbo rev_fl
+ in
+ relevance,name,k,ty,bo)
+ fl
+ in
+ uri, height, metasenv, subst,
+ C.Fixpoint (inductive, fl, attr)
+ | C.Inductive (ind, leftno, itl, attr) ->
+ let len = List.length itl in
+ let metasenv,subst,rev_itl,tys =
+ List.fold_left
+ (fun (metasenv,subst,res,ctx) (relevance,n,ty,cl) ->
+ let metasenv, subst, ty, _ = check_type metasenv subst [] ty in
+ metasenv,subst,(relevance,n,ty,cl)::res,(n,NCic.Decl ty)::ctx
+ ) (metasenv,subst,[],[]) itl in
+ let metasenv,subst,itl,_ =
+ List.fold_left
+ (fun (metasenv,subst,res,i) (it_relev,n,ty,cl) ->
+ let context,ty_sort = NCicReduction.split_prods ~subst [] ~-1 ty in
+ let sx_context_ty_rev,_= HExtlib.split_nth "NR 2" leftno (List.rev context) in
+ let metasenv,subst,cl =
+ List.fold_right
+ (fun (k_relev,n,te) (metasenv,subst,res) ->
+ let k_relev =
+ try snd (HExtlib.split_nth "NR 3" leftno k_relev)
+ with Failure _ -> k_relev in
+ let te = NCicTypeChecker.debruijn uri len [] te in
+ let metasenv, subst, te, _ = check_type metasenv subst tys te in
+ let context,te = NCicReduction.split_prods ~subst tys leftno te in
+ let _,chopped_context_rev =
+ HExtlib.split_nth "NR 4" (List.length tys) (List.rev context) in
+ let sx_context_te_rev,_ =
+ HExtlib.split_nth "NR 5" leftno chopped_context_rev in
+ let metasenv,subst,_ =
+ try
+ List.fold_left2
+ (fun (metasenv,subst,context) item1 item2 ->
+ let (metasenv,subst),convertible =
+ try
+ match item1,item2 with
+ (n1,C.Decl ty1),(n2,C.Decl ty2) ->
+ if n1 = n2 then
+ NCicUnification.unify hdb ~test_eq_only:true metasenv
+ subst context ty1 ty2,true
+ else
+ (metasenv,subst),false
+ | (n1,C.Def (bo1,ty1)),(n2,C.Def (bo2,ty2)) ->
+ if n1 = n2 then
+ let metasenv,subst =
+ NCicUnification.unify hdb ~test_eq_only:true metasenv
+ subst context ty1 ty2
+ in
+ NCicUnification.unify hdb ~test_eq_only:true metasenv
+ subst context bo1 bo2,true
+ else
+ (metasenv,subst),false
+ | _,_ -> (metasenv,subst),false
+ with
+ | NCicUnification.Uncertain _
+ | NCicUnification.UnificationFailure _ ->
+ (metasenv,subst),false
+ in
+ let term2 =
+ match item2 with
+ _,C.Decl t -> t
+ | _,C.Def (b,_) -> b in
+ if not convertible then
+ raise (RefineFailure (lazy (localise term2,
+ ("Mismatch between the left parameters of the constructor " ^
+ "and those of its inductive type"))))
+ else
+ metasenv,subst,item1::context
+ ) (metasenv,subst,[]) sx_context_ty_rev sx_context_te_rev
+ with Invalid_argument "List.fold_left2" -> assert false in
+ let con_sort= NCicTypeChecker.typeof ~subst ~metasenv context te in
+ (match
+ NCicReduction.whd ~subst context con_sort,
+ NCicReduction.whd ~subst [] ty_sort
+ with
+ (C.Sort (C.Type u1) as s1), (C.Sort (C.Type u2) as s2) ->
+ if not (NCicEnvironment.universe_leq u1 u2) then
+ raise
+ (RefineFailure
+ (lazy(localise te, "The type " ^
+ NCicPp.ppterm ~metasenv ~subst ~context s1 ^
+ " of the constructor is not included in the inductive"^
+ " type sort " ^
+ NCicPp.ppterm ~metasenv ~subst ~context s2)))
+ | C.Sort _, C.Sort C.Prop
+ | C.Sort _, C.Sort C.Type _ -> ()
+ | _, _ ->
+ raise
+ (RefineFailure
+ (lazy (localise te,
+ "Wrong constructor or inductive arity shape"))));
+ (* let's check also the positivity conditions *)
+ if
+ not
+ (NCicTypeChecker.are_all_occurrences_positive
+ ~subst context uri leftno (i+leftno) leftno (len+leftno) te)
+ then
+ raise
+ (RefineFailure
+ (lazy (localise te,
+ "Non positive occurence in " ^ NUri.string_of_uri uri)))
+ else
+ let relsno = List.length itl + leftno in
+ let te =
+ NCicSubstitution.psubst
+ (fun i ->
+ if i <= leftno then
+ NCic.Rel i
+ else
+ NCic.Const (NReference.reference_of_spec uri
+ (NReference.Ind (ind,relsno - i,leftno))))
+ (HExtlib.list_seq 1 (relsno+1))
+ te in
+ let te =
+ List.fold_right
+ (fun (name,decl) te ->
+ match decl with
+ NCic.Decl ty -> NCic.Prod (name,ty,te)
+ | NCic.Def (bo,ty) -> NCic.LetIn (name,ty,bo,te)
+ ) sx_context_te_rev te
+ in
+ metasenv,subst,(k_relev,n,te)::res
+ ) cl (metasenv,subst,[])
+ in
+ metasenv,subst,(it_relev,n,ty,cl)::res,i+1
+ ) (metasenv,subst,[],1) rev_itl
+ in
+ uri, height, metasenv, subst, C.Inductive (ind, leftno, itl, attr)
+;;
+