src/Pure/unify.ML
changeset 52698 df1531af559f
parent 52221 4ffe819a9b11
child 52701 51dfdcd88e84
equal deleted inserted replaced
52697:6fb98a20c349 52698:df1531af559f
   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)) =