X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Fsoftware%2Fcomponents%2Fng_refiner%2FnCicRefiner.ml;h=191bd708c3e6abbf3b843f89b3723df66a3a54c9;hb=24cbdd6b6b83b878797f067a4ae358b0fc4c4337;hp=36e9b3d24b3cc6c81e39cd3e86556f968f4dcab2;hpb=023b925489d007fc1a39087e2770aac4b2740159;p=helm.git diff --git a/helm/software/components/ng_refiner/nCicRefiner.ml b/helm/software/components/ng_refiner/nCicRefiner.ml index 36e9b3d24..191bd708c 100644 --- a/helm/software/components/ng_refiner/nCicRefiner.ml +++ b/helm/software/components/ng_refiner/nCicRefiner.ml @@ -18,6 +18,18 @@ exception AssertFailure of string Lazy.t;; module C = NCic module Ref = NReference +let indent = ref "";; +let inside c = indent := !indent ^ String.make 1 c;; +let outside () = indent := String.sub !indent 0 (String.length !indent -1);; + +(* +let pp s = + prerr_endline (Printf.sprintf "%-20s" !indent ^ " " ^ Lazy.force s) +;; +*) + +let pp _ = ();; + let wrap_exc msg = function | NCicUnification.Uncertain _ -> Uncertain msg | NCicUnification.UnificationFailure _ -> RefineFailure msg @@ -28,53 +40,12 @@ let wrap_exc msg = function let exp_implicit metasenv context expty = let foo x = match expty with Some t -> `WithType t | None -> x in function - | `Closed -> NCicMetaSubst.mk_meta metasenv [] (foo `Type) + | `Closed -> NCicMetaSubst.mk_meta metasenv [] (foo `Term) | `Type -> NCicMetaSubst.mk_meta metasenv context (foo `Type) | `Term -> NCicMetaSubst.mk_meta metasenv context (foo `Term) | _ -> assert false ;; -let force_to_sort metasenv subst context t = - match NCicReduction.whd ~subst context t with - | C.Meta (_,(_,(C.Irl 0 | C.Ctx []))) as t -> - metasenv, subst, t - | C.Meta (i,(_,lc)) as t -> - let len = match lc with C.Irl len->len | C.Ctx l->List.length l in - prerr_endline "RESTRICT"; - let metasenv, subst, _ = - NCicMetaSubst.restrict metasenv subst i (HExtlib.list_seq 1 len) - in - metasenv, subst, t - | C.Sort _ -> metasenv, subst, t - | _ -> assert false -;; - -let sort_of_prod - localise metasenv subst context orig_s orig_t (name,s) t (t1, t2) -= - let metasenv, subst, t1 = force_to_sort metasenv subst context t1 in - let metasenv, subst, t2 = - force_to_sort metasenv subst ((name,C.Decl s)::context) t2 in - prerr_endline ("S1:"^NCicPp.ppterm ~metasenv ~subst ~context t1); - prerr_endline ("S2:"^NCicPp.ppterm ~metasenv ~subst ~context:((name,C.Decl s)::context) t2); - match t1, t2 with - | C.Sort _, C.Sort C.Prop -> metasenv, subst, t2 - | C.Sort (C.Type u1), C.Sort (C.Type u2) -> - metasenv, subst, C.Sort (C.Type (u1@u2)) - | C.Sort C.Prop,C.Sort (C.Type _) -> metasenv, subst, t2 - | C.Meta _, C.Sort _ - | C.Meta _, C.Meta _ - | C.Sort _, C.Meta _ -> metasenv, subst, t2 - | x, (C.Sort _ | C.Meta _) | _, x -> - let y, context, orig = - if x == t1 then s, context, orig_s - else t, ((name,C.Decl s)::context), orig_t - in - raise (RefineFailure (lazy (localise orig,Printf.sprintf - "%s is expected to be a type, but its type is %s that is not a sort" - (NCicPp.ppterm ~subst ~metasenv ~context y) - (NCicPp.ppterm ~subst ~metasenv ~context x)))) -;; let check_allowed_sort_elimination localise r orig = let mkapp he arg = @@ -83,34 +54,34 @@ let check_allowed_sort_elimination localise r orig = | t -> C.Appl [t;arg] in (* ctx, ind_type @ lefts, sort_of_ind_ty@lefts, outsort *) let rec aux metasenv subst context ind arity1 arity2 = + (*D*)inside 'S'; try let rc = let arity1 = NCicReduction.whd ~subst context arity1 in + pp (lazy(NCicPp.ppterm ~subst ~metasenv ~context arity1 ^ " elimsto " ^ + NCicPp.ppterm ~subst ~metasenv ~context arity2 ^ "\nMENV:\n"^ + NCicPp.ppmetasenv ~subst metasenv)); match arity1 with | C.Prod (name,so1,de1) (* , t ==?== C.Prod _ *) -> let metasenv, meta, _ = - NCicMetaSubst.mk_meta metasenv ((name,C.Decl so1)::context) `Typeless + NCicMetaSubst.mk_meta metasenv ((name,C.Decl so1)::context) `Type in let metasenv, subst = try NCicUnification.unify metasenv subst context - (C.Prod (name, so1, meta)) arity2 + arity2 (C.Prod (name, so1, meta)) with exc -> raise (wrap_exc (lazy (localise orig, Printf.sprintf "expected %s, found %s" (* XXX localizzare meglio *) - (NCicPp.ppterm ~subst ~metasenv ~context arity1) + (NCicPp.ppterm ~subst ~metasenv ~context (C.Prod (name, so1, meta))) (NCicPp.ppterm ~subst ~metasenv ~context arity2))) exc) in aux metasenv subst ((name, C.Decl so1)::context) (mkapp (NCicSubstitution.lift 1 ind) (C.Rel 1)) de1 meta | C.Sort _ (* , t ==?== C.Prod _ *) -> - let metasenv, meta, _ = NCicMetaSubst.mk_meta metasenv [] `Typeless in - prerr_endline ( - (NCicPp.ppterm ~subst ~metasenv ~context (C.Prod ("_", ind, meta))) ^ " ==== " ^ - (NCicPp.ppterm ~subst ~metasenv ~context arity2) ^ "\nMENV:\n" - ^ NCicPp.ppmetasenv ~subst metasenv); + let metasenv, meta, _ = NCicMetaSubst.mk_meta metasenv [] `Type in let metasenv, subst = try NCicUnification.unify metasenv subst context - (C.Prod ("_", ind, meta)) arity2 + arity2 (C.Prod ("_", ind, meta)) with exc -> raise (wrap_exc (lazy (localise orig, Printf.sprintf "expected %s, found %s" (* XXX localizzare meglio *) - (NCicPp.ppterm ~subst ~metasenv ~context arity1) + (NCicPp.ppterm ~subst ~metasenv ~context (C.Prod ("_", ind, meta))) (NCicPp.ppterm ~subst ~metasenv ~context arity2))) exc) in (try NCicTypeChecker.check_allowed_sort_elimination @@ -119,37 +90,42 @@ let check_allowed_sort_elimination localise r orig = with exc -> raise (wrap_exc (lazy (localise orig, "Sort elimination not allowed ")) exc)) | _ -> assert false + (*D*)in outside(); rc with exc -> outside (); raise exc in aux ;; let rec typeof - ?(localise=fun _ -> Stdpp.dummy_loc) metasenv subst context term expty + ?(localise=fun _ -> Stdpp.dummy_loc) + ~look_for_coercion metasenv subst context term expty = - let force_ty metasenv subst context orig t infty = function + let force_ty metasenv subst context orig t infty expty = + (*D*)inside 'F'; try let rc = + match expty with | Some expty -> (match t with | C.Implicit _ | C.Lambda _ -> metasenv, subst, t, expty | _ -> - prerr_endline ("F:" ^ + pp (lazy ( (NCicPp.ppterm ~metasenv ~subst ~context infty) ^ " === " ^ - (NCicPp.ppterm ~metasenv ~subst ~context expty) ^ "\nMENV:\n" ^ - NCicPp.ppmetasenv ~subst metasenv); - let metasenv, subst = - try NCicUnification.unify metasenv subst context infty expty - with exc -> raise (wrap_exc (lazy (localise orig, Printf.sprintf - "The term %s has type %s but is here used with type %s" - (NCicPp.ppterm ~metasenv ~subst ~context t) - (NCicPp.ppterm ~metasenv ~subst ~context infty) - (NCicPp.ppterm ~metasenv ~subst ~context expty))) exc) - in - metasenv, subst, t, expty) + (NCicPp.ppterm ~metasenv ~subst ~context expty))); + try + let metasenv, subst = + NCicUnification.unify metasenv subst context infty expty + in + metasenv, subst, t, expty + with exc -> + try_coercions ~look_for_coercion ~localise + metasenv subst context t orig infty expty true exc) | None -> metasenv, subst, t, infty + (*D*)in outside(); rc with exc -> outside (); raise exc in let rec typeof_aux metasenv subst context expty = fun t as orig -> - prerr_endline ("R:"^NCicPp.ppterm ~metasenv ~subst ~context t); + (*D*)inside 'R'; try let rc = + pp (lazy (NCicPp.ppterm ~metasenv ~subst ~context t)); + pp (lazy (NCicPp.ppmetasenv ~subst metasenv)); let metasenv, subst, t, infty = match t with | C.Rel n -> @@ -184,15 +160,15 @@ let rec typeof metasenv, subst, t, NCicSubstitution.subst_meta l ty | C.Const _ -> metasenv, subst, t, NCicTypeChecker.typeof ~subst ~metasenv context t - | C.Prod (name,(s as orig_s),(t as orig_t)) as orig -> + | C.Prod (name,(s as orig_s),(t as orig_t)) -> let metasenv, subst, s, s1 = typeof_aux metasenv subst context None s in - let context = (name,(C.Decl s))::context in - let metasenv, subst, t, s2 = typeof_aux metasenv subst context None t in - let metasenv, subst, ty = - sort_of_prod localise metasenv subst + let context1 = (name,(C.Decl s))::context in + let metasenv, subst, t, s2 = typeof_aux metasenv subst context1 None t in + let metasenv, subst, s, t, ty = + sort_of_prod ~look_for_coercion localise metasenv subst context orig_s orig_t (name,s) t (s1,s2) in - metasenv, subst, orig, ty + metasenv, subst, NCic.Prod(name,s,t), ty | C.Lambda (n,(s as orig_s),t) -> let exp_s, exp_ty_t = match expty with @@ -200,11 +176,13 @@ let rec typeof | Some expty -> match NCicReduction.whd ~subst context expty with | C.Prod (_,s,t) -> Some s, Some t - | _ -> None, None + | _ -> None, None (** XXX FUNCLASS |-> QUALCOSA *) in let metasenv, subst, s, ty_s = typeof_aux metasenv subst context None s in - let metasenv, subst, _ = force_to_sort metasenv subst context ty_s in + let metasenv, subst, s, _ = + force_to_sort ~look_for_coercion + metasenv subst context s orig_s localise ty_s in let (metasenv,subst), exp_ty_t = match exp_s with | Some exp_s -> @@ -215,28 +193,30 @@ let rec typeof exp_s))) exc)) | None -> (metasenv, subst), None in - (* XXX coerce_to_sort s *) let context = (n,C.Decl s) :: context in let metasenv, subst, t, ty_t = typeof_aux metasenv subst context exp_ty_t t in metasenv, subst, C.Lambda(n,s,t), C.Prod (n,s,ty_t) - | C.LetIn (n,ty,t,bo) -> + | C.LetIn (n,(ty as orig_ty),t,bo) -> let metasenv, subst, ty, ty_ty = typeof_aux metasenv subst context None ty in - let metasenv, subst, _ = force_to_sort metasenv subst context ty_ty in + let metasenv, subst, ty, _ = + force_to_sort ~look_for_coercion + metasenv subst context ty orig_ty localise ty_ty in let metasenv, subst, t, _ = typeof_aux metasenv subst context (Some ty) t in - let context = (n, C.Def (t,ty)) :: context in + let context1 = (n, C.Def (t,ty)) :: context in let metasenv, subst, bo, bo_ty = - typeof_aux metasenv subst context expty bo + typeof_aux metasenv subst context1 None bo in - metasenv, subst, C.LetIn (n, ty, t, bo), - NCicSubstitution.subst ~avoid_beta_redexes:true t bo_ty + 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 metasenv, subst, he, ty_he = typeof_aux metasenv subst context None he in - eat_prods localise metasenv subst context orig_he he ty_he args + eat_prods ~localise ~look_for_coercion + metasenv subst context orig_he he ty_he args | C.Appl _ -> raise (AssertFailure (lazy "Appl of length < 2")) | C.Match (Ref.Ref (_,Ref.Ind (_,tyno,_)) as r, outtype,(term as orig_term),pl) as orig -> @@ -244,7 +224,7 @@ let rec typeof let _, _, arity, cl = List.nth itl tyno in let constructorsno = List.length cl in let _, metasenv, args = - NCicMetaSubst.saturate metasenv context arity 0 in + NCicMetaSubst.saturate metasenv subst context arity 0 in let ind = if args = [] then C.Const r else C.Appl (C.Const r::args) in let metasenv, subst, term, _ = typeof_aux metasenv subst context (Some ind) term in @@ -278,6 +258,9 @@ let rec typeof let ty_branch = NCicTypeChecker.type_of_branch ~subst context leftno outtype cons ty_cons in + pp (lazy ("TYPEOFBRANCH: " ^ + NCicPp.ppterm ~metasenv ~subst ~context p ^ " ::: " ^ + NCicPp.ppterm ~metasenv ~subst ~context ty_branch )); let metasenv, subst, p, _ = typeof_aux metasenv subst context (Some ty_branch) p in j+1, metasenv, subst, p :: branches) @@ -286,46 +269,165 @@ let rec typeof metasenv, subst, C.Match (r, outtype, term, List.rev pl_rev), NCicReduction.head_beta_reduce (C.Appl (outtype::arguments@[term])) - | C.Match _ -> assert false + | C.Match _ as orig -> + prerr_endline (NCicPp.ppterm ~metasenv ~subst ~context orig); + assert false in + pp (lazy (NCicPp.ppterm ~metasenv ~subst ~context t ^ " :: "^ + NCicPp.ppterm ~metasenv ~subst ~context infty )); force_ty metasenv subst context orig t infty expty + (*D*)in outside(); rc with exc -> outside (); raise exc in typeof_aux metasenv subst context expty term -and eat_prods localise metasenv subst context orig_he he ty_he args = - let rec aux metasenv subst args_so_far ty_he = function - | [] -> metasenv, subst, NCic.Appl (he :: List.rev args_so_far), ty_he +and try_coercions + ~localise ~look_for_coercion + metasenv subst context t orig_t infty expty perform_unification exc += + (* we try with a coercion *) + let rec first exc = function + | [] -> + raise (wrap_exc (lazy (localise orig_t, Printf.sprintf + "The term %s has type %s but is here used with type %s" + (NCicPp.ppterm ~metasenv ~subst ~context t) + (NCicPp.ppterm ~metasenv ~subst ~context infty) + (NCicPp.ppterm ~metasenv ~subst ~context expty))) exc) + | (metasenv, newterm, newtype, meta)::tl -> + try + let metasenv, subst = + NCicUnification.unify metasenv subst context meta t + in + let metasenv, subst = + if perform_unification then + NCicUnification.unify metasenv subst context newtype expty + else metasenv, subst + in + metasenv, subst, newterm, newtype + with + | NCicUnification.UnificationFailure _ -> first exc tl + | NCicUnification.Uncertain _ as exc -> first exc tl + in + first exc + (look_for_coercion metasenv subst context infty expty) + +and force_to_sort + ~look_for_coercion metasenv subst context t orig_t localise ty += + match NCicReduction.whd ~subst context ty with + | C.Meta (_,(0,(C.Irl 0 | C.Ctx []))) as ty -> + metasenv, subst, t, ty + | C.Meta (i,(_,(C.Irl 0 | C.Ctx []))) -> + metasenv, subst, t, C.Meta(i,(0,C.Irl 0)) + | C.Meta (i,(_,lc)) -> + let len = match lc with C.Irl len->len | C.Ctx l->List.length l in + let metasenv, subst, newmeta = + if len > 0 then + NCicMetaSubst.restrict metasenv subst i (HExtlib.list_seq 1 (len+1)) + else metasenv, subst, i + in + metasenv, subst, t, C.Meta (newmeta,(0,C.Irl 0)) + | C.Sort _ as ty -> metasenv, subst, t, ty + | ty -> + try_coercions ~localise ~look_for_coercion metasenv subst context + t orig_t ty (NCic.Sort (NCic.Type NCicEnvironment.type0)) false + (RefineFailure (lazy (localise orig_t, + "The type of " ^ NCicPp.ppterm ~metasenv ~subst ~context t + ^ " is not a sort: " ^ NCicPp.ppterm ~metasenv ~subst ~context ty))) + +and sort_of_prod ~look_for_coercion + localise metasenv subst context orig_s orig_t (name,s) t (t1, t2) += + let metasenv, subst, s, t1 = + force_to_sort + ~look_for_coercion metasenv subst context s orig_s localise t1 in + let metasenv, subst, t, t2 = + force_to_sort ~look_for_coercion metasenv subst ((name,C.Decl s)::context) + t orig_t localise t2 in + match t1, t2 with + | C.Sort _, C.Sort C.Prop -> metasenv, subst, s, t, t2 + | C.Sort (C.Type u1), C.Sort (C.Type u2) -> + metasenv, subst, s, t, C.Sort (C.Type (u1@u2)) + | C.Sort C.Prop,C.Sort (C.Type _) -> metasenv, subst, s, t, t2 + | C.Meta _, C.Sort _ + | C.Meta _, C.Meta (_,(_,_)) + | C.Sort _, C.Meta (_,(_,_)) -> metasenv, subst, s, t, t2 + | x, (C.Sort _ | C.Meta _) | _, x -> + let y, context, orig = + if x == t1 then s, context, orig_s + else t, ((name,C.Decl s)::context), orig_t + in + raise (RefineFailure (lazy (localise orig,Printf.sprintf + "%s is expected to be a type, but its type is %s that is not a sort" + (NCicPp.ppterm ~subst ~metasenv ~context y) + (NCicPp.ppterm ~subst ~metasenv ~context x)))) + +and eat_prods + ~localise ~look_for_coercion metasenv subst context orig_he he ty_he args += + (*D*)inside 'E'; try let rc = + 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 | arg::tl -> match NCicReduction.whd ~subst context ty_he with | C.Prod (_,s,t) -> let metasenv, subst, arg, _ = - typeof ~localise metasenv subst context arg (Some s) in + typeof ~look_for_coercion ~localise + metasenv subst context arg (Some s) in let t = NCicSubstitution.subst ~avoid_beta_redexes:true arg t in - aux metasenv subst (arg :: args_so_far) t tl - | t -> + aux metasenv subst (arg :: args_so_far) he t tl + | C.Meta _ + | C.Appl (C.Meta _ :: _) as t -> let metasenv, subst, arg, ty_arg = - typeof ~localise metasenv subst context arg None in + typeof ~look_for_coercion ~localise + metasenv subst context arg None in let metasenv, meta, _ = NCicMetaSubst.mk_meta metasenv (("_",C.Decl ty_arg) :: context) `Type in let flex_prod = C.Prod ("_", ty_arg, meta) in - prerr_endline ("F:" ^ - (NCicPp.ppterm ~metasenv ~subst ~context t) ^ " === " ^ - (NCicPp.ppterm ~metasenv ~subst ~context flex_prod) ^ "\nMENV:\n" ^ - NCicPp.ppmetasenv ~subst metasenv ^ "\nCTX:\n" ^ - NCicPp.ppcontext ~metasenv ~subst context); + (* next line grants that ty_args is a type *) + let metasenv,subst, flex_prod, _ = + typeof ~look_for_coercion ~localise metasenv subst + context flex_prod None in + pp (lazy ( "UNIFICATION in CTX:\n"^ + NCicPp.ppcontext ~metasenv ~subst context + ^ "\nOF: " ^ + NCicPp.ppterm ~metasenv ~subst ~context t ^ " === " ^ + NCicPp.ppterm ~metasenv ~subst ~context flex_prod ^ "\n")); let metasenv, subst = try NCicUnification.unify metasenv subst context t flex_prod with exc -> raise (wrap_exc (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))) exc) + ("The term %s has an inferred type %s, but is applied to the" ^^ + " argument %s of type %s") + (NCicPp.ppterm ~metasenv ~subst ~context he) + (NCicPp.ppterm ~metasenv ~subst ~context t) + (NCicPp.ppterm ~metasenv ~subst ~context arg) + (NCicPp.ppterm ~metasenv ~subst ~context ty_arg))) exc) (* XXX coerce to funclass *) in let meta = NCicSubstitution.subst ~avoid_beta_redexes:true arg meta in - aux metasenv subst (arg :: args_so_far) meta tl + aux metasenv subst (arg :: args_so_far) he meta tl + | C.Match (_,_,C.Meta _,_) + | C.Match (_,_,C.Appl (C.Meta _ :: _),_) + | C.Appl (C.Const (NReference.Ref (_, NReference.Fix _)) :: _) -> + 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 = + try_coercions ~localise ~look_for_coercion metasenv subst context + (NCicUntrusted.mk_appl he (List.rev args_so_far)) orig_he ty + (NCic.Prod ("_",NCic.Implicit `Term,NCic.Implicit `Term)) + false + (RefineFailure (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)))) + in + aux metasenv subst [] newhead newheadty (arg :: tl) in - aux metasenv subst [] ty_he args + aux metasenv subst [] he ty_he args + (*D*)in outside(); rc with exc -> outside (); raise exc ;; (* vim:set foldmethod=marker: *)