X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Fsoftware%2Fcomponents%2Fng_refiner%2FnCicUnification.ml;h=e56832fd502656a764891b6ce4da49ebd065a3e5;hb=7110ed13ffccb214bc3aafe37f6a7c24f59a49e5;hp=dff242970c690f1465b4d39094aaac4ef1906a99;hpb=8b1a49bbee9eea86eb74c040defe701370ca5893;p=helm.git diff --git a/helm/software/components/ng_refiner/nCicUnification.ml b/helm/software/components/ng_refiner/nCicUnification.ml index dff242970..e56832fd5 100644 --- a/helm/software/components/ng_refiner/nCicUnification.ml +++ b/helm/software/components/ng_refiner/nCicUnification.ml @@ -15,11 +15,6 @@ exception UnificationFailure of string Lazy.t;; exception Uncertain of string Lazy.t;; exception AssertFailure of string Lazy.t;; -let refiner_typeof = - ref (fun _ ?localise _ _ _ _ _ -> ignore localise; assert false);; -let set_refiner_typeof f = refiner_typeof := f -;; - let (===) x y = Pervasives.compare x y = 0 ;; let uncert_exc metasenv subst context t1 t2 = @@ -83,21 +78,27 @@ let eta_reduce subst t = module C = NCic;; module Ref = NReference;; +let debug = false;; let indent = ref "";; -let inside c = indent := !indent ^ String.make 1 c;; -let outside () = +let pp = + if debug then + fun s -> prerr_endline (Printf.sprintf "%-20s" !indent ^ " " ^ Lazy.force s) + else + fun _ -> () +;; +let inside c = + indent := !indent ^ String.make 1 c; + if debug then prerr_endline ("{{{" ^ !indent ^ " ") +;; +let outside ok = + if debug then prerr_endline "}}}"; + if not ok then pp (lazy "exception raised!"); try indent := String.sub !indent 0 (String.length !indent -1) with Invalid_argument _ -> indent := "??"; () ;; -let pp s = - prerr_endline (Printf.sprintf "%-20s" !indent ^ " " ^ Lazy.force s) -;; - -let pp _ = ();; - let ppcontext ~metasenv ~subst c = "\nctx:\n"^ NCicPp.ppcontext ~metasenv ~subst c ;; @@ -129,7 +130,7 @@ let fix_sorts swap exc t = let is_locked n subst = try match NCicUtils.lookup_subst n subst with - | Some tag, _,_,_ when NCicMetaSubst.is_out_scope_tag tag -> true + | tag, _,_,_ when NCicMetaSubst.is_out_scope_tag tag -> true | _ -> false with NCicUtils.Subst_not_found _ -> false ;; @@ -140,6 +141,18 @@ let rec mk_irl = | n -> NCic.Rel n :: mk_irl (n-1) ;; +(* the argument must be a term in whd *) +let rec could_reduce = + function + | C.Meta _ -> true + | C.Appl (C.Const (Ref.Ref (_,Ref.Fix (_,recno,_)))::args) + when List.length args > recno -> could_reduce (List.nth args recno) + | C.Match (_,_,arg,_) -> could_reduce arg + | C.Appl (he::_) -> could_reduce he + | C.Sort _ | C.Rel _ | C.Prod _ | C.Lambda _ | C.Const _ -> false + | C.Appl [] | C.LetIn _ | C.Implicit _ -> assert false +;; + let rec lambda_intros rdb metasenv subst context t args = let tty = NCicTypeChecker.typeof ~metasenv ~subst context t in let argsty = @@ -154,11 +167,16 @@ let rec lambda_intros rdb metasenv subst context t args = in metasenv, subst, bo | (arg,ty)::tail -> + pp(lazy("arg{ " ^ + NCicPp.ppterm ~metasenv ~subst ~context:context_of_args arg ^ ":" ^ + NCicPp.ppterm ~metasenv ~subst ~context:context_of_args ty)); let metasenv, subst, telescopic_ty = -(* XXX if processed_args = [] then metasenv, subst, ty else *) + if processed_args = [] then metasenv, subst, ty else + let _ = pp(lazy("delift")) in delift_type_wrt_terms rdb metasenv subst context_of_args ty (List.rev processed_args) in + pp(lazy("arg}")); let name = "HBeta"^string_of_int n in let metasenv, subst, bo = mk_lambda metasenv subst ((name,NCic.Decl telescopic_ty)::context) (n+1) @@ -166,7 +184,12 @@ let rec lambda_intros rdb metasenv subst context t args = in metasenv, subst, NCic.Lambda (name, telescopic_ty, bo) in + pp(lazy("LAMBDA_INTROS{ " ^ + NCicPp.ppterm ~metasenv ~subst ~context t ^ ":" ^ + NCicPp.ppterm ~metasenv ~subst ~context tty ^ " over " ^ + String.concat "," (List.map (NCicPp.ppterm ~metasenv ~subst ~context)args))); let rc = mk_lambda metasenv subst context 0 [] argsty in + pp(lazy("LAMBDA_INTROS}")); rc and instantiate rdb test_eq_only metasenv subst context n lc t swap = @@ -177,64 +200,106 @@ and instantiate rdb test_eq_only metasenv subst context n lc t swap = if swap then unify rdb test_eq_only m s c t2 t1 else unify rdb test_eq_only m s c t1 t2 in - let name, ctx, ty = NCicUtils.lookup_meta n metasenv in + let has_tag = List.exists in + let tags, _, ty = NCicUtils.lookup_meta n metasenv in + (* on the types *) let metasenv, subst, t = match ty with | NCic.Implicit (`Typeof _) -> - metasenv,subst, t - (* fix_sorts swap metasenv subst context (NCic.Meta(n,lc)) t *) + pp(lazy("meta with no type")); + assert(has_tag ((=)`IsSort) tags); + metasenv, subst, t | _ -> - pp (lazy ( - "typeof: " ^ NCicPp.ppterm ~metasenv ~subst ~context t ^ - ppcontext ~metasenv ~subst context ^ - ppmetasenv ~subst metasenv)); let exc_to_be = fail_exc metasenv subst context (NCic.Meta (n,lc)) t in let t, ty_t = try t, NCicTypeChecker.typeof ~subst ~metasenv context t with - | NCicTypeChecker.AssertFailure msg -> - (pp (lazy "fine typeof (fallimento)"); - let ft = fix_sorts swap exc_to_be t in - if ft == t then - (prerr_endline ( ("ILLTYPED: " ^ - NCicPp.ppterm ~metasenv ~subst ~context t - ^ "\nBECAUSE:" ^ Lazy.force msg ^ - ppcontext ~metasenv ~subst context ^ - ppmetasenv ~subst metasenv - )); - assert false) - else - try - pp (lazy ("typeof: " ^ - NCicPp.ppterm ~metasenv ~subst ~context ft)); - ft, NCicTypeChecker.typeof ~subst ~metasenv context ft - with NCicTypeChecker.AssertFailure _ -> - assert false) + | NCicTypeChecker.AssertFailure msg as exn -> + pp(lazy("we try to fix the sort\n"^ + Lazy.force msg^"\n"^NCicPp.ppmetasenv ~subst metasenv)); + let ft = fix_sorts swap exc_to_be t in + pp(lazy("unable to fix the sort")); + if ft == t then raise exn; + (try ft, NCicTypeChecker.typeof ~subst ~metasenv context ft + with NCicTypeChecker.AssertFailure _ -> raise exn) | NCicTypeChecker.TypeCheckerFailure msg -> prerr_endline (Lazy.force msg); - pp msg; assert false + prerr_endline (NCicPp.ppterm ~metasenv ~subst ~context t); + prerr_endline (ppcontext ~metasenv ~subst context); + prerr_endline (ppmetasenv ~subst metasenv); + assert false in - let lty = NCicSubstitution.subst_meta lc ty in match ty_t with - | NCic.Implicit _ -> - raise (UnificationFailure - (lazy "trying to unify a term with a type")) - | ty_t -> + | NCic.Implicit (`Typeof _) -> + raise (UnificationFailure(lazy "trying to unify a term with a type")) + | _ -> + let lty = NCicSubstitution.subst_meta lc ty in pp (lazy ("On the types: " ^ - NCicPp.ppterm ~metasenv ~subst ~context:ctx ty ^ " ~~~ " ^ - NCicPp.ppterm ~metasenv ~subst ~context lty ^ " === " - ^ NCicPp.ppterm ~metasenv ~subst ~context ty_t)); + NCicPp.ppterm ~metasenv ~subst ~context lty ^ " === " ^ + NCicPp.ppterm ~metasenv ~subst ~context ty_t)); let metasenv,subst = - try - unify test_eq_only metasenv subst context lty ty_t + try unify test_eq_only metasenv subst context lty ty_t with NCicEnvironment.BadConstraint _ as exc -> let ty_t = fix_sorts swap exc_to_be ty_t in try unify test_eq_only metasenv subst context lty ty_t - with _ -> raise exc in - metasenv, subst, t + with + | NCicEnvironment.BadConstraint _ + | UnificationFailure _ -> raise exc + in + metasenv, subst, t + in + (* viral sortification *) + let is_sort metasenv subst context t = + match NCicReduction.whd ~subst context t with + | NCic.Meta (i,_) -> + let tags, _, _ = NCicUtils.lookup_meta i metasenv in + has_tag ((=) `IsSort) tags + | NCic.Sort _ -> true + | _ -> false in - pp (lazy(string_of_int n ^ " := 111 = "^ - NCicPp.ppterm ~metasenv ~subst ~context t)); + let rec sortify metasenv subst = function + | NCic.Implicit (`Typeof _) -> assert false + | NCic.Sort _ as t -> metasenv, subst, t, 0 + | NCic.Meta (i,_) as t -> + let tags, context, ty = NCicUtils.lookup_meta i metasenv in + if has_tag ((=) `IsSort) tags then metasenv, subst, t, i + else + let ty = NCicReduction.whd ~subst context ty in + let metasenv, subst, ty, _ = sortify metasenv subst ty in + let metasenv, j, m, _ = + NCicMetaSubst.mk_meta metasenv ~attrs:[`IsSort] [] (`WithType ty) + in + pp(lazy("rimpiazzo " ^ string_of_int i^" con "^string_of_int j)); + let subst_entry = i, (tags, context, m, ty) in + let subst = subst_entry :: subst in + let metasenv = List.filter (fun x,_ -> i <> x) metasenv in + metasenv, subst, m, j + | t -> + if could_reduce t then raise (Uncertain(lazy "not a sort")) + else raise (UnificationFailure(lazy "not a sort")) + in + let metasenv, subst, _, n = + if has_tag ((=) `IsSort) tags then + let m,s,x,_ = sortify metasenv subst (NCicReduction.whd ~subst context t) + in m,s,x,n + else if is_sort metasenv subst context t then + sortify metasenv subst (NCic.Meta (n,lc)) + else + metasenv, subst, NCic.Rel ~-1,n + in + let tags, ctx, ty = NCicUtils.lookup_meta n metasenv in + (* instantiation *) + + (* sortification: + - Meta sort === t -> check t is sort or sortify + - add tag `IsSort and set cc=[] to n and its pile + - se gli ancestor non sono sorte o meta... bum... + - cambiare in-place menv + - geneare meta fresh sorta e dall'alto al basso + - Meta _ === Meta sort -> sortify n (i.e. add `IsSort) + *) + pp (lazy(string_of_int n ^ " := 111 = "^ + NCicPp.ppterm ~metasenv ~subst ~context t)); let (metasenv, subst), t = try NCicMetaSubst.delift @@ -266,14 +331,14 @@ and instantiate rdb test_eq_only metasenv subst context n lc t swap = with NCicUtils.Subst_not_found _ -> (* by cumulativity when unify(?,Type_i) * we could ? := Type_j with j <= i... *) - let subst = (n, (name, ctx, t, ty)) :: subst in + let subst = (n, (tags, ctx, t, ty)) :: subst in pp (lazy ("?"^string_of_int n^" := "^NCicPp.ppterm ~metasenv ~subst ~context (NCicSubstitution.subst_meta lc t))); let metasenv = List.filter (fun (m,_) -> not (n = m)) metasenv in metasenv, subst - (*D*) in outside(); rc with exn -> outside (); raise exn + (*D*) in outside true; rc with exn -> outside false; raise exn and unify rdb test_eq_only metasenv subst context t1 t2 = (*D*) inside 'U'; try let rc = @@ -370,11 +435,8 @@ and unify rdb test_eq_only metasenv subst context t1 t2 = let subst = List.map (fun (i,(tag,ctx,bo,ty)) -> let tag = - match tag with - Some tag when - tag = NCicMetaSubst.in_scope_tag - || NCicMetaSubst.is_out_scope_tag tag -> None - | _ -> tag + List.filter + (function `InScope | `OutScope _ -> false | _ -> true) tag in i,(tag,ctx,bo,ty) ) subst @@ -525,16 +587,16 @@ and unify rdb test_eq_only metasenv subst context t1 t2 = (fun (metasenv,subst) -> unify rdb test_eq_only metasenv subst context) (metasenv, subst) pl1 pl2 - with Invalid_argument _ -> - raise (uncert_exc metasenv subst context t1 t2)) + with Invalid_argument _ -> assert false) | (C.Implicit _, _) | (_, C.Implicit _) -> assert false | _ when NCicUntrusted.metas_of_term subst context t1 = [] && NCicUntrusted.metas_of_term subst context t2 = [] -> raise (fail_exc metasenv subst context t1 t2) | _ -> raise (uncert_exc metasenv subst context t1 t2) - (*D*) in outside(); rc with exn -> outside (); raise exn + (*D*) in outside true; rc with exn -> outside false; raise exn in let try_hints metasenv subst t1 t2 (* exc*) = + (*D*) inside 'H'; try let rc = (* prerr_endline ("\nProblema:\n" ^ NCicPp.ppterm ~metasenv ~subst ~context t1 ^ " =?= " ^ @@ -546,8 +608,7 @@ and unify rdb test_eq_only metasenv subst context t1 t2 = let rec cand_iter = function | [] -> None (* raise exc *) | (metasenv,(c1,c2),premises)::tl -> -(* - prerr_endline ("\nProvo il candidato:\n" ^ + pp (lazy ("\nProvo il candidato:\n" ^ String.concat "\n" (List.map (fun (a,b) -> @@ -555,9 +616,9 @@ and unify rdb test_eq_only metasenv subst context t1 t2 = NCicPp.ppterm ~metasenv ~subst ~context b) premises) ^ "\n-------------------------------------------\n"^ NCicPp.ppterm ~metasenv ~subst ~context c1 ^ " = " ^ - NCicPp.ppterm ~metasenv ~subst ~context c2); -*) + NCicPp.ppterm ~metasenv ~subst ~context c2)); try + (*D*) inside 'K'; try let rc = let metasenv,subst = fo_unif test_eq_only metasenv subst t1 c1 in let metasenv,subst = @@ -569,11 +630,13 @@ and unify rdb test_eq_only metasenv subst context t1 t2 = (metasenv, subst) premises in Some (metasenv, subst) + (*D*) in outside true; rc with exn -> outside false; raise exn with UnificationFailure _ | Uncertain _ -> cand_iter tl in cand_iter candidates + (*D*) in outside true; rc with exn -> outside false; raise exn in let height_of = function | NCic.Const (Ref.Ref (_,Ref.Def h)) @@ -642,7 +705,7 @@ pp (lazy (string_of_bool norm1 ^ " ?? " ^ string_of_bool norm2)); ) (metasenv,subst) todo with UnificationFailure _ | Uncertain _ when not (norm1 && norm2) -> unif_machines metasenv subst (small_delta_step ~subst m1 m2) - (*D*) in outside(); rc with exn -> outside (); raise exn + (*D*) in outside true; rc with exn -> outside false; raise exn in try fo_unif test_eq_only metasenv subst t1 t2 with @@ -663,20 +726,23 @@ pp (lazy (string_of_bool norm1 ^ " ?? " ^ string_of_bool norm2)); with | UnificationFailure _ -> raise (UnificationFailure msg) | Uncertain _ -> raise exn - (*D*) in outside(); rc with exn -> outside (); raise exn + (*D*) in outside true; rc with exn -> outside false; raise exn and delift_type_wrt_terms rdb metasenv subst context t args = - let metasenv, _, instance, _ = - NCicMetaSubst.mk_meta metasenv context `Type in - let meta_applied = NCicUntrusted.mk_appl instance args in - let metasenv,subst,meta_applied,_ = - !refiner_typeof ((rdb:> NRstatus.status)#set_coerc_db NCicCoercion.empty_db) - metasenv subst context meta_applied None + let (metasenv, subst), t = + try + NCicMetaSubst.delift + ~unify:(fun m s c t1 t2 -> + let ind = !indent in + let res = + try Some (unify rdb false m s c t1 t2 ) + with UnificationFailure _ | Uncertain _ -> None + in + indent := ind; res) + metasenv subst context 0 (0,NCic.Ctx (args @ + List.rev (mk_irl (List.length context)))) t + with NCicMetaSubst.MetaSubstFailure _ -> (metasenv, subst), t in - let metasenv, subst = - unify rdb true metasenv subst context meta_applied t in - let t = NCicSubstitution.lift (List.length args) instance in - let t = NCicUntrusted.mk_appl t (mk_irl (List.length args)) in metasenv, subst, t ;;