X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Fsoftware%2Fcomponents%2Fng_refiner%2FnCicUnification.ml;h=cf44ff4708946917e62fd397479caea6af471365;hb=1409a972815b8e4e697d9ad55c77d9292cbea787;hp=c224708533e5c6789606d943ac37fa4d23a609fb;hpb=686f7f4f4444125885bc7ef9e8ec3e0b6f567137;p=helm.git diff --git a/helm/software/components/ng_refiner/nCicUnification.ml b/helm/software/components/ng_refiner/nCicUnification.ml index c22470853..cf44ff470 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 = @@ -95,14 +90,16 @@ let outside () = let pp s = prerr_endline (Printf.sprintf "%-20s" !indent ^ " " ^ Lazy.force s) ;; -let pp _ = ();; +let pp _ = ();; -let ppcontext = NCicPp.ppcontext;; -let ppmetasenv = NCicPp.ppmetasenv;; +let ppcontext ~metasenv ~subst c = + "\nctx:\n"^ NCicPp.ppcontext ~metasenv ~subst c +;; +let ppmetasenv ~subst m = "\nmenv:\n" ^ NCicPp.ppmetasenv ~subst m;; -let ppcontext ~metasenv:_metasenv ~subst:_subst _context = "...";; -let ppmetasenv ~subst:_subst _metasenv = "...";; +let ppcontext ~metasenv:_metasenv ~subst:_subst _context = "";; +let ppmetasenv ~subst:_subst _metasenv = "";; let fix_sorts swap exc t = let rec aux () = function @@ -152,27 +149,30 @@ 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 = + 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,_,instance,_ = - NCicMetaSubst.mk_meta metasenv context_of_args `Term in - let meta_applied = - NCicUntrusted.mk_appl instance (List.rev processed_args) in -let metasenv,subst,_,_ = - !refiner_typeof ((rdb :> NRstatus.status)#set_coerc_db NCicCoercion.empty_db) metasenv subst context_of_args meta_applied None -in - let metasenv,subst = - unify rdb true metasenv subst context_of_args meta_applied ty in - let telescopic_ty = NCicSubstitution.lift n instance in - let telescopic_ty = - NCicUntrusted.mk_appl - telescopic_ty (mk_irl (List.length processed_args)) in let metasenv, subst, bo = mk_lambda metasenv subst ((name,NCic.Decl telescopic_ty)::context) (n+1) (arg::processed_args) tail in metasenv, subst, NCic.Lambda (name, telescopic_ty, bo) in - mk_lambda metasenv subst context 0 [] argsty + 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 = (*D*) inside 'I'; try let rc = @@ -190,8 +190,8 @@ and instantiate rdb test_eq_only metasenv subst context n lc t swap = (* fix_sorts swap metasenv subst context (NCic.Meta(n,lc)) t *) | _ -> pp (lazy ( - "typeof: " ^ NCicPp.ppterm ~metasenv ~subst ~context t ^ "\nctx:\n"^ - ppcontext ~metasenv ~subst context ^ "\nmenv:\n"^ + "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 = @@ -203,8 +203,8 @@ and instantiate rdb test_eq_only metasenv subst context n lc t swap = if ft == t then (prerr_endline ( ("ILLTYPED: " ^ NCicPp.ppterm ~metasenv ~subst ~context t - ^ "\nBECAUSE:" ^ Lazy.force msg ^ "\nCONTEXT:\n" ^ - ppcontext ~metasenv ~subst context ^ "\nMENV:\n" ^ + ^ "\nBECAUSE:" ^ Lazy.force msg ^ + ppcontext ~metasenv ~subst context ^ ppmetasenv ~subst metasenv )); assert false) @@ -217,6 +217,10 @@ and instantiate rdb test_eq_only metasenv subst context n lc t swap = assert false) | NCicTypeChecker.TypeCheckerFailure msg -> prerr_endline (Lazy.force msg); + prerr_endline ( + "typeof: " ^ NCicPp.ppterm ~metasenv ~subst ~context t ^ + ppcontext ~metasenv ~subst context ^ + ppmetasenv ~subst metasenv); pp msg; assert false in let lty = NCicSubstitution.subst_meta lc ty in @@ -260,7 +264,7 @@ and instantiate rdb test_eq_only metasenv subst context n lc t swap = in pp (lazy(string_of_int n ^ " := 222 = "^ NCicPp.ppterm ~metasenv ~subst ~context:ctx t - ^ "\n" ^ ppmetasenv ~subst metasenv)); + ^ ppmetasenv ~subst metasenv)); (* Unifying the types may have already instantiated n. *) try let _, _,oldt,_ = NCicUtils.lookup_subst n subst in @@ -285,7 +289,7 @@ and unify rdb test_eq_only metasenv subst context t1 t2 = let fo_unif test_eq_only metasenv subst t1 t2 = (*D*) inside 'F'; try let rc = pp (lazy(" " ^ NCicPp.ppterm ~metasenv ~subst ~context t1 ^ " ==?== " ^ - NCicPp.ppterm ~metasenv ~subst ~context t2 ^ "\n" ^ ppmetasenv + NCicPp.ppterm ~metasenv ~subst ~context t2 ^ ppmetasenv ~subst metasenv)); if t1 === t2 then metasenv, subst @@ -669,10 +673,28 @@ pp (lazy (string_of_bool norm1 ^ " ?? " ^ string_of_bool norm2)); | UnificationFailure _ -> raise (UnificationFailure msg) | Uncertain _ -> raise exn (*D*) in outside(); rc with exn -> outside (); raise exn + +and delift_type_wrt_terms rdb metasenv subst context t args = + 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 + metasenv, subst, t ;; + let unify rdb ?(test_eq_only=false) = indent := ""; unify rdb test_eq_only;; -let fix_sorts = fix_sorts false (UnificationFailure (lazy "no sup"));; +let fix_sorts = fix_sorts true (UnificationFailure (lazy "no sup"));;