| e -> raise e
;;
-let exp_implicit metasenv context expty =
+let exp_implicit ~localise metasenv context expty t =
let foo x = match expty with Some t -> `WithType t | None -> x in
function
| `Closed -> NCicMetaSubst.mk_meta metasenv [] (foo `Term)
| `Type -> NCicMetaSubst.mk_meta metasenv context (foo `Type)
| `Term -> NCicMetaSubst.mk_meta metasenv context (foo `Term)
+ | `Vector ->
+ raise (RefineFailure (lazy (localise t, "A vector of implicit terms " ^
+ "can only be used in argument position")))
| _ -> assert false
;;
-
let check_allowed_sort_elimination rdb localise r orig =
let mkapp he arg =
match he with
?(localise=fun _ -> Stdpp.dummy_loc)
metasenv subst context term expty
=
- let force_ty skip_lambda metasenv subst context orig t infty expty =
+ let force_ty skip_lambda skip_appl metasenv subst context orig t infty expty =
(*D*)inside 'F'; try let rc =
match expty with
| Some expty ->
(match t with
| C.Implicit _ -> assert false
| C.Lambda _ when skip_lambda -> metasenv, subst, t, expty
+ | C.Appl _ when skip_appl -> metasenv, subst, t, expty
| _ ->
pp (lazy (
(NCicPp.ppterm ~metasenv ~subst ~context infty) ^ " === " ^
NCicPp.ppterm ~subst ~metasenv ~context t)))
| C.Sort _ -> metasenv,subst,t,(C.Sort (C.Type NCicEnvironment.type0))
| C.Implicit infos ->
- let metasenv,_,t,ty = exp_implicit metasenv context expty infos in
- metasenv, subst, t, ty
+ let metasenv,_,t,ty =
+ exp_implicit ~localise metasenv context expty t infos
+ in
+ metasenv, subst, t, ty
| C.Meta (n,l) as t ->
let ty =
try
typeof_aux metasenv subst context_for_t exp_ty_t t
in
if force_after then
- force_ty false metasenv subst context orig
+ force_ty false true metasenv subst context orig
(C.Lambda(n,s,t)) (C.Prod (n,s,ty_t)) expty
else
metasenv, subst, C.Lambda(n,s,t), C.Prod (n,s,ty_t)
let bo_ty = NCicSubstitution.subst ~avoid_beta_redexes:true t bo_ty in
metasenv, subst, C.LetIn (n, ty, t, bo), bo_ty
| C.Appl ((he as orig_he)::(_::_ as args)) ->
- let upto =
- match orig_he with C.Meta _ -> List.length args | _ -> 0
- in
+ let upto = match orig_he with C.Meta _ -> List.length args | _ -> 0 in
let metasenv, subst, he, ty_he =
typeof_aux metasenv subst context None he in
let metasenv, subst, t, ty =
- eat_prods rdb ~localise
- metasenv subst context orig_he he ty_he args
- in
+ eat_prods rdb ~localise force_ty metasenv subst context expty t
+ orig_he he ty_he args in
let t = if upto > 0 then NCicReduction.head_beta_reduce ~upto t else t in
metasenv, subst, t, ty
| C.Appl _ -> raise (AssertFailure (lazy "Appl of length < 2"))
in
pp (lazy (NCicPp.ppterm ~metasenv ~subst ~context t ^ " :: "^
NCicPp.ppterm ~metasenv ~subst ~context infty ));
- force_ty true metasenv subst context orig t infty expty
+ force_ty true true metasenv subst context orig t infty expty
(*D*)in outside(); rc with exc -> outside (); raise exc
in
typeof_aux metasenv subst context expty term
| NCicUnification.Uncertain _ as exc -> first exc tl
in
first exc
- (NCicCoercion.look_for_coercion
- rdb.NRstatus.coerc_db metasenv subst context infty expty)
+ (NCicCoercion.look_for_coercion rdb metasenv subst context infty expty)
and force_to_sort rdb metasenv subst context t orig_t localise ty =
match NCicReduction.whd ~subst context ty with
with NCicUtils.Subst_not_found _ -> aux 'M')
| _ -> aux 'H'
-and eat_prods rdb
- ~localise metasenv subst context orig_he he ty_he args
-=
+and eat_prods rdb ~localise force_ty metasenv subst context expty orig_t orig_he he ty_he args =
(*D*)inside 'E'; try let rc =
+ let too_many_args = ref false in
let rec aux metasenv subst args_so_far he ty_he = function
- | []->metasenv, subst, NCicUntrusted.mk_appl he (List.rev args_so_far), ty_he
+ | [] ->
+ let res = NCicUntrusted.mk_appl he (List.rev args_so_far) in
+ (match NCicReduction.whd ~subst context ty_he with
+ NCic.Meta _ | NCic.Appl (NCic.Meta _::_) ->
+ too_many_args := true;
+ | _ -> ());
+ force_ty true false metasenv subst context orig_t res ty_he expty
+ | NCic.Implicit `Vector::tl ->
+ (try
+ too_many_args := false;
+ aux metasenv subst args_so_far he ty_he tl
+ with
+ Uncertain _
+ | RefineFailure _ as exc when !too_many_args <> true ->
+ try
+ aux metasenv subst args_so_far he ty_he
+ (NCic.Implicit `Vector :: NCic.Implicit `Term :: tl)
+ with
+ Uncertain msg | RefineFailure msg -> raise (wrap_exc msg exc))
| arg::tl ->
match NCicReduction.whd ~subst context ty_he with
| C.Prod (_,s,t) ->
^ "\nOF: " ^
NCicPp.ppterm ~metasenv ~subst ~context t ^ " === " ^
NCicPp.ppterm ~metasenv ~subst ~context flex_prod ^ "\n"));
- let metasenv, subst =
+ let metasenv, subst =
+ too_many_args := true;
try NCicUnification.unify rdb metasenv subst context t flex_prod
with exc -> raise (wrap_exc (lazy (localise orig_he, Printf.sprintf
("The term %s has an inferred type %s, but is applied to the" ^^
| C.Match (_,_,C.Meta _,_)
| C.Match (_,_,C.Appl (C.Meta _ :: _),_)
| C.Appl (C.Const (NReference.Ref (_, NReference.Fix _)) :: _) ->
+ too_many_args := true;
raise (Uncertain (lazy (localise orig_he, Printf.sprintf
("The term %s is here applied to %d arguments but expects " ^^
"only %d arguments") (NCicPp.ppterm ~metasenv ~subst ~context he)
(List.length args) (List.length args_so_far))))
| ty ->
let metasenv, subst, newhead, newheadty =
+ too_many_args := true;
try_coercions rdb ~localise metasenv subst context
(NCicUntrusted.mk_appl he (List.rev args_so_far)) orig_he ty
(NCic.Prod ("_",NCic.Implicit `Term,NCic.Implicit `Term))
"only %d arguments") (NCicPp.ppterm ~metasenv ~subst ~context he)
(List.length args) (List.length args_so_far))))
in
- aux metasenv subst [] newhead newheadty (arg :: tl)
+ too_many_args := false;
+ aux metasenv subst [] newhead newheadty (arg :: tl)
in
(* We need to reverse the order of the new created metas since they
are pushed on top of the metasenv in the wrong order *)
let typeof_obj
rdb ?(localise=fun _ -> Stdpp.dummy_loc) (uri,height,metasenv,subst,obj)
=
-prerr_endline ("===============\n" ^ NCicPp.ppobj (uri,height,metasenv,subst,obj));
let check_type metasenv subst context (ty as orig_ty) = (* XXX fattorizza *)
let metasenv, subst, ty, sort =
typeof rdb ~localise metasenv subst context ty None
match bo with
| Some bo ->
let metasenv, subst, bo, ty =
- typeof rdb ~localise metasenv subst [] bo (Some ty)
- in
+ typeof rdb ~localise metasenv subst [] bo (Some ty) in
let height = (* XXX recalculate *) height in
metasenv, subst, Some bo, ty, height
| None -> metasenv, subst, None, ty, 0
List.fold_left
(fun (types, metasenv, subst, fl) (relevance,name,k,ty,bo) ->
let metasenv, subst, ty, _ = check_type metasenv subst [] ty in
- let dbo = NCicTypeChecker.debruijn uri len [] bo in
+ let dbo = NCicTypeChecker.debruijn uri len [] ~subst bo in
let localise = relocalise localise dbo bo in
(name,C.Decl ty)::types,
metasenv, subst, (relevance,name,k,ty,dbo,localise)::fl
let k_relev =
try snd (HExtlib.split_nth leftno k_relev)
with Failure _ -> k_relev in
- let te = NCicTypeChecker.debruijn uri len [] te in
+ let te = NCicTypeChecker.debruijn uri len [] ~subst te in
let metasenv, subst, te, _ = check_type metasenv subst tys te in
let context,te = NCicReduction.split_prods ~subst tys leftno te in
let _,chopped_context_rev =
raise
(RefineFailure
(lazy (localise te,
- "Non positive occurence in " ^ NUri.string_of_uri uri)))
+ "Non positive occurence in " ^
+ NCicPp.ppterm ~metasenv ~subst ~context te)))
else
let relsno = List.length itl + leftno in
let te =
uri, height, metasenv, subst, C.Inductive (ind, leftno, itl, attr)
;;
+NCicUnification.set_refiner_typeof typeof;;
+
(* vim:set foldmethod=marker: *)
projects / helm.git / blobdiff