(* $Id$ *) open Pp open Util open Names open Univ open Generic open Term open Evd open Constant open Inductive open Sign open Environ open Reduction open Instantiate open Type_errors let make_judge v tj = { uj_val = v; uj_type = tj.body; uj_kind= DOP0 (Sort tj.typ) } let j_val_only j = j.uj_val (* Faut-il caster ? *) let j_val = j_val_only let j_val_cast j = mkCast j.uj_val j.uj_type let typed_type_of_judgment env j = match whd_betadeltaiota env j.uj_type with | DOP0(Sort s) -> { body = j.uj_val; typ = s } | _ -> error_not_type CCI env j.uj_val let assumption_of_judgement env j = match whd_betadeltaiota env j.uj_type with | DOP0(Sort s) -> { body = j.uj_val; typ = s } | _ -> error_assumption CCI env j.uj_val (* Type of a de Bruijn index. *) let relative env n = try let (_,typ) = lookup_rel n env in { uj_val = Rel n; uj_type = lift n typ.body; uj_kind = DOP0 (Sort typ.typ) } with Not_found -> error_unbound_rel CCI env n (* Management of context of variables. *) (* Checks if a context of variable is included in another one. *) let hyps_inclusion env (idl1,tyl1) (idl2,tyl2) = let rec aux = function | ([], [], _, _) -> true | (_, _, [], []) -> false | ((id1::idl1), (ty1::tyl1), idl2, tyl2) -> let rec search = function | ([], []) -> false | ((id2::idl2), (ty2::tyl2)) -> if id1 = id2 then (is_conv env (body_of_type ty1) (body_of_type ty2)) & aux (idl1,tyl1,idl2,tyl2) else search (idl2,tyl2) | (_, _) -> invalid_arg "hyps_inclusion" in search (idl2,tyl2) | (_, _, _, _) -> invalid_arg "hyps_inclusion" in aux (idl1,tyl1,idl2,tyl2) (* Checks if the given context of variables [hyps] is included in the current context of [env]. *) let construct_reference id env hyps = let hyps' = get_globals (context env) in if hyps_inclusion env hyps hyps' then Array.of_list (List.map (fun id -> VAR id) (ids_of_sign hyps)) else error_reference_variables CCI env id let check_hyps id env hyps = let hyps' = get_globals (context env) in if not (hyps_inclusion env hyps hyps') then error_reference_variables CCI env id (* Instantiation of terms on real arguments. *) let type_of_constant env c = let (sp,args) = destConst c in let cb = lookup_constant sp env in let hyps = cb.const_hyps in check_hyps (basename sp) env hyps; instantiate_type (ids_of_sign hyps) cb.const_type (Array.to_list args) (* Existentials. *) let type_of_existential env c = let (sp,args) = destConst c in let info = Evd.map (evar_map env) sp in let hyps = info.evar_hyps in check_hyps (basename sp) env hyps; instantiate_type (ids_of_sign hyps) info.evar_concl (Array.to_list args) (* Constants or existentials. *) let type_of_constant_or_existential env c = if is_existential c then type_of_existential env c else type_of_constant env c (* Inductive types. *) let instantiate_arity mis = let ids = ids_of_sign mis.mis_mib.mind_hyps in let args = Array.to_list mis.mis_args in let arity = mis.mis_mip.mind_arity in { body = instantiate_constr ids arity.body args; typ = arity.typ } let type_of_inductive env i = let mis = lookup_mind_specif i env in let hyps = mis.mis_mib.mind_hyps in check_hyps (basename mis.mis_sp) env hyps; instantiate_arity mis (* Constructors. *) let instantiate_lc mis = let hyps = mis.mis_mib.mind_hyps in let lc = mis.mis_mip.mind_lc in instantiate_constr (ids_of_sign hyps) lc (Array.to_list mis.mis_args) let type_of_constructor env c = let (sp,i,j,args) = destMutConstruct c in let mind = DOPN (MutInd (sp,i), args) in let recmind = check_mrectype_spec env mind in let mis = lookup_mind_specif recmind env in check_hyps (basename mis.mis_sp) env (mis.mis_mib.mind_hyps); let specif = instantiate_lc mis in let make_ik k = DOPN (MutInd (mis.mis_sp,k), mis.mis_args) in if j > mis_nconstr mis then anomaly "type_of_constructor" else sAPPViList (j-1) specif (list_tabulate make_ik (mis_ntypes mis)) (* gives the vector of constructors and of types of constructors of an inductive definition correctly instanciated *) let mis_type_mconstructs mis = let specif = instantiate_lc mis and ntypes = mis_ntypes mis and nconstr = mis_nconstr mis in let make_ik k = DOPN (MutInd (mis.mis_sp,k), mis.mis_args) and make_ck k = DOPN (MutConstruct ((mis.mis_sp,mis.mis_tyi),k+1), mis.mis_args) in (Array.init nconstr make_ck, sAPPVList specif (list_tabulate make_ik ntypes)) let type_mconstructs env mind = let redmind = check_mrectype_spec env mind in let mis = lookup_mind_specif redmind env in mis_type_mconstructs mis (* Case. *) let rec sort_of_arity env c = match whd_betadeltaiota env c with | DOP0(Sort( _)) as c' -> c' | DOP2(Prod,_,DLAM(_,c2)) -> sort_of_arity env c2 | _ -> invalid_arg "sort_of_arity" let make_arity_dep env k = let rec mrec c m = match whd_betadeltaiota env c with | DOP0(Sort _) -> mkArrow m k | DOP2(Prod,b,DLAM(n,c_0)) -> prod_name env (n,b,mrec c_0 (applist(lift 1 m,[Rel 1]))) | _ -> invalid_arg "make_arity_dep" in mrec let make_arity_nodep env k = let rec mrec c = match whd_betadeltaiota env c with | DOP0(Sort _) -> k | DOP2(Prod,b,DLAM(x,c_0)) -> DOP2(Prod,b,DLAM(x,mrec c_0)) | _ -> invalid_arg "make_arity_nodep" in mrec let error_elim_expln env kp ki = if is_info_sort env kp && not (is_info_sort env ki) then "non-informative objects may not construct informative ones." else match (kp,ki) with | (DOP0(Sort (Type _)), DOP0(Sort (Prop _))) -> "strong elimination on non-small inductive types leads to paradoxes." | _ -> "wrong arity" exception Arity of (constr * constr * string) option let is_correct_arity env kelim (c,p) = let rec srec ind (pt,t) = try (match whd_betadeltaiota env pt, whd_betadeltaiota env t with | DOP2(Prod,a1,DLAM(_,a2)), DOP2(Prod,a1',DLAM(_,a2')) -> if is_conv env a1 a1' then srec (applist(lift 1 ind,[Rel 1])) (a2,a2') else raise (Arity None) | DOP2(Prod,a1,DLAM(_,a2)), ki -> let k = whd_betadeltaiota env a2 in let ksort = (match k with DOP0(Sort s) -> s | _ -> raise (Arity None)) in if is_conv env a1 ind then if List.exists (base_sort_cmp CONV ksort) kelim then (true,k) else raise (Arity (Some(k,ki,error_elim_expln env k ki))) else raise (Arity None) | k, DOP2(Prod,_,_) -> raise (Arity None) | k, ki -> let ksort = (match k with DOP0(Sort s) -> s | _ -> raise (Arity None)) in if List.exists (base_sort_cmp CONV ksort) kelim then false,k else raise (Arity (Some(k,ki,error_elim_expln env k ki)))) with Arity kinds -> let listarity = (List.map (fun s -> make_arity_dep env (DOP0(Sort s)) t ind) kelim) @(List.map (fun s -> make_arity_nodep env (DOP0(Sort s)) t) kelim) in error_elim_arity CCI env ind listarity c p pt kinds in srec let cast_instantiate_arity mis = let tty = instantiate_arity mis in DOP2 (Cast, tty.body, DOP0 (Sort tty.typ)) let find_case_dep_nparams env (c,p) (mind,largs) typP = let mis = lookup_mind_specif mind env in let nparams = mis_nparams mis and kelim = mis_kelim mis and t = cast_instantiate_arity mis in let (globargs,la) = list_chop nparams largs in let glob_t = hnf_prod_applist env "find_elim_boolean" t globargs in let arity = applist(mind,globargs) in let (dep,_) = is_correct_arity env kelim (c,p) arity (typP,glob_t) in (dep, (nparams, globargs,la)) let type_one_branch_dep (env,nparams,globargs,p) co t = let rec typrec n c = match whd_betadeltaiota env c with | DOP2(Prod,a1,DLAM(x,a2)) -> prod_name env (x,a1,typrec (n+1) a2) | x -> let lAV = destAppL (ensure_appl x) in let (_,vargs) = array_chop (nparams+1) lAV in applist (appvect ((lift n p),vargs), [applist(co,((List.map (lift n) globargs)@(rel_list 0 n)))]) in typrec 0 (hnf_prod_applist env "type_case" t globargs) let type_one_branch_nodep (env,nparams,globargs,p) t = let rec typrec n c = match whd_betadeltaiota env c with | DOP2(Prod,a1,DLAM(x,a2)) -> DOP2(Prod,a1,DLAM(x,typrec (n+1) a2)) | x -> let lAV = destAppL(ensure_appl x) in let (_,vargs) = array_chop (nparams+1) lAV in appvect (lift n p,vargs) in typrec 0 (hnf_prod_applist env "type_case" t globargs) (* type_case_branches type un
Case c of ... end
ct = type de c, si inductif il a la forme APP(mI,largs), sinon raise Induc
pt = sorte de p
type_case_branches retourne (lb, lr); lb est le vecteur des types
attendus dans les branches du Case; lr est le type attendu du resultat
*)
let type_case_branches env ct pt p c =
try
let ((mI,largs) as indt) = find_mrectype env ct in
let (dep,(nparams,globargs,la)) =
find_case_dep_nparams env (c,p) indt pt
in
let (lconstruct,ltypconstr) = type_mconstructs env mI in
if dep then
(mI,
array_map2 (type_one_branch_dep (env,nparams,globargs,p))
lconstruct ltypconstr,
beta_applist (p,(la@[c])))
else
(mI,
Array.map (type_one_branch_nodep (env,nparams,globargs,p))
ltypconstr,
beta_applist (p,la))
with Induc ->
error_case_not_inductive CCI env c ct
let check_branches_message env (c,ct) (explft,lft) =
let n = Array.length explft
and expn = Array.length lft in
let rec check_conv i =
if not (i = n) then
if not (is_conv_leq env lft.(i) (explft.(i))) then
error_ill_formed_branch CCI env c i (nf_betaiota env lft.(i))
(nf_betaiota env explft.(i))
else
check_conv (i+1)
in
if n<>expn then error_number_branches CCI env c ct expn else check_conv 0
let type_of_case env pj cj lfj =
let lft = Array.map (fun j -> j.uj_type) lfj in
let (mind,bty,rslty) =
type_case_branches env cj.uj_type pj.uj_type pj.uj_val cj.uj_val in
let kind = sort_of_arity env pj.uj_type in
check_branches_message env (cj.uj_val,cj.uj_type) (bty,lft);
{ uj_val =
mkMutCaseA (ci_of_mind mind) (j_val pj) (j_val cj) (Array.map j_val lfj);
uj_type = rslty;
uj_kind = kind }
(* Prop and Set *)
let type_of_prop_or_set cts =
{ uj_val = DOP0(Sort(Prop cts));
uj_type = DOP0(Sort type_0);
uj_kind = DOP0(Sort type_1) }
(* Type of Type(i). *)
let type_of_type u g =
let (uu,g') = super u g in
let (uuu,g'') = super uu g' in
{ uj_val = DOP0 (Sort (Type u));
uj_type = DOP0 (Sort (Type uu));
uj_kind = DOP0 (Sort (Type uuu)) },
g''
let type_of_sort c g =
match c with
| DOP0 (Sort (Type u)) -> let (uu,g') = super u g in mkType uu, g'
| DOP0 (Sort (Prop _)) -> mkType prop_univ, g
| DOP0 (Implicit) -> mkImplicit, g
| _ -> invalid_arg "type_of_sort"
(* Type of a lambda-abstraction. *)
let sort_of_product domsort rangsort g0 =
match rangsort with
(* Product rule (s,Prop,Prop) *)
| Prop _ -> rangsort, g0
| Type u2 ->
(match domsort with
(* Product rule (Prop,Type_i,Type_i) *)
| Prop _ -> rangsort, g0
(* Product rule (Type_i,Type_i,Type_i) *)
| Type u1 -> let (u12,g1) = sup u1 u2 g0 in Type u12, g1)
let abs_rel env name var j =
let rngtyp = whd_betadeltaiota env j.uj_kind in
let cvar = incast_type var in
let (s,g) = sort_of_product var.typ (destSort rngtyp) (universes env) in
{ uj_val = mkLambda name cvar (j_val j);
uj_type = mkProd name cvar j.uj_type;
uj_kind = mkSort s },
g
(* Type of a product. *)
let gen_rel env name var j =
let jtyp = whd_betadeltaiota env j.uj_type in
let jkind = whd_betadeltaiota env j.uj_kind in
let j = { uj_val = j.uj_val; uj_type = jtyp; uj_kind = jkind } in
if isprop jkind then
error "Proof objects can only be abstracted"
else
match jtyp with
| DOP0(Sort s) ->
let (s',g) = sort_of_product var.typ s (universes env) in
let res_type = mkSort s' in
let (res_kind,g') = type_of_sort res_type g in
{ uj_val =
mkProd name (mkCast var.body (mkSort var.typ)) (j_val_cast j);
uj_type = res_type;
uj_kind = res_kind }, g'
| _ ->
error_generalization CCI env (name,var) j.uj_val
(* Type of a cast. *)
let cast_rel env cj tj =
if is_conv_leq env cj.uj_type tj.uj_val then
{ uj_val = j_val_only cj;
uj_type = tj.uj_val;
uj_kind = whd_betadeltaiota env tj.uj_type }
else
error_actual_type CCI env cj.uj_val cj.uj_type tj.uj_val
(* Type of an application. *)
let apply_rel_list env0 nocheck argjl funj =
let rec apply_rec env typ = function
| [] ->
{ uj_val = applist (j_val_only funj, List.map j_val_only argjl);
uj_type = typ;
uj_kind = funj.uj_kind },
universes env
| hj::restjl ->
match whd_betadeltaiota env typ with
| DOP2(Prod,c1,DLAM(_,c2)) ->
if nocheck then
apply_rec env (subst1 hj.uj_val c2) restjl
else
(match conv_leq env hj.uj_type c1 with
| Convertible g ->
let env' = set_universes g env in
apply_rec env' (subst1 hj.uj_val c2) restjl
| NotConvertible ->
error_cant_apply CCI env "Type Error" funj argjl)
| _ ->
error_cant_apply CCI env "Non-functional construction" funj argjl
in
apply_rec env0 funj.uj_type argjl
(* Fixpoints. *)
(* Checking function for terms containing existential variables.
The function noccur_with_meta consideres the fact that
each existential variable (as well as each isevar)
in the term appears applied to its local context,
which may contain the CoFix variables. These occurrences of CoFix variables
are not considered *)
let noccur_with_meta sigma n m term =
let rec occur_rec n = function
| Rel(p) -> if n<=p & p