exception Uncertain of string;;
exception AssertFailure of string;;
-let debug_print = prerr_endline
+let debug_print = fun _ -> ()
let fo_unif_subst subst context metasenv t1 t2 ugraph =
try
| (_,_) -> raise (AssertFailure "split: list too short")
;;
-let look_for_coercion src tgt =
- if (src = (CicUtil.term_of_uri "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1)")) &&
- (tgt = (CicUtil.term_of_uri "cic:/Coq/Reals/Rdefinitions/R.con"))
- then
- begin
- prerr_endline "TROVATA coercion";
- Some (CicUtil.term_of_uri "cic:/Coq/Reals/Raxioms/INR.con")
- end
- else
- begin
- prerr_endline (sprintf "NON TROVATA la coercion %s %s" (CicPp.ppterm src)
- (CicPp.ppterm tgt));
- None
- end
-;;
-
-
let rec type_of_constant uri ugraph =
let module C = Cic in
let module R = CicReduction in
canonical_context l ugraph
in
(* trust or check ??? *)
- C.Meta (n,l'),CicSubstitution.lift_meta l' ty,
+ C.Meta (n,l'),CicSubstitution.subst_meta l' ty,
subst', metasenv', ugraph1
(* type_of_aux subst metasenv
- context (CicSubstitution.lift_meta l term) *)
+ context (CicSubstitution.subst_meta l term) *)
with CicUtil.Subst_not_found _ ->
let (_,canonical_context,ty) = CicUtil.lookup_meta n metasenv in
let l',subst',metasenv', ugraph1 =
check_metasenv_consistency n subst metasenv context
canonical_context l ugraph
in
- C.Meta (n,l'),CicSubstitution.lift_meta l' ty,
+ C.Meta (n,l'),CicSubstitution.subst_meta l' ty,
subst', metasenv',ugraph1)
| C.Sort (C.Type tno) ->
let tno' = CicUniv.fresh() in
(try
let subst''',metasenv''',ugraph3 =
fo_unif_subst subst'' context metasenv''
- inferredty ty' ugraph2
+ inferredty ty ugraph2
in
C.Cast (te',ty'),ty',subst''',metasenv''',ugraph3
with
(match outtype with
| C.Meta (n,l) ->
- (let candidate,ugraph5 =
+ (let candidate,ugraph5,metasenv =
+ let exp_name_subst, metasenv =
+ let o,_ =
+ CicEnvironment.get_obj CicUniv.empty_ugraph uri
+ in
+ let uris = CicUtil.params_of_obj o in
+ List.fold_right (
+ fun uri (acc,metasenv) ->
+ let metasenv',new_meta =
+ CicMkImplicit.mk_implicit metasenv subst context
+ in
+ let irl =
+ CicMkImplicit.identity_relocation_list_for_metavariable
+ context
+ in
+ (uri, Cic.Meta(new_meta,irl))::acc, metasenv'
+ ) uris ([],metasenv)
+ in
+ let ty = Cic.MutInd(uri, i, exp_name_subst) in
+ let fresh_name =
+ FreshNamesGenerator.mk_fresh_name ~subst metasenv
+ context Cic.Anonymous ~typ:ty
+ in
match outtypeinstances with
- | [] -> raise (Uncertain "Inference of annotation for empty inductive types not implemented")
+ | [] ->
+ let extended_context =
+ Some (fresh_name,Cic.Decl ty)::context
+ in
+ let metasenv,new_meta =
+ CicMkImplicit.mk_implicit metasenv subst extended_context
+ in
+ let irl =
+ CicMkImplicit.identity_relocation_list_for_metavariable
+ extended_context
+ in
+ let candidate =
+ Cic.Lambda(fresh_name, ty, Cic.Meta (new_meta,irl))
+ in
+ (Some candidate),ugraph4,metasenv
| (constructor_args_no,_,instance,_)::tl ->
try
let instance' =
CicSubstitution.delift constructor_args_no
(CicMetaSubst.apply_subst subst instance)
in
+ let candidate,ugraph,metasenv =
List.fold_left (
- fun (candidate_oty,ugraph)
+ fun (candidate_oty,ugraph,metasenv)
(constructor_args_no,_,instance,_) ->
match candidate_oty with
- | None -> None,ugraph
+ | None -> None,ugraph,metasenv
| Some ty ->
try
let instance' =
CicReduction.are_convertible context
instance' ty ugraph
in
- if b then
- candidate_oty,ugraph1
- else
- None,ugraph
- with Failure s -> None,ugraph
- ) (Some instance',ugraph4) tl
+ if b then
+ candidate_oty,ugraph1,metasenv
+ else
+ None,ugraph,metasenv
+ with Failure s -> None,ugraph,metasenv
+ ) (Some instance',ugraph4,metasenv) tl
+ in
+ match candidate with
+ | None -> None, ugraph,metasenv
+ | Some t ->
+ Some (Cic.Lambda (fresh_name, ty,
+ CicSubstitution.lift 1 t)),ugraph,metasenv
with Failure s ->
- None,ugraph4
+ None,ugraph4,metasenv
in
match candidate with
| None -> raise (Uncertain "can't solve an higher order unification problem")
| Some candidate ->
- prerr_endline ("CANDIDATE=" ^ (CicPp.ppterm candidate));
let s,m,u =
fo_unif_subst subst context metasenv
candidate outtype ugraph5
in
- C.MutCase (uri, i, outtype, term', pl'),candidate,s,m,u)
+ C.MutCase (uri, i, outtype, term', pl'),
+ (Cic.Appl [outtype; term']),s,m,u)
| _ -> (* easy case *)
let _,_, subst, metasenv,ugraph5 =
type_of_aux subst metasenv context
function
[] -> []
| (Some (n,C.Decl t))::tl ->
- (Some (n,C.Decl (S.lift_meta l (S.lift i t))))::(aux (i+1) tl)
+ (Some (n,C.Decl (S.subst_meta l (S.lift i t))))::(aux (i+1) tl)
| (Some (n,C.Def (t,None)))::tl ->
- (Some (n,C.Def ((S.lift_meta l (S.lift i t)),None)))::(aux (i+1) tl)
+ (Some (n,C.Def ((S.subst_meta l (S.lift i t)),None)))::(aux (i+1) tl)
| None::tl -> None::(aux (i+1) tl)
| (Some (n,C.Def (t,Some ty)))::tl ->
(Some (n,
- C.Def ((S.lift_meta l (S.lift i t)),
- Some (S.lift_meta l (S.lift i ty))))) :: (aux (i+1) tl)
+ C.Def ((S.subst_meta l (S.lift i t)),
+ Some (S.subst_meta l (S.lift i ty))))) :: (aux (i+1) tl)
in
aux 1 canonical_context
in
try
fo_unif_subst subst context metasenv hetype hetype' ugraph
with exn ->
- prerr_endline (Printf.sprintf "hetype=%s\nhetype'=%s\nmetasenv=%s\nsubst=%s"
+ debug_print (Printf.sprintf "hetype=%s\nhetype'=%s\nmetasenv=%s\nsubst=%s"
(CicPp.ppterm hetype)
(CicPp.ppterm hetype')
(CicMetaSubst.ppmetasenv metasenv [])
hete,subst,metasenv,ugraph1
with exn ->
(* we search a coercion from hety to s *)
- let coer = look_for_coercion
+ let coer = CoercGraph.look_for_coercion
(CicMetaSubst.apply_subst subst hety)
(CicMetaSubst.apply_subst subst s)
in
(cleaned_t,cleaned_ty,cleaned_metasenv,ugraph1)
;;
+let type_of_aux' metasenv context term ugraph =
+ try
+ type_of_aux' metasenv context term ugraph
+ with
+ CicUniv.UniverseInconsistency msg -> raise (RefineFailure msg)
+
+
(* DEBUGGING ONLY
let type_of_aux' metasenv context term =
try
projects / helm.git / blobdiff