2 ||M|| This file is part of HELM, an Hypertextual, Electronic
3 ||A|| Library of Mathematics, developed at the Computer Science
4 ||T|| Department, University of Bologna, Italy.
6 ||T|| HELM is free software; you can redistribute it and/or
7 ||A|| modify it under the terms of the GNU General Public License
8 \ / version 2 or (at your option) any later version.
9 \ / This software is distributed as is, NO WARRANTY.
10 V_______________________________________________________________ *)
14 exception UnificationFailure of string Lazy.t;;
15 exception Uncertain of string Lazy.t;;
16 exception AssertFailure of string Lazy.t;;
17 exception KeepReducing of string Lazy.t;;
19 let (===) x y = Pervasives.compare x y = 0 ;;
21 let mk_msg metasenv subst context t1 t2 =
23 "Can't unify " ^ NCicPp.ppterm ~metasenv ~subst ~context t1 ^
24 " with " ^ NCicPp.ppterm ~metasenv ~subst ~context t2))
26 let mk_appl ~upto hd tl =
27 NCicReduction.head_beta_reduce ~upto
29 | NCic.Appl l -> NCic.Appl (l@tl)
30 | _ -> NCic.Appl (hd :: tl))
33 exception WrongShape;;
35 let eta_reduce subst t =
36 let delift_if_not_occur body =
38 Some (NCicSubstitution.psubst ~avoid_beta_redexes:true
39 (fun () -> raise WrongShape) [()] body)
40 with WrongShape -> None
42 let rec eat_lambdas ctx = function
43 | NCic.Lambda (name, src, tgt) ->
44 eat_lambdas ((name, src) :: ctx) tgt
45 | NCic.Meta (i,lc) as t->
47 let _,_,t,_ = NCicUtils.lookup_subst i subst in
48 let t = NCicSubstitution.subst_meta lc t in
50 with Not_found -> ctx, t)
53 let context_body = eat_lambdas [] t in
54 let rec aux = function
56 | (name, src)::ctx, (NCic.Appl (hd::[NCic.Rel 1]) as bo) ->
57 (match delift_if_not_occur hd with
58 | None -> aux (ctx,NCic.Lambda(name,src, bo))
59 | Some bo -> aux (ctx,bo))
60 | (name, src)::ctx, (NCic.Appl args as bo)
61 when HExtlib.list_last args = NCic.Rel 1 ->
62 let args, _ = HExtlib.split_nth (List.length args - 1) args in
63 (match delift_if_not_occur (NCic.Appl args) with
64 | None -> aux (ctx,NCic.Lambda(name,src, bo))
65 | Some bo -> aux (ctx,bo))
66 | (name, src) :: ctx, t ->
67 aux (ctx,NCic.Lambda(name,src, t))
73 module Ref = NReference;;
75 let debug = ref false;;
79 prerr_endline (Printf.sprintf "%-20s" !indent ^ " " ^ Lazy.force s)
84 indent := !indent ^ String.make 1 c;
85 if !debug then prerr_endline ("{{{" ^ !indent ^ " ")
88 if !debug then prerr_endline "}}}";
89 if not ok then pp (lazy "exception raised!");
91 indent := String.sub !indent 0 (String.length !indent -1)
93 Invalid_argument _ -> indent := "??"; ()
96 let ppcontext ~metasenv ~subst c =
97 "\nctx:\n"^ NCicPp.ppcontext ~metasenv ~subst c
99 let ppmetasenv ~subst m = "\nmenv:\n" ^ NCicPp.ppmetasenv ~subst m;;
101 let ppcontext ~metasenv:_metasenv ~subst:_subst _context = "";;
102 let ppmetasenv ~subst:_subst _metasenv = "";;
104 let fix_sorts swap exc t =
105 let rec aux () = function
106 | NCic.Sort (NCic.Type u) as orig ->
108 match NCicEnvironment.sup u with
110 prerr_endline ("no sup for " ^ NCicPp.ppterm ~metasenv:[] ~subst:[] ~context:[] orig) ;
112 | Some u1 -> if u = u1 then orig else NCic.Sort (NCic.Type u1)
114 NCic.Sort (NCic.Type (
115 match NCicEnvironment.sup NCicEnvironment.type0 with
117 | _ -> assert false))
118 | NCic.Meta _ as orig -> orig
119 | t -> NCicUtils.map (fun _ _ -> ()) () aux t
124 let is_locked n subst =
126 match NCicUtils.lookup_subst n subst with
127 | tag, _,_,_ when NCicMetaSubst.is_out_scope_tag tag -> true
129 with NCicUtils.Subst_not_found _ -> false
132 let rec mk_irl stop base =
133 if base > stop then []
134 else (NCic.Rel base) :: mk_irl stop (base+1)
137 (* the argument must be a term in whd *)
138 let rec could_reduce =
141 | C.Appl (C.Const (Ref.Ref (_,Ref.Fix (_,recno,_)))::args)
142 when List.length args > recno -> could_reduce (List.nth args recno)
143 | C.Match (_,_,arg,_) -> could_reduce arg
144 | C.Appl (he::_) -> could_reduce he
145 | C.Sort _ | C.Rel _ | C.Prod _ | C.Lambda _ | C.Const _ -> false
146 | C.Appl [] | C.LetIn _ | C.Implicit _ -> assert false
149 let rec lambda_intros rdb metasenv subst context t args =
150 let tty = NCicTypeChecker.typeof ~metasenv ~subst context t in
153 (fun arg -> arg, NCicTypeChecker.typeof ~metasenv ~subst context arg) args in
154 let context_of_args = context in
155 let rec mk_lambda metasenv subst context n processed_args = function
157 let metasenv, _, bo, _ =
158 NCicMetaSubst.mk_meta metasenv context
159 (`WithType (NCicSubstitution.lift n tty))
164 NCicPp.ppterm ~metasenv ~subst ~context:context_of_args arg ^ " : " ^
165 NCicPp.ppterm ~metasenv ~subst ~context:context_of_args ty));
166 let metasenv, subst, telescopic_ty =
167 if processed_args = [] then metasenv, subst, ty else
168 let _ = pp(lazy("delift")) in
169 delift_type_wrt_terms rdb metasenv subst context
170 (NCicSubstitution.lift n ty)
171 (List.map (NCicSubstitution.lift n) (List.rev processed_args))
173 pp(lazy("arg} "^NCicPp.ppterm ~metasenv ~subst ~context telescopic_ty));
174 let name = "HBeta"^string_of_int n in
175 let metasenv, subst, bo =
176 mk_lambda metasenv subst ((name,NCic.Decl telescopic_ty)::context) (n+1)
177 (arg::processed_args) tail
179 metasenv, subst, NCic.Lambda (name, telescopic_ty, bo)
181 pp(lazy("LAMBDA_INTROS{ " ^
182 NCicPp.ppterm ~metasenv ~subst ~context t ^ ":" ^
183 NCicPp.ppterm ~metasenv ~subst ~context tty ^ " over " ^
184 String.concat "," (List.map (NCicPp.ppterm ~metasenv ~subst ~context)args)));
185 let rc = mk_lambda metasenv subst context 0 [] argsty in
186 pp(lazy("LAMBDA_INTROS}"));
189 and instantiate rdb test_eq_only metasenv subst context n lc t swap =
190 (*D*) inside 'I'; try let rc =
191 pp (lazy(string_of_int n ^ " :=?= "^
192 NCicPp.ppterm ~metasenv ~subst ~context t));
193 let unify test_eq_only m s c t1 t2 =
194 if swap then unify rdb test_eq_only m s c t2 t1
195 else unify rdb test_eq_only m s c t1 t2
197 let has_tag = List.exists in
198 let tags, _, ty = NCicUtils.lookup_meta n metasenv in
200 let metasenv, subst, t =
202 | NCic.Implicit (`Typeof _) ->
203 pp(lazy("meta with no type"));
204 assert(has_tag ((=)`IsSort) tags);
208 UnificationFailure (mk_msg metasenv subst context (NCic.Meta (n,lc)) t)
211 try t, NCicTypeChecker.typeof ~subst ~metasenv context t
213 | NCicTypeChecker.AssertFailure msg as exn ->
214 pp(lazy("we try to fix the sort\n"^
215 Lazy.force msg^"\n"^NCicPp.ppmetasenv ~subst metasenv));
216 let ft = fix_sorts swap exc_to_be t in
217 pp(lazy("unable to fix the sort"));
218 if ft == t then raise exn;
219 (try ft, NCicTypeChecker.typeof ~subst ~metasenv context ft
220 with NCicTypeChecker.AssertFailure _ -> raise exn)
221 | NCicTypeChecker.TypeCheckerFailure msg ->
222 prerr_endline (Lazy.force msg);
223 prerr_endline (NCicPp.ppterm ~metasenv ~subst ~context t);
224 prerr_endline (ppcontext ~metasenv ~subst context);
225 prerr_endline (ppmetasenv ~subst metasenv);
229 | NCic.Implicit (`Typeof _) ->
230 raise (UnificationFailure(lazy "trying to unify a term with a type"))
232 let lty = NCicSubstitution.subst_meta lc ty in
233 pp (lazy ("On the types: " ^
234 NCicPp.ppterm ~metasenv ~subst ~context lty ^ " === " ^
235 NCicPp.ppterm ~metasenv ~subst ~context ty_t));
237 try unify test_eq_only metasenv subst context lty ty_t
238 with NCicEnvironment.BadConstraint _ as exc ->
239 let ty_t = fix_sorts swap exc_to_be ty_t in
240 try unify test_eq_only metasenv subst context lty ty_t
242 | NCicEnvironment.BadConstraint _
243 | UnificationFailure _ -> raise exc
247 (* viral sortification *)
248 let is_sort metasenv subst context t =
249 match NCicReduction.whd ~subst context t with
251 let tags, _, _ = NCicUtils.lookup_meta i metasenv in
252 has_tag ((=) `IsSort) tags
253 | NCic.Sort _ -> true
256 let rec sortify metasenv subst = function
257 | NCic.Implicit (`Typeof _) -> assert false
258 | NCic.Sort _ as t -> metasenv, subst, t, 0
259 | NCic.Meta (i,_) as t ->
260 let tags, context, ty = NCicUtils.lookup_meta i metasenv in
261 if has_tag ((=) `IsSort) tags then metasenv, subst, t, i
263 let ty = NCicReduction.whd ~subst context ty in
264 let metasenv, subst, ty, _ = sortify metasenv subst ty in
265 let metasenv, j, m, _ =
266 NCicMetaSubst.mk_meta metasenv ~attrs:[`IsSort] [] (`WithType ty)
268 pp(lazy("rimpiazzo " ^ string_of_int i^" con "^string_of_int j));
269 let subst_entry = i, (tags, context, m, ty) in
270 let subst = subst_entry :: subst in
271 let metasenv = List.filter (fun x,_ -> i <> x) metasenv in
272 metasenv, subst, m, j
273 | NCic.Appl (NCic.Meta _ as hd :: args) as t ->
274 let metasenv, subst, lambda_Mj =
275 lambda_intros rdb metasenv subst context t args
277 let metasenv,subst= unify true metasenv subst context hd lambda_Mj in
278 let t = NCicReduction.whd ~subst context t in
279 let _result = sortify metasenv subst t in
280 (* untested, maybe dead, code *) assert false;
282 if could_reduce t then raise (Uncertain(lazy "not a sort"))
283 else raise (UnificationFailure(lazy "not a sort"))
285 let metasenv, subst, _, n =
286 if has_tag ((=) `IsSort) tags then
287 let m,s,x,_ = sortify metasenv subst (NCicReduction.whd ~subst context t)
289 else if is_sort metasenv subst context t then
290 sortify metasenv subst (NCic.Meta (n,lc))
292 metasenv, subst, NCic.Rel ~-1,n
294 let tags, ctx, ty = NCicUtils.lookup_meta n metasenv in
296 pp (lazy(string_of_int n ^ " := 111 = "^
297 NCicPp.ppterm ~metasenv ~subst ~context t));
298 let (metasenv, subst), t =
301 ~unify:(fun m s c t1 t2 ->
304 try Some (unify test_eq_only m s c t1 t2 )
305 with UnificationFailure _ | Uncertain _ -> None
308 metasenv subst context n lc t
309 with NCicMetaSubst.Uncertain msg ->
310 pp (lazy ("delift fails: " ^ Lazy.force msg));
311 raise (Uncertain msg)
312 | NCicMetaSubst.MetaSubstFailure msg ->
313 pp (lazy ("delift fails: " ^ Lazy.force msg));
314 raise (UnificationFailure msg)
316 pp (lazy(string_of_int n ^ " := 222 = "^
317 NCicPp.ppterm ~metasenv ~subst ~context:ctx t
318 ^ ppmetasenv ~subst metasenv));
319 (* Unifying the types may have already instantiated n. *)
321 let _, _,oldt,_ = NCicUtils.lookup_subst n subst in
322 let oldt = NCicSubstitution.subst_meta lc oldt in
323 let t = NCicSubstitution.subst_meta lc t in
324 (* conjecture: always fail --> occur check *)
325 unify test_eq_only metasenv subst context oldt t
326 with NCicUtils.Subst_not_found _ ->
328 let rec aux = function
329 | NCic.Meta (j,lc) ->
331 let _, _, t, _ = NCicUtils.lookup_subst j subst in
332 aux (NCicSubstitution.subst_meta lc t)
333 with NCicUtils.Subst_not_found _ ->
334 let tags', ctx, ty = NCicUtils.lookup_meta j metasenv in
335 let metasenv = List.remove_assoc j metasenv in
336 let tags = tags @ tags' in
337 (j, (tags, ctx, ty)) :: metasenv, tags)
338 | _ -> metasenv, tags
342 (* by cumulativity when unify(?,Type_i)
343 * we could ? := Type_j with j <= i... *)
344 let subst = (n, (tags, ctx, t, ty)) :: subst in
345 pp (lazy ("?"^string_of_int n^" := "^NCicPp.ppterm
346 ~metasenv ~subst ~context (NCicSubstitution.subst_meta lc t)));
348 List.filter (fun (m,_) -> not (n = m)) metasenv
351 (*D*) in outside true; rc with exn -> outside false; raise exn
353 and unify rdb test_eq_only metasenv subst context t1 t2 =
354 (*D*) inside 'U'; try let rc =
355 let fo_unif test_eq_only metasenv subst (norm1,t1) (norm2,t2) =
356 (*D*) inside 'F'; try let rc =
357 pp (lazy(" " ^ NCicPp.ppterm ~metasenv ~subst ~context t1 ^ " ==?== " ^
358 NCicPp.ppterm ~metasenv ~subst ~context t2 ^ ppmetasenv
360 pp (lazy(" " ^ NCicPp.ppterm ~metasenv ~subst:[] ~context t1 ^ " ==??== " ^
361 NCicPp.ppterm ~metasenv ~subst:[] ~context t2 ^ ppmetasenv
367 | C.Appl [_], _ | _, C.Appl [_] | C.Appl [], _ | _, C.Appl []
368 | C.Appl (C.Appl _::_), _ | _, C.Appl (C.Appl _::_) ->
369 prerr_endline "Appl [Appl _;_] or Appl [] or Appl [_] invariant";
371 | (C.Sort (C.Type a), C.Sort (C.Type b)) when not test_eq_only ->
372 if NCicEnvironment.universe_leq a b then metasenv, subst
373 else raise (UnificationFailure (mk_msg metasenv subst context t1 t2))
374 | (C.Sort (C.Type a), C.Sort (C.Type b)) ->
375 if NCicEnvironment.universe_eq a b then metasenv, subst
376 else raise (UnificationFailure (mk_msg metasenv subst context t1 t2))
377 | (C.Sort C.Prop,C.Sort (C.Type _)) ->
378 if (not test_eq_only) then metasenv, subst
379 else raise (UnificationFailure (mk_msg metasenv subst context t1 t2))
381 | (C.Lambda (name1,s1,t1), C.Lambda(_,s2,t2))
382 | (C.Prod (name1,s1,t1), C.Prod(_,s2,t2)) ->
383 let metasenv, subst = unify rdb true metasenv subst context s1 s2 in
384 unify rdb test_eq_only metasenv subst ((name1, C.Decl s1)::context) t1 t2
385 | (C.LetIn (name1,ty1,s1,t1), C.LetIn(_,ty2,s2,t2)) ->
386 let metasenv,subst=unify rdb test_eq_only metasenv subst context ty1 ty2 in
387 let metasenv,subst=unify rdb test_eq_only metasenv subst context s1 s2 in
388 let context = (name1, C.Def (s1,ty1))::context in
389 unify rdb test_eq_only metasenv subst context t1 t2
391 | (C.Meta (n1,(s1,l1 as lc1)),C.Meta (n2,(s2,l2 as lc2))) when n1 = n2 ->
393 let l1 = NCicUtils.expand_local_context l1 in
394 let l2 = NCicUtils.expand_local_context l2 in
395 let metasenv, subst, to_restrict, _ =
397 (fun t1 t2 (metasenv, subst, to_restrict, i) ->
399 let metasenv, subst =
400 unify rdb test_eq_only metasenv subst context
401 (NCicSubstitution.lift s1 t1) (NCicSubstitution.lift s2 t2)
403 metasenv, subst, to_restrict, i-1
404 with UnificationFailure _ | Uncertain _ ->
405 metasenv, subst, i::to_restrict, i-1)
406 l1 l2 (metasenv, subst, [], List.length l1)
408 if to_restrict <> [] then
409 let metasenv, subst, _ =
410 NCicMetaSubst.restrict metasenv subst n1 to_restrict
415 | Invalid_argument _ -> assert false
416 | NCicMetaSubst.MetaSubstFailure msg ->
418 let _,_,term,_ = NCicUtils.lookup_subst n1 subst in
419 let term1 = NCicSubstitution.subst_meta lc1 term in
420 let term2 = NCicSubstitution.subst_meta lc2 term in
421 unify rdb test_eq_only metasenv subst context term1 term2
422 with NCicUtils.Subst_not_found _-> raise (UnificationFailure msg))
424 | NCic.Appl (NCic.Meta (i,_)::_ as l1),
425 NCic.Appl (NCic.Meta (j,_)::_ as l2) when i=j ->
428 (fun (metasenv, subst) t1 t2 ->
429 unify rdb test_eq_only metasenv subst context t1 t2)
430 (metasenv,subst) l1 l2
431 with Invalid_argument _ ->
432 raise (UnificationFailure (mk_msg metasenv subst context t1 t2)))
434 | _, NCic.Meta (n, _) when is_locked n subst ->
435 (let (metasenv, subst), i =
436 match NCicReduction.whd ~subst context t1 with
437 | NCic.Appl (NCic.Meta (i,l)::args) ->
438 let metasenv, subst, lambda_Mj =
439 lambda_intros rdb metasenv subst context t1 args
441 unify rdb test_eq_only metasenv subst context
442 (C.Meta (i,l)) lambda_Mj,
444 | NCic.Meta (i,_) -> (metasenv, subst), i
446 raise (UnificationFailure (lazy "Locked term vs non
447 flexible term; probably not saturated enough yet!"))
449 let t1 = NCicReduction.whd ~subst context t1 in
451 match t1 with NCic.Meta (j,l) -> j, l | _ -> assert false
453 let metasenv, subst =
454 instantiate rdb test_eq_only metasenv subst context j lj t2 true
456 (* We need to remove the out_scope_tags to avoid propagation of
457 them that triggers again the ad-hoc case *)
459 List.map (fun (i,(tag,ctx,bo,ty)) ->
462 (function `InScope | `OutScope _ -> false | _ -> true) tag
468 let name, ctx, term, ty = NCicUtils.lookup_subst i subst in
469 let term = eta_reduce subst term in
470 let subst = List.filter (fun (j,_) -> j <> i) subst in
471 metasenv, ((i, (name, ctx, term, ty)) :: subst)
472 with Not_found -> assert false))
474 | C.Meta (n,lc), t when List.mem_assoc n subst ->
475 let _,_,term,_ = NCicUtils.lookup_subst n subst in
476 let term = NCicSubstitution.subst_meta lc term in
477 unify rdb test_eq_only metasenv subst context term t
479 | t, C.Meta (n,lc) when List.mem_assoc n subst ->
480 let _,_,term,_ = NCicUtils.lookup_subst n subst in
481 let term = NCicSubstitution.subst_meta lc term in
482 unify rdb test_eq_only metasenv subst context t term
484 | NCic.Appl (NCic.Meta (i,l)::args), _ when List.mem_assoc i subst ->
485 let _,_,term,_ = NCicUtils.lookup_subst i subst in
486 let term = NCicSubstitution.subst_meta l term in
487 unify rdb test_eq_only metasenv subst context
488 (mk_appl ~upto:(List.length args) term args) t2
490 | _, NCic.Appl (NCic.Meta (i,l)::args) when List.mem_assoc i subst ->
491 let _,_,term,_ = NCicUtils.lookup_subst i subst in
492 let term = NCicSubstitution.subst_meta l term in
493 unify rdb test_eq_only metasenv subst context t1
494 (mk_appl ~upto:(List.length args) term args)
496 | C.Meta (n,lc), t ->
497 instantiate rdb test_eq_only metasenv subst context n lc
498 (NCicReduction.head_beta_reduce ~subst t) false
500 | t, C.Meta (n,lc) ->
501 instantiate rdb test_eq_only metasenv subst context n lc
502 (NCicReduction.head_beta_reduce ~subst t) true
504 | NCic.Appl (NCic.Meta (i,l)::args), _ ->
505 let metasenv, subst, lambda_Mj =
506 lambda_intros rdb metasenv subst context t1 args
508 let metasenv, subst =
510 unify rdb test_eq_only metasenv subst context
511 (C.Meta (i,l)) lambda_Mj
512 with UnificationFailure msg | Uncertain msg ->
513 (* failure: let's try again argument vs argument *)
514 raise (KeepReducing msg)
516 let metasenv, subst =
517 unify rdb test_eq_only metasenv subst context t1 t2
520 let name, ctx, term, ty = NCicUtils.lookup_subst i subst in
521 let term = eta_reduce subst term in
522 let subst = List.filter (fun (j,_) -> j <> i) subst in
523 metasenv, ((i, (name, ctx, term, ty)) :: subst)
524 with Not_found -> assert false)
526 | _, NCic.Appl (NCic.Meta (i,l)::args) ->
527 let metasenv, subst, lambda_Mj =
528 lambda_intros rdb metasenv subst context t2 args
530 let metasenv, subst =
532 unify rdb test_eq_only metasenv subst context
533 lambda_Mj (C.Meta (i,l))
534 with UnificationFailure msg | Uncertain msg ->
535 (* failure: let's try again argument vs argument *)
536 raise (KeepReducing msg)
538 let metasenv, subst =
539 unify rdb test_eq_only metasenv subst context t1 t2
542 let name, ctx, term, ty = NCicUtils.lookup_subst i subst in
543 let term = eta_reduce subst term in
544 let subst = List.filter (fun (j,_) -> j <> i) subst in
545 metasenv, ((i, (name, ctx, term, ty)) :: subst)
546 with Not_found -> assert false)
548 (* processing this case here we avoid a useless small delta step *)
549 | (C.Appl ((C.Const r1) as _hd1::tl1), C.Appl (C.Const r2::tl2))
551 let relevance = NCicEnvironment.get_relevance r1 in
552 let relevance = match r1 with
553 | Ref.Ref (_,Ref.Con (_,_,lno)) ->
555 try snd (HExtlib.split_nth lno relevance)
558 HExtlib.mk_list false lno @ relevance
561 let metasenv, subst, _ =
564 (fun (metasenv, subst, relevance) t1 t2 ->
566 match relevance with b::tl -> b,tl | _ -> true, [] in
567 let metasenv, subst =
568 try unify rdb test_eq_only metasenv subst context t1 t2
569 with UnificationFailure _ | Uncertain _ when not b ->
572 metasenv, subst, relevance)
573 (metasenv, subst, relevance) tl1 tl2
575 Invalid_argument _ ->
576 raise (Uncertain (mk_msg metasenv subst context t1 t2))
577 | UnificationFailure _ | Uncertain _ when not (norm1 && norm2) ->
578 raise (KeepReducing (mk_msg metasenv subst context t1 t2))
582 | (C.Match (Ref.Ref (_,Ref.Ind (_,tyno,_)) as ref1,outtype1,term1,pl1),
583 C.Match (ref2,outtype2,term2,pl2)) ->
584 let _,_,itl,_,_ = NCicEnvironment.get_checked_indtys ref1 in
585 let _,_,ty,_ = List.nth itl tyno in
586 let rec remove_prods ~subst context ty =
587 let ty = NCicReduction.whd ~subst context ty in
590 | C.Prod (name,so,ta) ->
591 remove_prods ~subst ((name,(C.Decl so))::context) ta
595 match remove_prods ~subst [] ty with
596 | C.Sort C.Prop -> true
599 if not (Ref.eq ref1 ref2) then
600 raise (Uncertain (mk_msg metasenv subst context t1 t2))
602 let metasenv, subst =
603 unify rdb test_eq_only metasenv subst context outtype1 outtype2 in
604 let metasenv, subst =
605 try unify rdb test_eq_only metasenv subst context term1 term2
606 with UnificationFailure _ | Uncertain _ when is_prop ->
611 (fun (metasenv,subst) ->
612 unify rdb test_eq_only metasenv subst context)
613 (metasenv, subst) pl1 pl2
614 with Invalid_argument _ -> assert false)
615 | (C.Implicit _, _) | (_, C.Implicit _) -> assert false
616 | _ when norm1 && norm2 ->
617 if (could_reduce t1 || could_reduce t2) then
618 raise (Uncertain (mk_msg metasenv subst context t1 t2))
620 raise (UnificationFailure (mk_msg metasenv subst context t1 t2))
621 | _ -> raise (KeepReducing (mk_msg metasenv subst context t1 t2))
622 (*D*) in outside true; rc with exn -> outside false; raise exn
624 let try_hints metasenv subst (_,t1 as mt1) (_,t2 as mt2) (* exc*) =
625 (*D*) inside 'H'; try let rc =
626 pp(lazy ("\nProblema:\n" ^
627 NCicPp.ppterm ~metasenv ~subst ~context t1 ^ " =?= " ^
628 NCicPp.ppterm ~metasenv ~subst ~context t2));
630 NCicUnifHint.look_for_hint rdb metasenv subst context t1 t2
632 let rec cand_iter = function
633 | [] -> None (* raise exc *)
634 | (metasenv,(c1,c2),premises)::tl ->
635 pp (lazy ("\nProvo il candidato:\n" ^
639 NCicPp.ppterm ~metasenv ~subst ~context a ^ " =?= " ^
640 NCicPp.ppterm ~metasenv ~subst ~context b) premises) ^
641 "\n-------------------------------------------\n"^
642 NCicPp.ppterm ~metasenv ~subst ~context c1 ^ " = " ^
643 NCicPp.ppterm ~metasenv ~subst ~context c2));
645 (*D*) inside 'K'; try let rc =
647 fo_unif test_eq_only metasenv subst mt1 (false,c1) in
649 fo_unif test_eq_only metasenv subst (false,c2) mt2 in
652 (fun (metasenv, subst) (x,y) ->
653 unify rdb test_eq_only metasenv subst context x y)
654 (metasenv, subst) premises
656 pp(lazy("FUNZIONA!"));
657 Some (metasenv, subst)
658 (*D*) in outside true; rc with exn -> outside false; raise exn
660 KeepReducing _ | UnificationFailure _ | Uncertain _ -> cand_iter tl
663 (*D*) in outside true; rc with exn -> outside false; raise exn
665 let height_of = function
666 | NCic.Const (Ref.Ref (_,Ref.Def h))
667 | NCic.Const (Ref.Ref (_,Ref.Fix (_,_,h)))
668 | NCic.Appl(NCic.Const(Ref.Ref(_,Ref.Def h))::_)
669 | NCic.Appl(NCic.Const(Ref.Ref(_,Ref.Fix (_,_,h)))::_) -> h
672 let put_in_whd m1 m2 =
673 NCicReduction.reduce_machine ~delta:max_int ~subst context m1,
674 NCicReduction.reduce_machine ~delta:max_int ~subst context m2
676 let small_delta_step ~subst
677 ((_,_,t1,_ as m1, norm1) as x1) ((_,_,t2,_ as m2, norm2) as x2)
679 assert (not (norm1 && norm2));
681 x1,NCicReduction.reduce_machine ~delta:0 ~subst context m2
683 NCicReduction.reduce_machine ~delta:0 ~subst context m1,x2
685 let h1 = height_of t1 in
686 let h2 = height_of t2 in
687 let delta = if h1 = h2 then max 0 (h1 -1) else min h1 h2 in
688 NCicReduction.reduce_machine ~delta ~subst context m1,
689 NCicReduction.reduce_machine ~delta ~subst context m2
691 let rec unif_machines metasenv subst =
693 | ((k1,e1,t1,s1),norm1 as m1),((k2,e2,t2,s2),norm2 as m2) ->
694 (*D*) inside 'M'; try let rc =
696 NCicPp.ppterm ~metasenv ~subst ~context
697 (NCicReduction.unwind (k1,e1,t1,s1)) ^
699 NCicPp.ppterm ~metasenv ~subst ~context
700 (NCicReduction.unwind (k2,e2,t2,s2))));
701 pp (lazy (string_of_bool norm1 ^ " ?? " ^ string_of_bool norm2));
702 let relevance = [] (* TO BE UNDERSTOOD
704 | C.Const r -> NCicEnvironment.get_relevance r
706 let unif_from_stack t1 t2 b metasenv subst =
708 let t1 = NCicReduction.from_stack ~delta:max_int t1 in
709 let t2 = NCicReduction.from_stack ~delta:max_int t2 in
710 unif_machines metasenv subst (put_in_whd t1 t2)
711 with UnificationFailure _ | Uncertain _ when not b ->
714 let rec check_stack l1 l2 r todo =
716 | x1::tl1, x2::tl2, r::tr-> check_stack tl1 tl2 tr ((x1,x2,r)::todo)
717 | x1::tl1, x2::tl2, []-> check_stack tl1 tl2 [] ((x1,x2,true)::todo)
719 NCicReduction.unwind (k1,e1,t1,List.rev l1),
720 NCicReduction.unwind (k2,e2,t2,List.rev l2),
723 let hh1,hh2,todo=check_stack (List.rev s1) (List.rev s2) relevance [] in
726 fo_unif test_eq_only metasenv subst (norm1,hh1) (norm2,hh2) in
728 (fun (metasenv,subst) (x1,x2,r) ->
729 unif_from_stack x1 x2 r metasenv subst
730 ) (metasenv,subst) todo
733 assert (not (norm1 && norm2));
734 unif_machines metasenv subst (small_delta_step ~subst m1 m2)
735 | UnificationFailure _ | Uncertain _ when (not (norm1 && norm2))
736 -> unif_machines metasenv subst (small_delta_step ~subst m1 m2)
737 | UnificationFailure msg
738 when could_reduce (NCicReduction.unwind (fst m1))
739 || could_reduce (NCicReduction.unwind (fst m2))
740 -> raise (Uncertain msg)
741 (*D*) in outside true; rc with exn -> outside false; raise exn
743 try fo_unif test_eq_only metasenv subst (false,t1) (false,t2)
745 | UnificationFailure _ as exn -> raise exn
746 | KeepReducing _ | Uncertain _ as exn ->
747 let (t1,norm1 as tm1),(t2,norm2 as tm2) =
748 put_in_whd (0,[],t1,[]) (0,[],t2,[])
751 try_hints metasenv subst
752 (norm1,NCicReduction.unwind t1) (norm2,NCicReduction.unwind t2)
757 | KeepReducing msg ->
759 unif_machines metasenv subst (tm1,tm2)
761 | UnificationFailure _ -> raise (UnificationFailure msg)
762 | Uncertain _ -> raise (Uncertain msg)
763 | KeepReducing _ -> assert false)
764 | Uncertain _ -> raise exn
766 (*D*) in outside true; rc with KeepReducing _ -> assert false | exn -> outside false; raise exn
768 and delift_type_wrt_terms rdb metasenv subst context t args =
769 let lc = List.rev args @ mk_irl (List.length context) (List.length args+1) in
770 let (metasenv, subst), t =
773 ~unify:(fun m s c t1 t2 ->
776 try Some (unify rdb false m s c t1 t2 )
777 with UnificationFailure _ | Uncertain _ -> None
780 metasenv subst context 0 (0,NCic.Ctx lc) t
782 NCicMetaSubst.MetaSubstFailure _
783 | NCicMetaSubst.Uncertain _ -> (metasenv, subst), t
789 let unify rdb ?(test_eq_only=false) =
791 unify rdb test_eq_only;;
793 let fix_sorts = fix_sorts true (UnificationFailure (lazy "no sup"));;