X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Fsoftware%2Fcomponents%2Fng_refiner%2FnCicUnification.ml;h=291dcabdde30c808b88db0c362bc09fbefa1e0b6;hb=7ca0a000878e864c92d94f77900bc2ca0ac143b9;hp=325cd3e5f1e5520365a8bcb90712cd4f84e8c8a2;hpb=23b7119d915c6ff6ba3c89267bd91f7312afe619;p=helm.git diff --git a/helm/software/components/ng_refiner/nCicUnification.ml b/helm/software/components/ng_refiner/nCicUnification.ml index 325cd3e5f..291dcabdd 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,33 +78,43 @@ 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 ppcontext ~metasenv ~subst c = + "\nctx:\n"^ NCicPp.ppcontext ~metasenv ~subst c ;; +let ppmetasenv ~subst m = "\nmenv:\n" ^ NCicPp.ppmetasenv ~subst m;; -let ppcontext = NCicPp.ppcontext;; -let ppmetasenv = NCicPp.ppmetasenv;; - -let ppcontext ~metasenv:_metasenv ~subst:_subst _context = "...";; -let ppmetasenv ~subst:_subst _metasenv = "...";; - -let pp _ = ();; +let ppcontext ~metasenv:_metasenv ~subst:_subst _context = "";; +let ppmetasenv ~subst:_subst _metasenv = "";; let fix_sorts swap exc t = let rec aux () = function | NCic.Sort (NCic.Type u) as orig -> if swap then match NCicEnvironment.sup u with - | None -> prerr_endline "no sup for" ; raise exc + | None -> + prerr_endline ("no sup for " ^ NCicPp.ppterm ~metasenv:[] ~subst:[] ~context:[] orig) ; + raise exc | Some u1 -> if u = u1 then orig else NCic.Sort (NCic.Type u1) else NCic.Sort (NCic.Type ( @@ -136,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 = @@ -150,27 +167,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 = @@ -183,13 +203,43 @@ and instantiate rdb test_eq_only metasenv subst context n lc t swap = let name, ctx, ty = NCicUtils.lookup_meta n metasenv in let metasenv, subst, t = match ty with - | NCic.Implicit (`Typeof _) -> - metasenv,subst, t - (* fix_sorts swap metasenv subst context (NCic.Meta(n,lc)) t *) + | NCic.Implicit (`Typeof _) -> + (match NCicReduction.whd ~subst context t with + NCic.Sort _ -> metasenv,subst,t + | NCic.Meta (i,_) when + let _,_,ty = NCicUtils.lookup_meta i metasenv in + (match ty with + NCic.Implicit (`Typeof _) -> true + | _ -> false) + -> metasenv,subst,t + | NCic.Meta (i,_) -> + let rec remove_and_hope i = + let _,ctx,ty = NCicUtils.lookup_meta i metasenv in + match ty with + NCic.Implicit _ -> List.filter (fun i',_ -> i <> i') metasenv + | _ -> + match NCicReduction.whd ~subst ctx ty with + NCic.Meta (j,_) -> + let metasenv = remove_and_hope j in + List.filter (fun i',_ -> i <> i') metasenv + | _ -> assert false (* NON POSSO RESTRINGERE *) + in + let metasenv = remove_and_hope i in + let metasenv = + (i,(None,[],NCic.Implicit (`Typeof i))):: + List.filter (fun i',_ -> i <> i') metasenv + in + metasenv,subst,t + | NCic.Appl (NCic.Meta _::_) -> + raise (Uncertain (lazy "Trying to instantiate a metavariable that represents a sort with a term")) + | t when could_reduce t -> + raise (Uncertain (lazy "Trying to instantiate a metavariable that represents a sort with a term")) + | _ -> + raise (UnificationFailure (lazy "Trying to instantiate a metavariable that represents a sort with a term"))) | _ -> 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 = @@ -201,8 +251,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) @@ -215,9 +265,12 @@ 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 ty_t = fix_sorts swap exc_to_be ty_t in let lty = NCicSubstitution.subst_meta lc ty in match ty_t with | NCic.Implicit _ -> @@ -229,7 +282,12 @@ and instantiate rdb test_eq_only metasenv subst context n lc t swap = NCicPp.ppterm ~metasenv ~subst ~context lty ^ " === " ^ NCicPp.ppterm ~metasenv ~subst ~context ty_t)); let metasenv,subst = - unify test_eq_only metasenv subst context lty ty_t in + 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 in pp (lazy(string_of_int n ^ " := 111 = "^ @@ -254,7 +312,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 @@ -272,14 +330,14 @@ and instantiate rdb test_eq_only metasenv subst context n lc t swap = 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 = 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 @@ -353,7 +411,9 @@ and unify rdb test_eq_only metasenv subst context t1 t2 = (C.Meta (i,l)) lambda_Mj, i | NCic.Meta (i,_) -> (metasenv, subst), i - | _ -> prerr_endline ("XXX: " ^ NCicPp.ppterm ~metasenv ~subst ~context (NCicReduction.whd ~subst context t1)); assert false + | _ -> + raise (UnificationFailure (lazy "Locked term vs non + flexible term; probably not saturated enough yet!")) in let t1 = NCicReduction.whd ~subst context t1 in let j, lj = @@ -522,16 +582,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 ^ " =?= " ^ @@ -543,8 +603,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) -> @@ -552,9 +611,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 = @@ -566,11 +625,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)) @@ -615,8 +676,8 @@ pp (lazy (string_of_bool norm1 ^ " ?? " ^ string_of_bool norm2)); | _ -> [] *) in let unif_from_stack t1 t2 b metasenv subst = try - let t1 = NCicReduction.from_stack t1 in - let t2 = NCicReduction.from_stack t2 in + let t1 = NCicReduction.from_stack ~delta:max_int t1 in + let t2 = NCicReduction.from_stack ~delta:max_int t2 in unif_machines metasenv subst (put_in_whd t1 t2) with UnificationFailure _ | Uncertain _ when not b -> metasenv, subst @@ -639,7 +700,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 @@ -660,9 +721,29 @@ 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, 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 true (UnificationFailure (lazy "no sup"));;