330 NB "vname" is only used in the call to make_args!! *) |
330 NB "vname" is only used in the call to make_args!! *) |
331 fun matchcopy thy vname = |
331 fun matchcopy thy vname = |
332 let |
332 let |
333 fun mc (rbinder, targs, u, ed as (env, dpairs)) : (term * (Envir.env * dpair list)) Seq.seq = |
333 fun mc (rbinder, targs, u, ed as (env, dpairs)) : (term * (Envir.env * dpair list)) Seq.seq = |
334 let |
334 let |
335 val trace_tps = Config.get_global thy trace_types; |
335 val trace_types = Config.get_global thy trace_types; |
336 (*Produce copies of uarg and cons them in front of uargs*) |
336 (*Produce copies of uarg and cons them in front of uargs*) |
337 fun copycons uarg (uargs, (env, dpairs)) = |
337 fun copycons uarg (uargs, (env, dpairs)) = |
338 Seq.map (fn (uarg', ed') => (uarg' :: uargs, ed')) |
338 Seq.map (fn (uarg', ed') => (uarg' :: uargs, ed')) |
339 (mc (rbinder, targs,eta_norm env (rbinder, Envir.head_norm env uarg), |
339 (mc (rbinder, targs,eta_norm env (rbinder, Envir.head_norm env uarg), |
340 (env, dpairs))); |
340 (env, dpairs))); |
347 (*attempt projection on argument with given typ*) |
347 (*attempt projection on argument with given typ*) |
348 val Ts = map (curry (fastype env) rbinder) targs; |
348 val Ts = map (curry (fastype env) rbinder) targs; |
349 fun projenv (head, (Us, bary), targ, tail) = |
349 fun projenv (head, (Us, bary), targ, tail) = |
350 let |
350 let |
351 val env = |
351 val env = |
352 if trace_tps then test_unify_types thy (base, bary) env |
352 if trace_types then test_unify_types thy (base, bary) env |
353 else unify_types thy (base, bary) env |
353 else unify_types thy (base, bary) env |
354 in |
354 in |
355 Seq.make (fn () => |
355 Seq.make (fn () => |
356 let |
356 let |
357 val (env', args) = make_args vname (Ts, env, Us); |
357 val (env', args) = make_args vname (Ts, env, Us); |
585 (*Unify the dpairs in the environment. |
585 (*Unify the dpairs in the environment. |
586 Returns flex-flex disagreement pairs NOT IN normal form. |
586 Returns flex-flex disagreement pairs NOT IN normal form. |
587 SIMPL may raise exception CANTUNIFY. *) |
587 SIMPL may raise exception CANTUNIFY. *) |
588 fun hounifiers (thy, env, tus : (term * term) list) : (Envir.env * (term * term) list) Seq.seq = |
588 fun hounifiers (thy, env, tus : (term * term) list) : (Envir.env * (term * term) list) Seq.seq = |
589 let |
589 let |
590 val trace_bnd = Config.get_global thy trace_bound; |
590 val trace_bound = Config.get_global thy trace_bound; |
591 val search_bnd = Config.get_global thy search_bound; |
591 val search_bound = Config.get_global thy search_bound; |
592 val trace_smp = Config.get_global thy trace_simp; |
592 val trace_simp = Config.get_global thy trace_simp; |
593 fun add_unify tdepth ((env, dpairs), reseq) = |
593 fun add_unify tdepth ((env, dpairs), reseq) = |
594 Seq.make (fn () => |
594 Seq.make (fn () => |
595 let |
595 let |
596 val (env', flexflex, flexrigid) = |
596 val (env', flexflex, flexrigid) = |
597 (if tdepth > trace_bnd andalso trace_smp |
597 (if tdepth > trace_bound andalso trace_simp |
598 then print_dpairs thy "Enter SIMPL" (env, dpairs) else (); |
598 then print_dpairs thy "Enter SIMPL" (env, dpairs) else (); |
599 SIMPL thy (env, dpairs)); |
599 SIMPL thy (env, dpairs)); |
600 in |
600 in |
601 (case flexrigid of |
601 (case flexrigid of |
602 [] => SOME (fold_rev (add_ffpair thy) flexflex (env', []), reseq) |
602 [] => SOME (fold_rev (add_ffpair thy) flexflex (env', []), reseq) |
603 | dp :: frigid' => |
603 | dp :: frigid' => |
604 if tdepth > search_bnd then |
604 if tdepth > search_bound then |
605 (warning "Unification bound exceeded"; Seq.pull reseq) |
605 (warning "Unification bound exceeded"; Seq.pull reseq) |
606 else |
606 else |
607 (if tdepth > trace_bnd then |
607 (if tdepth > trace_bound then |
608 print_dpairs thy "Enter MATCH" (env',flexrigid@flexflex) |
608 print_dpairs thy "Enter MATCH" (env',flexrigid@flexflex) |
609 else (); |
609 else (); |
610 Seq.pull (Seq.it_right |
610 Seq.pull (Seq.it_right |
611 (add_unify (tdepth + 1)) (MATCH thy (env',dp, frigid'@flexflex), reseq)))) |
611 (add_unify (tdepth + 1)) (MATCH thy (env',dp, frigid'@flexflex), reseq)))) |
612 end |
612 end |
613 handle CANTUNIFY => |
613 handle CANTUNIFY => |
614 (if tdepth > trace_bnd then tracing"Failure node" else (); |
614 (if tdepth > trace_bound then tracing "Failure node" else (); |
615 Seq.pull reseq)); |
615 Seq.pull reseq)); |
616 val dps = map (fn (t, u) => ([], t, u)) tus; |
616 val dps = map (fn (t, u) => ([], t, u)) tus; |
617 in add_unify 1 ((env, dps), Seq.empty) end; |
617 in add_unify 1 ((env, dps), Seq.empty) end; |
618 |
618 |
619 fun unifiers (params as (thy, env, tus)) = |
619 fun unifiers (params as (thy, env, tus)) = |