(PP.ppterm ~subst ~metasenv ~context t2))))
;;
-let eat_prods ~subst ~metasenv context he ty_he args_with_ty =
- let rec aux ty_he = function
- | [] -> ty_he
- | (arg, ty_arg)::tl ->
- match R.whd ~subst context ty_he with
- | C.Prod (_,s,t) ->
- if R.are_convertible ~subst context ty_arg s then
- aux (S.subst ~avoid_beta_redexes:true arg t) tl
- else
- raise
- (TypeCheckerFailure
- (lazy (Printf.sprintf
- ("Appl: wrong application of %s: the parameter %s has type"^^
- "\n%s\nbut it should have type \n%s\nContext:\n%s\n")
- (PP.ppterm ~subst ~metasenv ~context he)
- (PP.ppterm ~subst ~metasenv ~context arg)
- (PP.ppterm ~subst ~metasenv ~context ty_arg)
- (PP.ppterm ~subst ~metasenv ~context s)
- (PP.ppcontext ~subst ~metasenv context))))
- | _ ->
- raise
- (TypeCheckerFailure
- (lazy (Printf.sprintf
- "Appl: %s is not a function, it cannot be applied"
- (PP.ppterm ~subst ~metasenv ~context
- (let res = List.length tl in
- let eaten = List.length args_with_ty - res in
- (C.Appl
- (he::List.map fst
- (fst (HExtlib.split_nth eaten args_with_ty)))))))))
- in
- aux ty_he args_with_ty
-;;
+(* REMINDER: eat_prods was here *)
(* instantiate_parameters ps (x1:T1)...(xn:Tn)C *)
(* returns ((x_|ps|:T_|ps|)...(xn:Tn)C){ps_1 / x1 ; ... ; ps_|ps| / x_|ps|} *)
(*CSC: mettere in cicSubstitution *)
let rec subst_inductive_type_with_dummy _ = function
| C.Const (Ref.Ref (uri',Ref.Ind (true,0,_))) when NUri.eq uri' uri -> dummy
- | C.Appl ((C.Const (Ref.Ref (uri',Ref.Ind (true,0,_))))::_)
- when NUri.eq uri' uri -> dummy
+ | C.Appl ((C.Const (Ref.Ref (uri',Ref.Ind (true,0,lno))))::tl)
+ when NUri.eq uri' uri ->
+ let _, rargs = HExtlib.split_nth lno tl in
+ if rargs = [] then dummy else C.Appl (dummy :: rargs)
| t -> U.map (fun _ x->x) () subst_inductive_type_with_dummy t
in
- match R.whd context te with
- | C.Const (Ref.Ref (uri',Ref.Ind _))
- | C.Appl ((C.Const (Ref.Ref (uri',Ref.Ind _)))::_)
- when NUri.eq uri' uri -> true
- | C.Prod (name,source,dest) when
- does_not_occur ~subst ((name,C.Decl source)::context) 0 1 dest ->
- (* dummy abstraction, so we behave as in the anonimous case *)
- strictly_positive ~subst context n nn
- (subst_inductive_type_with_dummy () source) &&
- weakly_positive ~subst ((name,C.Decl source)::context)
- (n + 1) (nn + 1) uri dest
- | C.Prod (name,source,dest) ->
- does_not_occur ~subst context n nn
- (subst_inductive_type_with_dummy () source)&&
- weakly_positive ~subst ((name,C.Decl source)::context)
- (n + 1) (nn + 1) uri dest
- | _ ->
- raise (TypeCheckerFailure (lazy "Malformed inductive constructor type"))
+ (* this function has the same semantics of are_all_occurrences_positive
+ but the i-th context entry role is played by dummy and some checks
+ are skipped because we already know that are_all_occurrences_positive
+ of uri in te. *)
+ let rec aux context n nn te =
+ match R.whd context te with
+ | t when t = dummy -> true
+ | C.Appl (te::rargs) when te = dummy ->
+ List.for_all (does_not_occur ~subst context n nn) rargs
+ | C.Prod (name,source,dest) when
+ does_not_occur ~subst ((name,C.Decl source)::context) 0 1 dest ->
+ (* dummy abstraction, so we behave as in the anonimous case *)
+ strictly_positive ~subst context n nn source &&
+ weakly_positive ~subst ((name,C.Decl source)::context)
+ (n + 1) (nn + 1) uri dest
+ | C.Prod (name,source,dest) ->
+ does_not_occur ~subst context n nn source &&
+ weakly_positive ~subst ((name,C.Decl source)::context)
+ (n + 1) (nn + 1) uri dest
+ | _ ->
+ raise (TypeCheckerFailure (lazy "Malformed inductive constructor type"))
+ in
+ aux context n nn (subst_inductive_type_with_dummy () te)
and strictly_positive ~subst context n nn te =
match R.whd context te with
| C.LetIn (n,ty,t,bo) ->
let ty_t = typeof_aux context t in
let _ = typeof_aux context ty in
- if not (R.are_convertible ~subst context ty_t ty) then
+ if not (R.are_convertible ~subst get_relevance context ty_t ty) then
raise
(TypeCheckerFailure
(lazy (Printf.sprintf
let ty_branch =
type_of_branch ~subst context leftno outtype cons ty_cons 0
in
- j+1, R.are_convertible ~subst context ty_p ty_branch,
+ j+1, R.are_convertible ~subst get_relevance context ty_p ty_branch,
ty_p, ty_branch
else
j,false,old_p_ty,old_exp_p_ty
(_,C.Decl t1), (_,C.Decl t2)
| (_,C.Def (t1,_)), (_,C.Def (t2,_))
| (_,C.Def (_,t1)), (_,C.Decl t2) ->
- if not (R.are_convertible ~subst tl t1 t2) then
+ if not (R.are_convertible ~subst get_relevance tl t1 t2) then
raise
(TypeCheckerFailure
(lazy (Printf.sprintf
with Failure _ -> t)
| _ -> t
in
- if not (R.are_convertible ~subst context optimized_t ct)
+ if not (R.are_convertible ~subst get_relevance context optimized_t ct)
then
raise
(TypeCheckerFailure
(PP.ppterm ~subst ~metasenv ~context t))))
| t, (_,C.Decl ct) ->
let type_t = typeof_aux context t in
- if not (R.are_convertible ~subst context type_t ct) then
+ if not (R.are_convertible ~subst get_relevance context type_t ct) then
raise (TypeCheckerFailure
(lazy (Printf.sprintf
("Not well typed metavariable local context: "^^
"Local and canonical context %s have different lengths"
(PP.ppterm ~subst ~metasenv ~context term))))
- and is_non_informative context paramsno c =
- let rec aux context c =
- match R.whd context c with
- | C.Prod (n,so,de) ->
- let s = typeof_aux context so in
- s = C.Sort C.Prop && aux ((n,(C.Decl so))::context) de
- | _ -> true in
- let context',dx = split_prods ~subst:[] context paramsno c in
- aux context' dx
-
and check_allowed_sort_elimination ~subst ~metasenv r =
let mkapp he arg =
match he with
let arity2 = R.whd ~subst context arity2 in
match arity1,arity2 with
| C.Prod (name,so1,de1), C.Prod (_,so2,de2) ->
- if not (R.are_convertible ~subst context so1 so2) then
+ if not (R.are_convertible ~subst get_relevance context so1 so2) then
raise (TypeCheckerFailure (lazy (Printf.sprintf
"In outtype: expected %s, found %s"
(PP.ppterm ~subst ~metasenv ~context so1)
aux ((name, C.Decl so1)::context)
(mkapp (S.lift 1 ind) (C.Rel 1)) de1 de2
| C.Sort _, C.Prod (name,so,ta) ->
- if not (R.are_convertible ~subst context so ind) then
+ if not (R.are_convertible ~subst get_relevance context so ind) then
raise (TypeCheckerFailure (lazy (Printf.sprintf
"In outtype: expected %s, found %s"
(PP.ppterm ~subst ~metasenv ~context ind)
* have them already *)
let _,leftno,itl,_,i = E.get_checked_indtys r in
let itl_len = List.length itl in
- let _,name,ty,cl = List.nth itl i in
+ let _,_,_,cl = List.nth itl i in
let cl_len = List.length cl in
(* is it a singleton or empty non recursive and non informative
definition? *)
if not
(cl_len = 0 ||
(itl_len = 1 && cl_len = 1 &&
- is_non_informative [name,C.Decl ty] leftno
- (let _,_,x = List.nth cl 0 in x)))
+ is_non_informative leftno
+ (let _,_,x = List.hd cl in x)))
then
raise (TypeCheckerFailure (lazy
("Sort elimination not allowed")));
in
typeof_aux context term
+and eat_prods ~subst ~metasenv context he ty_he args_with_ty =
+ let rec aux ty_he = function
+ | [] -> ty_he
+ | (arg, ty_arg)::tl ->
+ match R.whd ~subst context ty_he with
+ | C.Prod (_,s,t) ->
+ if R.are_convertible ~subst get_relevance context ty_arg s then
+ aux (S.subst ~avoid_beta_redexes:true arg t) tl
+ else
+ raise
+ (TypeCheckerFailure
+ (lazy (Printf.sprintf
+ ("Appl: wrong application of %s: the parameter %s has type"^^
+ "\n%s\nbut it should have type \n%s\nContext:\n%s\n")
+ (PP.ppterm ~subst ~metasenv ~context he)
+ (PP.ppterm ~subst ~metasenv ~context arg)
+ (PP.ppterm ~subst ~metasenv ~context ty_arg)
+ (PP.ppterm ~subst ~metasenv ~context s)
+ (PP.ppcontext ~subst ~metasenv context))))
+ | _ ->
+ raise
+ (TypeCheckerFailure
+ (lazy (Printf.sprintf
+ "Appl: %s is not a function, it cannot be applied"
+ (PP.ppterm ~subst ~metasenv ~context
+ (let res = List.length tl in
+ let eaten = List.length args_with_ty - res in
+ (C.Appl
+ (he::List.map fst
+ (fst (HExtlib.split_nth eaten args_with_ty)))))))))
+ in
+ aux ty_he args_with_ty
+
+and is_non_informative paramsno c =
+ let rec aux context c =
+ match R.whd context c with
+ | C.Prod (n,so,de) ->
+ let s = typeof ~metasenv:[] ~subst:[] context so in
+ s = C.Sort C.Prop && aux ((n,(C.Decl so))::context) de
+ | _ -> true in
+ let context',dx = split_prods ~subst:[] [] paramsno c in
+ aux context' dx
+
and check_mutual_inductive_defs uri ~metasenv ~subst leftno tyl =
(* let's check if the arity of the inductive types are well formed *)
List.iter (fun (_,_,x,_) -> ignore (typeof ~subst ~metasenv [] x)) tyl;
let tys = List.rev_map (fun (_,n,ty,_) -> (n,(C.Decl ty))) tyl in
ignore
(List.fold_right
- (fun (_,_,ty,cl) i ->
+ (fun (it_relev,_,ty,cl) i ->
let context,ty_sort = split_prods ~subst [] ~-1 ty in
let sx_context_ty_rev,_ = HExtlib.split_nth leftno (List.rev context) in
List.iter
- (fun (_,_,te) ->
+ (fun (k_relev,_,te) ->
+ let _,k_relev = HExtlib.split_nth leftno k_relev in
let te = debruijn uri len [] te in
let context,te = split_prods ~subst tys leftno te in
let _,chopped_context_rev =
let convertible =
match item1,item2 with
(n1,C.Decl ty1),(n2,C.Decl ty2) ->
- n1 = n2 && R.are_convertible ~subst context ty1 ty2
+ n1 = n2 && R.are_convertible ~subst get_relevance context ty1 ty2
| (n1,C.Def (bo1,ty1)),(n2,C.Def (bo2,ty2)) ->
n1 = n2
- && R.are_convertible ~subst context ty1 ty2
- && R.are_convertible ~subst context bo1 bo2
+ && R.are_convertible ~subst get_relevance context ty1 ty2
+ && R.are_convertible ~subst get_relevance context bo1 bo2
| _,_ -> false
in
if not convertible then
then
raise
(TypeCheckerFailure
- (lazy ("Non positive occurence in "^NUri.string_of_uri uri))))
+ (lazy ("Non positive occurence in "^NUri.string_of_uri
+ uri)))
+ else check_relevance ~subst ~metasenv context k_relev te)
cl;
- i + 1)
+ check_relevance ~subst ~metasenv [] it_relev ty;
+ i+1)
tyl 1)
+and check_relevance ~subst ~metasenv context relevance ty =
+ let error context ty =
+ raise (TypeCheckerFailure
+ (lazy ("Wrong relevance declaration: " ^
+ String.concat "," (List.map string_of_bool relevance)^
+ "\nfor type: "^PP.ppterm ~metasenv ~subst ~context ty)))
+ in
+ let rec aux context relevance ty =
+ match R.whd ~subst context ty with
+ | C.Prod (name,so,de) ->
+ let sort = typeof ~subst ~metasenv context so in
+ (match (relevance,R.whd ~subst context sort) with
+ | [],_ -> ()
+ | false::tl,C.Sort C.Prop -> aux ((name,(C.Decl so))::context) tl de
+ | true::_,C.Sort C.Prop
+ | false::_,C.Sort _
+ | false::_,C.Meta _ -> error context ty
+ | true::tl,C.Sort _
+ | true::tl,C.Meta _ -> aux ((name,(C.Decl so))::context) tl de
+ | _ -> raise (AssertFailure (lazy (Printf.sprintf
+ "Prod: the type %s of the source of %s is not a sort"
+ (PP.ppterm ~subst ~metasenv ~context sort)
+ (PP.ppterm ~subst ~metasenv ~context so)))))
+ | _ -> (match relevance with
+ | [] -> ()
+ | _::_ -> error context ty)
+ in aux context relevance ty
+
and guarded_by_destructors r_uri r_len ~subst ~metasenv context recfuns t =
let recursor f k t = U.fold shift_k k (fun k () -> f k) () t in
let rec aux (context, recfuns, x as k) t =
if h1 <> h2 then error ();
ty
| _ -> raise (AssertFailure (lazy "type_of_constant: environment/reference"))
+
+and get_relevance ~subst context t args =
+ let ty = typeof ~subst ~metasenv:[] context t in
+ let rec aux context ty = function
+ | [] -> []
+ | arg::tl -> match R.whd ~subst context ty with
+ | C.Prod (_,so,de) ->
+ let sort = typeof ~subst ~metasenv:[] context so in
+ let new_ty = S.subst ~avoid_beta_redexes:true arg de in
+ (*prerr_endline ("so: " ^ PP.ppterm ~subst ~metasenv:[]
+ ~context so);
+ prerr_endline ("sort: " ^ PP.ppterm ~subst ~metasenv:[]
+ ~context sort);*)
+ (match R.whd ~subst context sort with
+ | C.Sort C.Prop ->
+ false::(aux context new_ty tl)
+ | C.Sort _
+ | C.Meta _ -> true::(aux context new_ty tl)
+ | _ -> raise (TypeCheckerFailure (lazy (Printf.sprintf
+ "Prod: the type %s of the source of %s is not a sort"
+ (PP.ppterm ~subst ~metasenv:[] ~context sort)
+ (PP.ppterm ~subst ~metasenv:[] ~context so)))))
+ | _ ->
+ raise
+ (TypeCheckerFailure
+ (lazy (Printf.sprintf
+ "Appl: %s is not a function, it cannot be applied"
+ (PP.ppterm ~subst ~metasenv:[] ~context
+ (let res = List.length tl in
+ let eaten = List.length args - res in
+ (C.Appl
+ (t::fst
+ (HExtlib.split_nth eaten args))))))))
+ in aux context ty args
;;
let typecheck_context ~metasenv ~subst context =
| name,C.Def (te,ty) ->
ignore (typeof ~metasenv ~subst:[] context ty);
let ty' = typeof ~metasenv ~subst:[] context te in
- if not (R.are_convertible ~subst context ty' ty) then
+ if not (R.are_convertible ~subst get_relevance context ty' ty) then
raise (AssertFailure (lazy (Printf.sprintf (
"the type of the definiens for %s in the context is not "^^
"convertible with the declared one.\n"^^
typecheck_context ~metasenv ~subst context;
ignore (typeof ~metasenv ~subst context ty);
let ty' = typeof ~metasenv ~subst context bo in
- if not (R.are_convertible ~subst context ty' ty) then
+ if not (R.are_convertible ~subst get_relevance context ty' ty) then
raise (AssertFailure (lazy (Printf.sprintf (
"the type of the definiens for %d in the substitution is not "^^
"convertible with the declared one.\n"^^
) [] subst)
;;
+
let typecheck_obj (uri,_height,metasenv,subst,kind) =
(* height is not checked since it is only used to implement an optimization *)
typecheck_metasenv metasenv;
| C.Constant (relevance,_,Some te,ty,_) ->
let _ = typeof ~subst ~metasenv [] ty in
let ty_te = typeof ~subst ~metasenv [] te in
- if not (R.are_convertible ~subst [] ty_te ty) then
+ if not (R.are_convertible ~subst get_relevance [] ty_te ty) then
raise (TypeCheckerFailure (lazy (Printf.sprintf (
"the type of the body is not convertible with the declared one.\n"^^
"inferred type:\n%s\nexpected type:\n%s")
(PP.ppterm ~subst ~metasenv ~context:[] ty_te)
- (PP.ppterm ~subst ~metasenv ~context:[] ty))))
+ (PP.ppterm ~subst ~metasenv ~context:[] ty))));
+ check_relevance ~subst ~metasenv [] relevance ty
+ (*check_relevance ~in_type:false ~subst ~metasenv relevance te*)
| C.Constant (relevance,_,None,ty,_) ->
- ignore (typeof ~subst ~metasenv [] ty)
+ ignore (typeof ~subst ~metasenv [] ty);
+ check_relevance ~subst ~metasenv [] relevance ty
| C.Inductive (_, leftno, tyl, _) ->
check_mutual_inductive_defs uri ~metasenv ~subst leftno tyl
| C.Fixpoint (inductive,fl,_) ->
List.fold_left
(fun (types,kl) (relevance,name,k,ty,_) ->
let _ = typeof ~subst ~metasenv [] ty in
+ check_relevance ~subst ~metasenv [] relevance ty;
((name,C.Decl ty)::types, k::kl)
) ([],[]) fl
in
in
List.iter2 (fun (_,_,x,ty,_) bo ->
let ty_bo = typeof ~subst ~metasenv types bo in
- if not (R.are_convertible ~subst types ty_bo ty)
+ if not (R.are_convertible ~subst get_relevance types ty_bo ty)
then raise (TypeCheckerFailure (lazy ("(Co)Fix: ill-typed bodies")))
else
if inductive then begin
projects / helm.git / blobdiff