exception Uncertain of string Lazy.t;;
exception AssertFailure of string Lazy.t;;
+(* for internal use only; the integer is the number of surplus arguments *)
+exception MoreArgsThanExpected of int * exn;;
+
let insert_coercions = ref true
let pack_coercions = ref true
try
Cic.CicHash.find localization_tbl t
with Not_found ->
- prerr_endline ("!!! NOT LOCALIZED: " ^ CicPp.ppterm t);
+ HLog.debug ("!!! NOT LOCALIZED: " ^ CicPp.ppterm t);
raise exn'
in
raise (HExtlib.Localized (loc,exn'))
| _ -> assert false
;;
+let unvariant newt =
+ match newt with
+ | Cic.Appl (hd::args) ->
+ let uri = CicUtil.uri_of_term hd in
+ (match
+ CicEnvironment.get_obj CicUniv.oblivion_ugraph uri
+ with
+ | Cic.Constant (_,Some t,_,[],attrs),_
+ when List.exists ((=) (`Flavour `Variant)) attrs ->
+ Cic.Appl (t::args)
+ | _ -> newt)
+ | _ -> newt
+;;
+
let is_a_double_coercion t =
- let last_of l =
- let rec aux acc = function
- | x::[] -> acc,x
- | x::tl -> aux (acc@[x]) tl
- | [] -> assert false
- in
- aux [] l
+ let rec subst_nth n x l =
+ match n,l with
+ | _, [] -> []
+ | 0, _::tl -> x :: tl
+ | n, hd::tl -> hd :: subst_nth (n-1) x tl
in
let imp = Cic.Implicit None in
let dummyres = false,imp, imp,imp,imp in
match t with
- | Cic.Appl (c1::tl) when CoercDb.is_a_coercion' c1 ->
- (match last_of tl with
- | sib1,Cic.Appl (c2::tl2) when CoercDb.is_a_coercion' c2 ->
- let sib2,head = last_of tl2 in
- true, c1, c2, head,Cic.Appl (c1::sib1@[Cic.Appl
- (c2::sib2@[imp])])
+ | Cic.Appl l1 ->
+ (match CoercGraph.coerced_arg l1 with
+ | Some (Cic.Appl l2, pos1) ->
+ (match CoercGraph.coerced_arg l2 with
+ | Some (x, pos2) ->
+ true, List.hd l1, List.hd l2, x,
+ Cic.Appl (subst_nth (pos1 + 1)
+ (Cic.Appl (subst_nth (pos2+1) imp l2)) l1)
+ | _ -> dummyres)
| _ -> dummyres)
| _ -> dummyres
+;;
-let more_args_than_expected
- localization_tbl metasenv subst he context hetype' tlbody_and_type exn
+let more_args_than_expected localization_tbl metasenv subst he context hetype' residuals tlbody_and_type exn
=
+ let len = List.length tlbody_and_type in
let msg =
lazy ("The term " ^
CicMetaSubst.ppterm_in_context ~metasenv subst he context ^
- " (that has type "^CicMetaSubst.ppterm_in_context ~metasenv subst hetype' context ^
- ") is here applied to " ^ string_of_int (List.length tlbody_and_type) ^
- " arguments that are more than expected")
+ " (that has type "^ CicMetaSubst.ppterm_in_context ~metasenv subst hetype' context ^
+ ") is here applied to " ^ string_of_int len ^
+ " arguments but here it can handle only up to " ^
+ string_of_int (len - residuals) ^ " arguments")
in
enrich localization_tbl he ~f:(fun _-> msg) exn
;;
-let mk_prod_of_metas metasenv context' subst args =
+let mk_prod_of_metas metasenv context subst args =
let rec mk_prod metasenv context' = function
| [] ->
let (metasenv, idx) =
(* then I generate a name --- using the hint name_hint *)
(* --- that is fresh in context'. *)
let name_hint =
- (* Cic.Name "pippo" *)
FreshNamesGenerator.mk_fresh_name ~subst metasenv
- (* (CicMetaSubst.apply_subst_metasenv subst metasenv) *)
- (CicMetaSubst.apply_subst_context subst context')
+ (CicMetaSubst.apply_subst_context subst context)
Cic.Anonymous
~typ:(CicMetaSubst.apply_subst subst argty)
in
- (* [] and (Cic.Sort Cic.prop) are dummy: they will not be used *)
FreshNamesGenerator.mk_fresh_name ~subst
[] context' name_hint ~typ:(Cic.Sort Cic.Prop)
in
in
metasenv,Cic.Prod (name,meta,target)
in
- mk_prod metasenv context' args
+ mk_prod metasenv context args
;;
let rec type_of_constant uri ugraph =
and check_branch n context metasenv subst left_args_no actualtype term expectedtype ugraph =
let module C = Cic in
- (* let module R = CicMetaSubst in *)
let module R = CicReduction in
match R.whd ~subst context expectedtype with
C.MutInd (_,_,_) ->
| C.Appl (C.MutInd (_,_,_)::tl) ->
let (_,arguments) = split tl left_args_no in
(n,context,actualtype, arguments@[term]), subst, metasenv, ugraph
- | C.Prod (name,so,de) ->
+ | C.Prod (_,so,de) ->
(* we expect that the actual type of the branch has the due
number of Prod *)
(match R.whd ~subst context actualtype with
(* we should also check that the name variable is anonymous in
the actual type de' ?? *)
check_branch (n+1)
- ((Some (name,(C.Decl so)))::context)
+ ((Some (name',(C.Decl so)))::context)
metasenv subst left_args_no de' term' de ugraph1
| _ -> raise (AssertFailure (lazy "Wrong number of arguments")))
| _ -> raise (AssertFailure (lazy "Prod or MutInd expected"))
-and type_of_aux' ?(localization_tbl = Cic.CicHash.create 1) metasenv context t
- ugraph
+and type_of_aux' ?(clean_dummy_dependent_types=true)
+ ?(localization_tbl = Cic.CicHash.create 1) metasenv subst context t ugraph
=
let rec type_of_aux subst metasenv context t ugraph =
let module C = Cic in
match List.nth context (n - 1) with
Some (_,C.Decl ty) ->
t,S.lift n ty,subst,metasenv, ugraph
- | Some (_,C.Def (_,Some ty)) ->
+ | Some (_,C.Def (_,ty)) ->
t,S.lift n ty,subst,metasenv, ugraph
- | Some (_,C.Def (bo,None)) ->
- let ty,ugraph =
- (* if it is in the context it must be already well-typed*)
- CicTypeChecker.type_of_aux' ~subst metasenv context
- (S.lift n bo) ugraph
- in
- t,ty,subst,metasenv,ugraph
| None ->
enrich localization_tbl t
(RefineFailure (lazy "Rel to hidden hypothesis"))
t,(C.Sort (C.Type tno')),subst,metasenv,ugraph1
with
CicUniv.UniverseInconsistency msg -> raise (RefineFailure msg))
- | C.Sort _ ->
+ | C.Sort (C.CProp tno) ->
+ let tno' = CicUniv.fresh() in
+ (try
+ let ugraph1 = CicUniv.add_gt tno' tno ugraph in
+ t,(C.Sort (C.Type tno')),subst,metasenv,ugraph1
+ with
+ CicUniv.UniverseInconsistency msg -> raise (RefineFailure msg))
+ | C.Sort (C.Prop|C.Set) ->
t,C.Sort (C.Type (CicUniv.fresh())),subst,metasenv,ugraph
| C.Implicit infos ->
let metasenv',t' = exp_impl metasenv subst context infos in
let te',inferredty,subst'',metasenv'',ugraph2 =
type_of_aux subst' metasenv' context te ugraph1
in
+ let rec count_prods context ty =
+ match CicReduction.whd context ~subst:subst'' ty with
+ | Cic.Prod (n,s,t) ->
+ 1 + count_prods (Some (n,Cic.Decl s)::context) t
+ | _ -> 0
+ in
+ let exp_prods = count_prods context ty' in
+ let inf_prods = count_prods context inferredty in
+ let te', inferredty, metasenv'', subst'', ugraph2 =
+ let rec aux t m s ug it = function
+ | 0 -> t,it,m,s,ug
+ | n ->
+ match CicReduction.whd context ~subst:s it with
+ | Cic.Prod (_,src,tgt) ->
+ let newmeta, metaty, s, m, ug =
+ type_of_aux s m context (Cic.Implicit None) ug
+ in
+ let s,m,ug =
+ fo_unif_subst s context m metaty src ug
+ in
+ let t =
+ match t with
+ | Cic.Appl l -> Cic.Appl (l @ [newmeta])
+ | _ -> Cic.Appl [t;newmeta]
+ in
+ aux t m s ug (CicSubstitution.subst newmeta tgt) (n-1)
+ | _ -> t,it,m,s,ug
+ in
+ aux te' metasenv'' subst'' ugraph2 inferredty
+ (max 0 (inf_prods - exp_prods))
+ in
let (te', ty'), subst''',metasenv''',ugraph3 =
coerce_to_something true localization_tbl te' inferredty ty'
subst'' metasenv'' context ugraph2
in
C.Lambda (n,s',t'),C.Prod (n,s',type2),
subst'',metasenv'',ugraph2
- | C.LetIn (n,s,t) ->
- (* only to check if s is well-typed *)
- let s',ty,subst',metasenv',ugraph1 =
- type_of_aux subst metasenv context s ugraph
- in
- let context_for_t = ((Some (n,(C.Def (s',Some ty))))::context) in
+ | C.LetIn (n,s,ty,t) ->
+ (* only to check if s is well-typed *)
+ let s',ty',subst',metasenv',ugraph1 =
+ type_of_aux subst metasenv context s ugraph in
+ let ty,_,subst',metasenv',ugraph1 =
+ type_of_aux subst' metasenv' context ty ugraph1 in
+ let subst',metasenv',ugraph1 =
+ try
+ fo_unif_subst subst' context metasenv'
+ ty ty' ugraph1
+ with
+ exn ->
+ enrich localization_tbl s' exn
+ ~f:(function _ ->
+ lazy ("(2) The term " ^
+ CicMetaSubst.ppterm_in_context ~metasenv:metasenv' subst' s'
+ context ^ " has type " ^
+ CicMetaSubst.ppterm_in_context ~metasenv:metasenv' subst' ty'
+ context ^ " but is here used with type " ^
+ CicMetaSubst.ppterm_in_context ~metasenv:metasenv' subst' ty
+ context))
+ in
+ let context_for_t = ((Some (n,(C.Def (s',ty))))::context) in
let t',inferredty,subst'',metasenv'',ugraph2 =
type_of_aux subst' metasenv'
* Even faster than the previous solution.
* Moreover the inferred type is closer to the expected one.
*)
- C.LetIn (n,s',t'),
+ C.LetIn (n,s',ty,t'),
CicSubstitution.subst ~avoid_beta_redexes:true s' inferredty,
subst'',metasenv'',ugraph2
| C.Appl (he::((_::_) as tl)) ->
(lazy ("Unkown mutual inductive definition " ^
U.string_of_uri uri)))
in
+ if List.length constructors <> List.length pl then
+ enrich localization_tbl t
+ (RefineFailure
+ (lazy "Wrong number of cases")) ;
let rec count_prod t =
match CicReduction.whd ~subst context t with
C.Prod (_, _, t) -> 1 + (count_prod t)
exn ->
enrich localization_tbl term' exn
~f:(function _ ->
- lazy ("(10)The term " ^
+ lazy ("(3) The term " ^
CicMetaSubst.ppterm_in_context ~metasenv subst term'
context ^ " has type " ^
CicMetaSubst.ppterm_in_context ~metasenv subst actual_type
context ^ " but is here used with type " ^
- CicMetaSubst.ppterm_in_context ~metasenv subst expected_type' context))
+ CicMetaSubst.ppterm_in_context ~metasenv subst expected_type'
+ context))
in
let rec instantiate_prod t =
function
exn ->
enrich localization_tbl constructor'
~f:(fun _ ->
- lazy ("(11)The term " ^
+ lazy ("(4) The term " ^
CicMetaSubst.ppterm_in_context metasenv subst p'
context ^ " has type " ^
CicMetaSubst.ppterm_in_context metasenv subst actual_type
context)) exn
in
(p'::pl,j-1,
- outtypeinstances@[outtypeinstance],subst,metasenv,ugraph3))
+ outtypeinstance::outtypeinstances,subst,metasenv,ugraph3))
pl ([],List.length pl,[],subst,metasenv,ugraph3)
in
(let candidate,ugraph5,metasenv,subst =
let exp_name_subst, metasenv =
let o,_ =
- CicEnvironment.get_cooked_obj CicUniv.empty_ugraph uri
+ CicEnvironment.get_cooked_obj CicUniv.oblivion_ugraph uri
in
let uris = CicUtil.params_of_obj o in
List.fold_right (
in
C.Appl (outtype'::args)
in
- CicReduction.whd ~subst context appl
+ CicReduction.head_beta_reduce ~delta:false
+ ~upto:(List.length args) appl
in
try
fo_unif_subst subst context metasenv instance instance'
exn ->
enrich localization_tbl p exn
~f:(function _ ->
- lazy ("(12)The term " ^
+ lazy ("(5) The term " ^
CicMetaSubst.ppterm_in_context ~metasenv subst p
context ^ " has type " ^
CicMetaSubst.ppterm_in_context ~metasenv subst instance'
context ^ " but is here used with type " ^
CicMetaSubst.ppterm_in_context ~metasenv subst instance
context)))
- (subst,metasenv,ugraph5) pl' outtypeinstances
+ (subst,metasenv,ugraph5) pl' outtypeinstances
in
C.MutCase (uri, i, outtype, term', pl'),
CicReduction.head_beta_reduce
(CicMetaSubst.apply_subst subst
- (C.Appl(outtype::right_args@[term]))),
+ (C.Appl(outtype::right_args@[term']))),
subst,metasenv,ugraph6)
| C.Fix (i,fl) ->
let fl_ty',subst,metasenv,types,ugraph1,len =
exn ->
enrich localization_tbl bo exn
~f:(function _ ->
- lazy ("(13)The term " ^
+ lazy ("(7) The term " ^
CicMetaSubst.ppterm_in_context ~metasenv subst bo
context' ^ " has type " ^
CicMetaSubst.ppterm_in_context ~metasenv subst ty_of_bo
context' ^ " but is here used with type " ^
CicMetaSubst.ppterm_in_context ~metasenv subst expected_ty
- context))
+ context'))
in
fl @ [bo'] , subst',metasenv',ugraph'
) ([],subst,metasenv,ugraph1) (List.combine fl fl_ty')
exn ->
enrich localization_tbl bo exn
~f:(function _ ->
- lazy ("(14)The term " ^
+ lazy ("(8) The term " ^
CicMetaSubst.ppterm_in_context ~metasenv subst bo
context' ^ " has type " ^
CicMetaSubst.ppterm_in_context ~metasenv subst ty_of_bo
[] -> []
| (Some (n,C.Decl t))::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.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.subst_meta l (S.lift i t)),
- Some (S.subst_meta l (S.lift i ty))))) :: (aux (i+1) tl)
+ | (Some (n,C.Def (t,ty)))::tl ->
+ (Some
+ (n,
+ C.Def
+ (S.subst_meta l (S.lift i t),
+ S.subst_meta l (S.lift i ty)))) :: (aux (i+1) tl)
in
aux 1 canonical_context
in
_,None ->
l @ [None],subst,metasenv,ugraph
| Some t,Some (_,C.Def (ct,_)) ->
+ (*CSC: the following optimization is to avoid a possibly
+ expensive reduction that can be easily avoided and
+ that is quite frequent. However, this is better
+ handled using levels to control reduction *)
+ let optimized_t =
+ match t with
+ Cic.Rel n ->
+ (try
+ match List.nth context (n - 1) with
+ Some (_,C.Def (te,_)) -> S.lift n te
+ | _ -> t
+ with
+ Failure _ -> t)
+ | _ -> t
+ in
let subst',metasenv',ugraph' =
(try
-prerr_endline ("poco geniale: nel caso di IRL basterebbe sapere che questo e' il Rel corrispondente. Si puo' ottimizzare il caso t = rel.");
- fo_unif_subst subst context metasenv t ct ugraph
- with e -> raise (RefineFailure (lazy (sprintf "The local context is not consistent with the canonical context, since %s cannot be unified with %s. Reason: %s" (CicMetaSubst.ppterm ~metasenv subst t) (CicMetaSubst.ppterm ~metasenv subst ct) (match e with AssertFailure msg -> Lazy.force msg | _ -> (Printexc.to_string e))))))
+(*prerr_endline ("poco geniale: nel caso di IRL basterebbe sapere che questo e'
+ * il Rel corrispondente. Si puo' ottimizzare il caso t = rel.");*)
+ fo_unif_subst subst context metasenv optimized_t ct ugraph
+ with e -> raise (RefineFailure (lazy (sprintf "The local context is not consistent with the canonical context, since %s cannot be unified with %s. Reason: %s" (CicMetaSubst.ppterm ~metasenv subst optimized_t) (CicMetaSubst.ppterm ~metasenv subst ct) (match e with AssertFailure msg -> Lazy.force msg | _ -> (Printexc.to_string e))))))
in
l @ [Some t],subst',metasenv',ugraph'
| Some t,Some (_,C.Decl ct) ->
let t1'' = CicReduction.whd ~subst context t1 in
let t2'' = CicReduction.whd ~subst context_for_t2 t2 in
match (t1'', t2'') with
- (C.Sort s1, C.Sort s2)
- when (s2 = C.Prop or s2 = C.Set or s2 = C.CProp) ->
+ | (C.Sort s1, C.Sort s2) when (s2 = C.Prop || s2 = C.Set) ->
(* different than Coq manual!!! *)
C.Sort s2,subst,metasenv,ugraph
| (C.Sort (C.Type t1), C.Sort (C.Type t2)) ->
C.Sort (C.Type t'),subst,metasenv,ugraph2
with
CicUniv.UniverseInconsistency msg -> raise (RefineFailure msg))
+ | (C.Sort (C.CProp t1), C.Sort (C.CProp t2)) ->
+ let t' = CicUniv.fresh() in
+ (try
+ let ugraph1 = CicUniv.add_ge t' t1 ugraph in
+ let ugraph2 = CicUniv.add_ge t' t2 ugraph1 in
+ C.Sort (C.CProp t'),subst,metasenv,ugraph2
+ with
+ CicUniv.UniverseInconsistency msg -> raise (RefineFailure msg))
+ | (C.Sort (C.Type t1), C.Sort (C.CProp t2)) ->
+ let t' = CicUniv.fresh() in
+ (try
+ let ugraph1 = CicUniv.add_ge t' t1 ugraph in
+ let ugraph2 = CicUniv.add_ge t' t2 ugraph1 in
+ C.Sort (C.CProp t'),subst,metasenv,ugraph2
+ with
+ CicUniv.UniverseInconsistency msg -> raise (RefineFailure msg))
+ | (C.Sort (C.CProp t1), C.Sort (C.Type t2)) ->
+ let t' = CicUniv.fresh() in
+ (try
+ let ugraph1 = CicUniv.add_ge t' t1 ugraph in
+ let ugraph2 = CicUniv.add_ge t' t2 ugraph1 in
+ C.Sort (C.Type t'),subst,metasenv,ugraph2
+ with
+ CicUniv.UniverseInconsistency msg -> raise (RefineFailure msg))
| (C.Sort _,C.Sort (C.Type t1)) ->
C.Sort (C.Type t1),subst,metasenv,ugraph
+ | (C.Sort _,C.Sort (C.CProp t1)) ->
+ C.Sort (C.CProp t1),subst,metasenv,ugraph
| (C.Meta _, C.Sort _) -> t2'',subst,metasenv,ugraph
| (C.Sort _,C.Meta _) | (C.Meta _,C.Meta _) ->
(* TODO how can we force the meta to become a sort? If we don't we
| CoercGraph.SomeCoercion candidates ->
let selected =
HExtlib.list_findopt
- (function (metasenv,last,c) ->
- match c with
- | c when not (CoercGraph.is_composite c) ->
- debug_print (lazy ("\nNot a composite.."^CicPp.ppterm c));
- None
- | c ->
+ (fun (metasenv,last,c) _ ->
let subst,metasenv,ugraph =
fo_unif_subst subst context metasenv last head ugraph in
debug_print (lazy ("\nprovo" ^ CicPp.ppterm c));
in
tlbody_and_type,subst,metasenv,ugraph
- and eat_prods
+ and eat_prods
allow_coercions subst metasenv context he hetype args_bo_and_ty ugraph
=
(* given he:hety, gives beack all (c he) such that (c e):?->? *)
- let fix_arity exn metasenv context subst he hetype ugraph =
+ let fix_arity n metasenv context subst he hetype ugraph =
let hetype = CicMetaSubst.apply_subst subst hetype in
- let src = CoercDb.coerc_carr_of_term hetype in
- let tgt = CoercDb.Fun 0 in
- match CoercGraph.look_for_coercion' metasenv subst context src tgt with
- | CoercGraph.NoCoercion
- | CoercGraph.NotMetaClosed
- | CoercGraph.NotHandled _ -> raise exn
+ (* instead of a dummy functional type we may create the real product
+ * using args_bo_and_ty, but since coercions lookup ignores the
+ * actual ariety we opt for the simple solution *)
+ let fty = Cic.Prod(Cic.Anonymous, Cic.Sort Cic.Prop, Cic.Sort Cic.Prop) in
+ match CoercGraph.look_for_coercion metasenv subst context hetype fty with
+ | CoercGraph.NoCoercion -> []
+ | CoercGraph.NotHandled ->
+ raise (MoreArgsThanExpected (n,Uncertain (lazy "")))
| CoercGraph.SomeCoercionToTgt candidates
| CoercGraph.SomeCoercion candidates ->
HExtlib.filter_map
(fun (metasenv,last,coerc) ->
let pp t =
CicMetaSubst.ppterm_in_context ~metasenv subst t context in
- let subst,metasenv,ugraph =
- fo_unif_subst subst context metasenv last he ugraph in
- debug_print (lazy ("New head: "^ pp coerc));
try
- let t,tty,subst,metasenv,ugraph =
- type_of_aux subst metasenv context coerc ugraph in
- (*{{{*)debug_print (lazy (" refined: "^ pp t));
- debug_print (lazy (" has type: "^ pp tty));(*}}}*)
- Some (t,tty,subst,metasenv,ugraph)
+ let subst,metasenv,ugraph =
+ fo_unif_subst subst context metasenv last he ugraph in
+ debug_print (lazy ("New head: "^ pp coerc));
+ let tty,ugraph =
+ CicTypeChecker.type_of_aux' ~subst metasenv context coerc
+ ugraph
+ in
+ debug_print (lazy (" has type: "^ pp tty));
+
+ Some (unvariant coerc,tty,subst,metasenv,ugraph)
with
| Uncertain _ | RefineFailure _
| HExtlib.Localized (_,Uncertain _)
"Fixing arity of: "^ pp he ^ "\n that has type: "^ pp hetype^
"\n but is applyed to: " ^ String.concat ";"
(List.map (fun (t,_)->pp t) args_bo_and_ty)); (*}}}*)
- let exn = RefineFailure (lazy ("more args than expected")) in
+ let error = ref None in
let possible_fixes =
- fix_arity exn metasenv context subst he hetype ugraph in
+ fix_arity (List.length args) metasenv context subst he hetype
+ ugraph in
match
HExtlib.list_findopt
- (fun (he,hetype,subst,metasenv,ugraph) ->
+ (fun (he,hetype,subst,metasenv,ugraph) _ ->
(* {{{ *)debug_print (lazy ("Try fix: "^
CicMetaSubst.ppterm_in_context ~metasenv subst he context));
debug_print (lazy (" of type: "^
try
Some (eat_prods_and_args
metasenv subst context he hetype ugraph [] args)
- with RefineFailure _ | Uncertain _ -> None)
+ with
+ | RefineFailure _ | Uncertain _
+ | HExtlib.Localized (_,RefineFailure _)
+ | HExtlib.Localized (_,Uncertain _) as exn ->
+ error := Some exn; None)
possible_fixes
with
| Some x -> x
| None ->
- more_args_than_expected localization_tbl metasenv
- subst he context hetype args_bo_and_ty exn
+ match !error with
+ None ->
+ raise
+ (MoreArgsThanExpected
+ (List.length args, RefineFailure (lazy "")))
+ | Some exn -> raise exn
in
(* first we check if we are in the simple case of a meta closed term *)
let subst,metasenv,ugraph1,hetype',he,args_bo_and_ty =
subst,pristinemenv,ugraph,hetype,he,args_bo_and_ty
in
let coerced_args,subst,metasenv,he,t,ugraph =
+ try
eat_prods_and_args
metasenv subst context he hetype' ugraph1 [] args_bo_and_ty
+ with
+ MoreArgsThanExpected (residuals,exn) ->
+ more_args_than_expected localization_tbl metasenv
+ subst he context hetype' residuals args_bo_and_ty exn
in
he,(List.map fst coerced_args),t,subst,metasenv,ugraph
CoercGraph.look_for_coercion metasenv subst context infty expty
in
match coer with
- | CoercGraph.NotMetaClosed -> raise (Uncertain (lazy
- "coerce_atom_to_something fails since not meta closed"))
| CoercGraph.NoCoercion
- | CoercGraph.SomeCoercionToTgt _
- | CoercGraph.NotHandled _ -> raise (RefineFailure (lazy
+ | CoercGraph.SomeCoercionToTgt _ -> raise (RefineFailure (lazy
+ "coerce_atom_to_something fails since no coercions found"))
+ | CoercGraph.NotHandled when
+ not (CicUtil.is_meta_closed infty) ||
+ not (CicUtil.is_meta_closed expty) -> raise (Uncertain (lazy
+ "coerce_atom_to_something fails since carriers have metas"))
+ | CoercGraph.NotHandled -> raise (RefineFailure (lazy
"coerce_atom_to_something fails since no coercions found"))
| CoercGraph.SomeCoercion candidates ->
debug_print (lazy (string_of_int (List.length candidates) ^
(* {{{ *) debug_print (lazy ("FO_UNIF_SUBST: " ^
CicMetaSubst.ppterm_in_context ~metasenv subst last context ^
" <==> " ^
- CicMetaSubst.ppterm_in_context ~metasenv subst t context));
+ CicMetaSubst.ppterm_in_context ~metasenv subst t context ^
+ "####" ^ CicMetaSubst.ppterm_in_context ~metasenv subst c
+ context));
debug_print (lazy ("FO_UNIF_SUBST: " ^
CicPp.ppterm last ^ " <==> " ^ CicPp.ppterm t)); (* }}} *)
let subst,metasenv,ugraph =
let newt,newhety,subst,metasenv,ugraph =
type_of_aux subst metasenv context c ugraph in
let newt, newty, subst, metasenv, ugraph =
- avoid_double_coercion context subst metasenv ugraph newt expty
+ avoid_double_coercion context subst metasenv ugraph newt
+ expty
in
let subst,metasenv,ugraph =
- fo_unif_subst subst context metasenv newhety expty ugraph in
- Some ((newt,newty), subst, metasenv, ugraph)
+ fo_unif_subst subst context metasenv newhety expty ugraph
+ in
+ let b, ugraph =
+ CicReduction.are_convertible
+ ~subst ~metasenv context infty expty ugraph
+ in
+ if b then
+ Some ((t,infty), subst, metasenv, ugraph)
+ else
+ let newt = unvariant newt in
+ Some ((newt,newty), subst, metasenv, ugraph)
with
| Uncertain _ -> uncertain := true; None
| RefineFailure _ -> None)
fo_unif_subst subst context metasenv infty expty ugraph
in
(t, expty), subst, metasenv, ugraph
- with Uncertain _ | RefineFailure _ as exn ->
- if not allow_coercions || not !insert_coercions then
- enrich localization_tbl t exn
- else
+ with (Uncertain _ | RefineFailure _ as exn)
+ when allow_coercions && !insert_coercions ->
let whd = CicReduction.whd ~delta:false in
let clean t s c = whd c (CicMetaSubst.apply_subst s t) in
let infty = clean infty subst context in
CicTypeChecker.type_of_aux' ~subst metasenv context m
CicUniv.oblivion_ugraph
with
- | Cic.MutInd _ as mty,_ -> [], mty
- | Cic.Appl (Cic.MutInd _::args) as mty,_ ->
+ | (Cic.MutInd _ | Cic.Meta _) as mty,_ -> [], mty
+ | Cic.Appl ((Cic.MutInd _|Cic.Meta _)::args) as mty,_ ->
snd (HExtlib.split_nth leftno args), mty
| _ -> assert false
- with CicTypeChecker.TypeCheckerFailure _ -> assert false
+ with CicTypeChecker.TypeCheckerFailure _ ->
+ raise (AssertFailure(lazy "already ill-typed matched term"))
in
let new_outty =
keep_lambdas_and_put_expty context outty expty right_p m (rno+1)
coerce_to_something_aux t infty expty subst metasenv context ugraph
with Uncertain _ | RefineFailure _ as exn ->
let f _ =
- lazy ("The term " ^
+ lazy ("(9) The term " ^
CicMetaSubst.ppterm_in_context metasenv subst t context ^
" has type " ^ CicMetaSubst.ppterm_in_context metasenv subst
infty context ^ " but is here used with type " ^
(* eat prods ends here! *)
let t',ty,subst',metasenv',ugraph1 =
- type_of_aux [] metasenv context t ugraph
+ type_of_aux subst metasenv context t ugraph
in
let substituted_t = CicMetaSubst.apply_subst subst' t' in
let substituted_ty = CicMetaSubst.apply_subst subst' ty in
(* substituted_t,substituted_ty,substituted_metasenv *)
(* ANDREA: spostare tutta questa robaccia da un altra parte *)
let cleaned_t =
- FreshNamesGenerator.clean_dummy_dependent_types substituted_t in
+ if clean_dummy_dependent_types then
+ FreshNamesGenerator.clean_dummy_dependent_types substituted_t
+ else substituted_t in
let cleaned_ty =
- FreshNamesGenerator.clean_dummy_dependent_types substituted_ty in
+ if clean_dummy_dependent_types then
+ FreshNamesGenerator.clean_dummy_dependent_types substituted_ty
+ else substituted_ty in
let cleaned_metasenv =
+ if clean_dummy_dependent_types then
List.map
(function (n,context,ty) ->
let ty' = FreshNamesGenerator.clean_dummy_dependent_types ty in
Cic.Decl (FreshNamesGenerator.clean_dummy_dependent_types t))
| Some (n, Cic.Def (bo,ty)) ->
let bo' = FreshNamesGenerator.clean_dummy_dependent_types bo in
- let ty' =
- match ty with
- None -> None
- | Some ty ->
- Some (FreshNamesGenerator.clean_dummy_dependent_types ty)
+ let ty' = FreshNamesGenerator.clean_dummy_dependent_types ty
in
Some (n, Cic.Def (bo',ty'))
) context
in
(n,context',ty')
) substituted_metasenv
+ else
+ substituted_metasenv
in
- (cleaned_t,cleaned_ty,cleaned_metasenv,ugraph1)
+ (cleaned_t,cleaned_ty,cleaned_metasenv,subst',ugraph1)
+;;
+
+let type_of metasenv subst context t ug =
+ type_of_aux' metasenv subst context t ug
+;;
+
+let type_of_aux'
+ ?clean_dummy_dependent_types ?localization_tbl metasenv context t ug
+=
+ let t,ty,m,s,ug =
+ type_of_aux' ?clean_dummy_dependent_types ?localization_tbl
+ metasenv [] context t ug
+ in
+ t,ty,m,ug
;;
let undebrujin uri typesno tys t =
metasenv,ugraph,substituted_tys
let typecheck metasenv uri obj ~localization_tbl =
- let ugraph = CicUniv.empty_ugraph in
+ let ugraph = CicUniv.oblivion_ugraph in
match obj with
Cic.Constant (name,Some bo,ty,args,attrs) ->
+ (* CSC: ugly code. Here I need to retrieve in advance the loc of bo
+ since type_of_aux' destroys localization information (which are
+ preserved by type_of_aux *)
+ let loc exn' =
+ try
+ Cic.CicHash.find localization_tbl bo
+ with Not_found ->
+ HLog.debug ("!!! NOT LOCALIZED: " ^ CicPp.ppterm bo);
+ raise exn' in
let bo',boty,metasenv,ugraph =
type_of_aux' ~localization_tbl metasenv [] bo ugraph in
let ty',_,metasenv,ugraph =
type_of_aux' ~localization_tbl metasenv [] ty ugraph in
- let subst,metasenv,ugraph = fo_unif_subst [] [] metasenv boty ty' ugraph in
+ let subst,metasenv,ugraph =
+ try
+ fo_unif_subst [] [] metasenv boty ty' ugraph
+ with
+ RefineFailure _
+ | Uncertain _ as exn ->
+ let msg =
+ lazy ("(1) The term " ^
+ CicMetaSubst.ppterm_in_context ~metasenv [] bo' [] ^
+ " has type " ^
+ CicMetaSubst.ppterm_in_context ~metasenv [] boty [] ^
+ " but is here used with type " ^
+ CicMetaSubst.ppterm_in_context ~metasenv [] ty' [])
+ in
+ let exn' =
+ match exn with
+ RefineFailure _ -> RefineFailure msg
+ | Uncertain _ -> Uncertain msg
+ | _ -> assert false
+ in
+ raise (HExtlib.Localized (loc exn',exn'))
+ in
let bo' = CicMetaSubst.apply_subst subst bo' in
let ty' = CicMetaSubst.apply_subst subst ty' in
let metasenv = CicMetaSubst.apply_subst_metasenv subst metasenv in
Cic.Constant (name,Some bo',ty',args,attrs),metasenv,ugraph
| Cic.Constant (name,None,ty,args,attrs) ->
- let ty',_,metasenv,ugraph =
+ let ty',sort,metasenv,ugraph =
type_of_aux' ~localization_tbl metasenv [] ty ugraph
in
- Cic.Constant (name,None,ty',args,attrs),metasenv,ugraph
+ (match CicReduction.whd [] sort with
+ Cic.Sort _
+ | Cic.Meta _ -> Cic.Constant (name,None,ty',args,attrs),metasenv,ugraph
+ | _ -> raise (RefineFailure (lazy "")))
| Cic.CurrentProof (name,metasenv',bo,ty,args,attrs) ->
assert (metasenv' = metasenv);
(* Here we do not check the metasenv for correctness *)
let ty',sort,metasenv,ugraph =
type_of_aux' ~localization_tbl metasenv [] ty ugraph in
begin
- match sort with
+ match CicReduction.whd ~delta:true [] sort with
Cic.Sort _
(* instead of raising Uncertain, let's hope that the meta will become
a sort *)
List.fold_right
(fun (name,b,ty,cl) (metasenv,ugraph,res) ->
let ty',_,metasenv,ugraph =
- type_of_aux' ~localization_tbl metasenv [] ty ugraph
+ (* clean_dummy_dependent_types: false to avoid cleaning the names
+ of the left products, that must be identical to those of the
+ constructors; however, non-left products should probably be
+ cleaned *)
+ type_of_aux' ~clean_dummy_dependent_types:false ~localization_tbl
+ metasenv [] ty ugraph
in
metasenv,ugraph,(name,b,ty',cl)::res
) tys (metasenv,ugraph,[]) in
(fun (name,ty) (metasenv,ugraph,res) ->
let ty =
CicTypeChecker.debrujin_constructor
- ~cb:(relocalize localization_tbl) uri typesno ty in
+ ~cb:(relocalize localization_tbl) uri typesno [] ty in
let ty',_,metasenv,ugraph =
type_of_aux' ~localization_tbl metasenv con_context ty ugraph in
let ty' = undebrujin uri typesno tys ty' in
| C.Lambda (name,so,dest) ->
let ctx' = (Some (name,C.Decl so))::ctx in
C.Lambda (name, merge_coercions ctx so, merge_coercions ctx' dest)
- | C.LetIn (name,so,dest) ->
- let _,ty,metasenv,ugraph =
- pack_coercions := false;
- type_of_aux' metasenv ctx so CicUniv.oblivion_ugraph in
- pack_coercions := true;
- let ctx' = Some (name,(C.Def (so,Some ty)))::ctx in
- C.LetIn (name, merge_coercions ctx so, merge_coercions ctx' dest)
+ | C.LetIn (name,so,ty,dest) ->
+ let ctx' = Some (name,(C.Def (so,ty)))::ctx in
+ C.LetIn
+ (name, merge_coercions ctx so, merge_coercions ctx ty,
+ merge_coercions ctx' dest)
| C.Appl l ->
let l = List.map (merge_coercions ctx) l in
let t = C.Appl l in
merge_coercions ctx t
;;
-let pack_coercion_metasenv conjectures =
+let pack_coercion_metasenv conjectures = conjectures (*
+
+ TASSI: this code war written when coercions were a toy,
+ now packing coercions involves unification thus
+ the metasenv may change, and this pack coercion
+ does not handle that.
+
let module C = Cic in
List.map
(fun (i, ctx, ty) ->
in
((i,ctx,pack_coercion conjectures ctx ty))
) conjectures
+ *)
;;
-let pack_coercion_obj obj =
+let pack_coercion_obj obj = obj (*
+
+ TASSI: this code war written when coercions were a toy,
+ now packing coercions involves unification thus
+ the metasenv may change, and this pack coercion
+ does not handle that.
+
let module C = Cic in
match obj with
| C.Constant (id, body, ty, params, attrs) ->
(name, ind, arity, cl))
indtys
in
- C.InductiveDefinition (indtys, params, leftno, attrs)
+ C.InductiveDefinition (indtys, params, leftno, attrs) *)
;;
projects / helm.git / blobdiff