guard unify tracing via visible status of global theory;
authorwenzelm
Thu, 18 Jul 2013 22:00:35 +0200
changeset 5383851dfdcd88e84
parent 53837 d63f80f93025
child 53839 c503730efae5
guard unify tracing via visible status of global theory;
find_theorems: back-patching of background theory to observe Context_Position.is_visible avoids spamming via auto solve_direct;
src/Pure/Tools/find_theorems.ML
src/Pure/unify.ML
src/Tools/solve_direct.ML
     1.1 --- a/src/Pure/Tools/find_theorems.ML	Thu Jul 18 21:57:27 2013 +0200
     1.2 +++ b/src/Pure/Tools/find_theorems.ML	Thu Jul 18 22:00:35 2013 +0200
     1.3 @@ -631,8 +631,18 @@
     1.4          Toplevel.keep (fn state =>
     1.5            let
     1.6              val ctxt = Toplevel.context_of state;
     1.7 +            val thy' =
     1.8 +              Proof_Context.theory_of ctxt
     1.9 +              |> Theory.copy
    1.10 +              |> Context_Position.set_visible_global (Context_Position.is_visible ctxt)
    1.11 +              |> Theory.checkpoint;
    1.12 +
    1.13              val opt_goal = try (Proof.simple_goal o Toplevel.proof_of) state |> Option.map #goal;
    1.14 -          in print_theorems ctxt opt_goal opt_lim rem_dups spec end)));
    1.15 +            val (ctxt', opt_goal') =
    1.16 +              (case opt_goal of
    1.17 +                NONE => (ctxt, NONE)
    1.18 +              | SOME th => (Proof_Context.transfer thy' ctxt, SOME (Thm.transfer thy' th)));
    1.19 +          in print_theorems ctxt' opt_goal' opt_lim rem_dups spec end)));
    1.20  
    1.21  end;
    1.22  
     2.1 --- a/src/Pure/unify.ML	Thu Jul 18 21:57:27 2013 +0200
     2.2 +++ b/src/Pure/unify.ML	Thu Jul 18 22:00:35 2013 +0200
     2.3 @@ -189,7 +189,10 @@
     2.4  fun test_unify_types thy (T, U) env =
     2.5    let
     2.6      val str_of = Syntax.string_of_typ_global thy;
     2.7 -    fun warn () = tracing ("Potential loss of completeness: " ^ str_of U ^ " = " ^ str_of T);
     2.8 +    fun warn () =
     2.9 +      if Context_Position.is_visible_global thy then
    2.10 +        tracing ("Potential loss of completeness: " ^ str_of U ^ " = " ^ str_of T)
    2.11 +      else ();
    2.12      val env' = unify_types thy (T, U) env;
    2.13    in if is_TVar T orelse is_TVar U then warn () else (); env' end;
    2.14  
    2.15 @@ -572,14 +575,16 @@
    2.16    In t==u print u first because it may be rigid or flexible --
    2.17      t is always flexible.*)
    2.18  fun print_dpairs thy msg (env, dpairs) =
    2.19 -  let
    2.20 -    fun pdp (rbinder, t, u) =
    2.21 -      let
    2.22 -        fun termT t =
    2.23 -          Syntax.pretty_term_global thy (Envir.norm_term env (Logic.rlist_abs (rbinder, t)));
    2.24 -        val bsymbs = [termT u, Pretty.str " =?=", Pretty.brk 1, termT t];
    2.25 -      in tracing (Pretty.string_of (Pretty.blk (0, bsymbs))) end;
    2.26 -  in tracing msg; List.app pdp dpairs end;
    2.27 +  if Context_Position.is_visible_global thy then
    2.28 +    let
    2.29 +      fun pdp (rbinder, t, u) =
    2.30 +        let
    2.31 +          fun termT t =
    2.32 +            Syntax.pretty_term_global thy (Envir.norm_term env (Logic.rlist_abs (rbinder, t)));
    2.33 +          val bsymbs = [termT u, Pretty.str " =?=", Pretty.brk 1, termT t];
    2.34 +        in tracing (Pretty.string_of (Pretty.blk (0, bsymbs))) end;
    2.35 +    in tracing msg; List.app pdp dpairs end
    2.36 +  else ();
    2.37  
    2.38  
    2.39  (*Unify the dpairs in the environment.
    2.40 @@ -602,7 +607,8 @@
    2.41              [] => SOME (fold_rev (add_ffpair thy) flexflex (env', []), reseq)
    2.42            | dp :: frigid' =>
    2.43                if tdepth > search_bound then
    2.44 -                (warning "Unification bound exceeded"; Seq.pull reseq)
    2.45 +                (Context_Position.if_visible_global thy warning "Unification bound exceeded";
    2.46 +                 Seq.pull reseq)
    2.47                else
    2.48                 (if tdepth > trace_bound then
    2.49                    print_dpairs thy "Enter MATCH" (env',flexrigid@flexflex)
    2.50 @@ -611,8 +617,8 @@
    2.51                      (add_unify (tdepth + 1)) (MATCH thy (env',dp, frigid'@flexflex), reseq))))
    2.52          end
    2.53          handle CANTUNIFY =>
    2.54 -         (if tdepth > trace_bound then tracing "Failure node" else ();
    2.55 -          Seq.pull reseq));
    2.56 +         (if tdepth > trace_bound then Context_Position.if_visible_global thy tracing "Failure node"
    2.57 +          else (); Seq.pull reseq));
    2.58      val dps = map (fn (t, u) => ([], t, u)) tus;
    2.59    in add_unify 1 ((env, dps), Seq.empty) end;
    2.60  
     3.1 --- a/src/Tools/solve_direct.ML	Thu Jul 18 21:57:27 2013 +0200
     3.2 +++ b/src/Tools/solve_direct.ML	Thu Jul 18 22:00:35 2013 +0200
     3.3 @@ -29,6 +29,7 @@
     3.4  val noneN = "none";
     3.5  val unknownN = "none";
     3.6  
     3.7 +
     3.8  (* preferences *)
     3.9  
    3.10  val max_solutions = Unsynchronized.ref 5;
    3.11 @@ -46,10 +47,11 @@
    3.12  fun do_solve_direct mode state =
    3.13    let
    3.14      val ctxt = Proof.context_of state;
    3.15 +    val find_ctxt = if mode = Auto_Try then Context_Position.set_visible false ctxt else ctxt;
    3.16  
    3.17      val crits = [(true, Find_Theorems.Solves)];
    3.18      fun find g =
    3.19 -      snd (Find_Theorems.find_theorems ctxt (SOME g) (SOME (! max_solutions)) false crits);
    3.20 +      snd (Find_Theorems.find_theorems find_ctxt (SOME g) (SOME (! max_solutions)) false crits);
    3.21  
    3.22      fun prt_result (goal, results) =
    3.23        let