(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|} *)
| 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: "^^
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)
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
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 (name,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 check_rel1_irrelevant ~metasenv ~subst context =
- let shift e (k, context) = k+1,e::context in
+let check_rel1_irrelevant ~metasenv ~subst context = fun _ -> ();;
+(* let shift e (k, context) = k+1,e::context in
let rec aux (evil, context as k) () t =
match R.whd ~subst context t with
- | C.Rel i when i = evil -> raise (TypeCheckerFailure (lazy (Printf.sprintf
+ | C.Rel i when i = evil -> (*
+ raise (TypeCheckerFailure (lazy (Printf.sprintf
"Argument %s declared as irrelevante is used in a relevant position"
- (PP.ppterm ~subst ~metasenv ~context (C.Rel i)))))
+ (PP.ppterm ~subst ~metasenv ~context (C.Rel i))))) *) ()
| C.Meta _ -> ()
| C.Lambda (name,so,tgt) ->
(* checking so is not needed since the implicit version of CC
| C.Match (_, _, t, pl) -> List.iter (aux k ()) (t::pl)
| t -> U.fold shift k aux () t
in
- aux (1, context) ()
-
-let check_relevance ~metasenv ~subst ~in_type relevance =
- let shift e (in_type, context, relevance) =
- assert (relevance = []); in_type, e::context, relevance
- in
- let rec aux (in_type, context, relevance as k) () t =
- match relevance, R.whd ~subst context t, in_type with
- | _,C.Meta _,_ -> ()
- | true::tl,C.Lambda (name,so,t), false
- | true::tl,C.Prod (name,so,t), true ->
- aux (in_type, (name, C.Decl so)::context, tl) () t
- | false::tl,C.Lambda (name,so,t), false
- | false::tl,C.Prod (name,so,t), true ->
- let context = (name, C.Decl so)::context in
- check_rel1_irrelevant ~metasenv ~subst context t;
- aux (in_type, context, tl) () t
- | [], C.Match (ref,oty,t,pl), _ ->
- aux k () t;
- let _,lno,itl,_,i = E.get_checked_indtys ref in
- let rel,_,_,cl = List.nth itl i in
- let _, rel = HExtlib.split_nth lno rel in
- aux (false, context, rel) () oty;
- List.iter2
- (fun p (rel,_,_) ->
- let _,rel = HExtlib.split_nth lno rel in
- aux (false, context, rel) () p)
- pl cl
- | [],t,_ -> U.fold shift k aux () t
- | _,_,_ ->
- raise (TypeCheckerFailure (lazy "Wrong relevance declaration"))
- in
- aux (in_type, [], relevance) ()
-;;
+ aux (1, context) () *)
let typecheck_obj (uri,_height,metasenv,subst,kind) =
(* height is not checked since it is only used to implement an optimization *)
| 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))));
- check_relevance ~in_type:true ~subst ~metasenv relevance ty;
- check_relevance ~in_type:false ~subst ~metasenv relevance te
+ 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);
- check_relevance ~in_type:true ~subst ~metasenv relevance 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