proper context for extern operation: observe local options;
authorwenzelm
Mon, 02 Dec 2024 11:22:44 +0100
changeset 81534 c32ebdcbe8ca
parent 81533 fb49af893986
child 81535 db073d1733ab
proper context for extern operation: observe local options; more uniform global_ctxt for pretty printing;
src/Pure/Proof/extraction.ML
src/Pure/Proof/proof_checker.ML
src/Pure/Pure.thy
src/Pure/global_theory.ML
src/Pure/raw_simplifier.ML
src/Pure/thm_deps.ML
--- a/src/Pure/Proof/extraction.ML	Mon Dec 02 11:08:36 2024 +0100
+++ b/src/Pure/Proof/extraction.ML	Mon Dec 02 11:22:44 2024 +0100
@@ -505,6 +505,8 @@
 fun extract thm_vss thy =
   let
     val thy' = add_syntax thy;
+    val global_ctxt = Syntax.init_pretty_global thy';
+    val print_thm_name = Global_Theory.print_thm_name global_ctxt;
 
     val {realizes_eqns, typeof_eqns, types, realizers, defs, expand, prep} =
       ExtractionData.get thy;
@@ -640,8 +642,7 @@
                   let
                     val _ = T = nullT orelse error "corr: internal error";
                     val _ =
-                      msg d ("Building correctness proof for " ^
-                        quote (Global_Theory.print_thm_name thy thm_name) ^
+                      msg d ("Building correctness proof for " ^ quote (print_thm_name thm_name) ^
                         (if null vs' then ""
                          else " (relevant variables: " ^ commas_quote vs' ^ ")"));
                     val prf' = prep (Proofterm.reconstruct_proof thy' prop prf);
@@ -670,8 +671,8 @@
             | SOME rs => (case find vs' rs of
                 SOME (_, prf') => (Proofterm.proof_combP (prf_subst_TVars tye' prf', sprfs), defs')
               | NONE => error ("corr: no realizer for instance of theorem " ^
-                  quote (Global_Theory.print_thm_name thy' thm_name) ^ ":\n" ^
-                    Syntax.string_of_term_global thy'
+                  quote (print_thm_name thm_name) ^ ":\n" ^
+                    Syntax.string_of_term global_ctxt
                       (Envir.beta_norm (Proofterm.prop_of (Proofterm.proof_combt (prf0, ts)))))))
           end
 
@@ -686,7 +687,7 @@
               SOME (_, prf) => (Proofterm.proof_combP (prf_subst_TVars tye' prf, mk_sprfs cs tye),
                 defs)
             | NONE => error ("corr: no realizer for instance of axiom " ^
-                quote s ^ ":\n" ^ Syntax.string_of_term_global thy' (Envir.beta_norm
+                quote s ^ ":\n" ^ Syntax.string_of_term global_ctxt (Envir.beta_norm
                   (Proofterm.prop_of (Proofterm.proof_combt (prf0, ts)))))
           end
 
@@ -738,7 +739,7 @@
                 NONE =>
                   let
                     val _ =
-                      msg d ("Extracting " ^ quote (Global_Theory.print_thm_name thy' thm_name) ^
+                      msg d ("Extracting " ^ quote (print_thm_name thm_name) ^
                         (if null vs' then ""
                          else " (relevant variables: " ^ commas_quote vs' ^ ")"));
                     val prf' = prep (Proofterm.reconstruct_proof thy' prop prf);
@@ -790,8 +791,8 @@
             | SOME rs => (case find vs' rs of
                 SOME (t, _) => (subst_TVars tye' t, defs)
               | NONE => error ("extr: no realizer for instance of theorem " ^
-                  quote (Global_Theory.print_thm_name thy' thm_name) ^ ":\n" ^
-                    Syntax.string_of_term_global thy' (Envir.beta_norm
+                  quote (print_thm_name thm_name) ^ ":\n" ^
+                    Syntax.string_of_term global_ctxt (Envir.beta_norm
                     (Proofterm.prop_of (Proofterm.proof_combt (prf0, ts))))))
           end
 
@@ -803,7 +804,7 @@
             case find vs' (Thm_Name.Table.lookup_list realizers (s, 0)) of
               SOME (t, _) => (subst_TVars tye' t, defs)
             | NONE => error ("extr: no realizer for instance of axiom " ^
-                quote s ^ ":\n" ^ Syntax.string_of_term_global thy' (Envir.beta_norm
+                quote s ^ ":\n" ^ Syntax.string_of_term global_ctxt (Envir.beta_norm
                   (Proofterm.prop_of (Proofterm.proof_combt (prf0, ts)))))
           end
 
@@ -817,7 +818,7 @@
         val name = Thm.derivation_name thm;
         val _ = if Thm_Name.is_empty name then error "extraction: unnamed theorem" else ();
         val _ = etype_of thy' vs [] prop <> nullT orelse error ("theorem " ^
-          quote (Global_Theory.print_thm_name thy' name) ^ " has no computational content")
+          quote (print_thm_name name) ^ " has no computational content")
       in Proofterm.reconstruct_proof thy' prop prf end;
 
     val defs =
--- a/src/Pure/Proof/proof_checker.ML	Mon Dec 02 11:08:36 2024 +0100
+++ b/src/Pure/Proof/proof_checker.ML	Mon Dec 02 11:22:44 2024 +0100
@@ -72,7 +72,10 @@
   end;
 
 fun thm_of_proof thy =
-  let val lookup = lookup_thm thy in
+  let
+    val global_ctxt = Syntax.init_pretty_global thy;
+    val lookup = lookup_thm thy;
+  in
     fn prf =>
       let
         val prf_names =
@@ -96,9 +99,9 @@
                   if is_equal prop prop' then ()
                   else
                     error ("Duplicate use of theorem name " ^
-                      quote (Global_Theory.print_thm_name thy thm_name) ^ Position.here thm_pos
-                      ^ "\n" ^ Syntax.string_of_term_global thy prop
-                      ^ "\n\n" ^ Syntax.string_of_term_global thy prop');
+                      quote (Global_Theory.print_thm_name global_ctxt thm_name) ^ Position.here thm_pos
+                      ^ "\n" ^ Syntax.string_of_term global_ctxt prop
+                      ^ "\n\n" ^ Syntax.string_of_term global_ctxt prop');
               in thm_of_atom thm Ts end
 
           | thm_of _ _ (PAxm (name, _, SOME Ts)) =
--- a/src/Pure/Pure.thy	Mon Dec 02 11:08:36 2024 +0100
+++ b/src/Pure/Pure.thy	Mon Dec 02 11:22:44 2024 +0100
@@ -1378,10 +1378,8 @@
     "print theorem dependencies (immediate non-transitive)"
     (Parse.thms1 >> (fn args =>
       Toplevel.keep (fn st =>
-        let
-          val thy = Toplevel.theory_of st;
-          val ctxt = Toplevel.context_of st;
-        in Pretty.writeln (Thm_Deps.pretty_thm_deps thy (Attrib.eval_thms ctxt args)) end)));
+        let val ctxt = Toplevel.context_of st
+        in Pretty.writeln (Thm_Deps.pretty_thm_deps ctxt (Attrib.eval_thms ctxt args)) end)));
 
 val _ =
   Outer_Syntax.command \<^command_keyword>\<open>thm_oracles\<close>
--- a/src/Pure/global_theory.ML	Mon Dec 02 11:08:36 2024 +0100
+++ b/src/Pure/global_theory.ML	Mon Dec 02 11:22:44 2024 +0100
@@ -14,8 +14,8 @@
   val alias_fact: binding -> string -> theory -> theory
   val hide_fact: bool -> string -> theory -> theory
   val dest_thms: bool -> theory list -> theory -> (Thm_Name.P * thm) list
-  val pretty_thm_name: theory -> Thm_Name.T -> Pretty.T
-  val print_thm_name: theory -> Thm_Name.T -> string
+  val pretty_thm_name: Proof.context -> Thm_Name.T -> Pretty.T
+  val print_thm_name: Proof.context -> Thm_Name.T -> string
   val get_thm_names: theory -> Thm_Name.P Inttab.table
   val dest_thm_names: theory -> (Proofterm.thm_id * Thm_Name.P) list
   val lookup_thm_id: theory -> Proofterm.thm_id -> Thm_Name.P option
@@ -88,7 +88,9 @@
   Facts.dest_static verbose (map facts_of prev_thys) (facts_of thy)
   |> maps (fn (name, thms) => Thm_Name.list (name, Position.none) thms);
 
-fun pretty_thm_name thy = Facts.pretty_thm_name (Context.Theory thy) (facts_of thy);
+fun pretty_thm_name ctxt =
+  Facts.pretty_thm_name (Context.Proof ctxt) (facts_of (Proof_Context.theory_of ctxt));
+
 val print_thm_name = Pretty.string_of oo pretty_thm_name;
 
 
@@ -108,9 +110,11 @@
         else
           (case Inttab.lookup thm_names serial of
             SOME (thm_name', thm_pos') =>
-              raise THM ("Duplicate use of derivation identity for " ^
-                print_thm_name thy thm_name ^ Position.here thm_pos ^ " vs. " ^
-                print_thm_name thy thm_name' ^ Position.here thm_pos', 0, [thm])
+              let val thy_ctxt = Proof_Context.init_global thy in
+                raise THM ("Duplicate use of derivation identity for " ^
+                  print_thm_name thy_ctxt thm_name ^ Position.here thm_pos ^ " vs. " ^
+                  print_thm_name thy_ctxt thm_name' ^ Position.here thm_pos', 0, [thm])
+              end
           | NONE => Inttab.update (serial, (thm_name, thm_pos)) thm_names)));
 
 fun lazy_thm_names thy =
--- a/src/Pure/raw_simplifier.ML	Mon Dec 02 11:08:36 2024 +0100
+++ b/src/Pure/raw_simplifier.ML	Mon Dec 02 11:22:44 2024 +0100
@@ -481,10 +481,9 @@
 
 fun print_thm ctxt msg (name, th) =
   let
-    val thy = Proof_Context.theory_of ctxt;
     val sffx =
       if Thm_Name.is_empty name then ""
-      else " " ^ quote (Global_Theory.print_thm_name thy name) ^ ":";
+      else " " ^ quote (Global_Theory.print_thm_name ctxt name) ^ ":";
   in print_term ctxt (msg ^ sffx) (Thm.full_prop_of th) end;
 
 fun print_thm0 ctxt msg th = print_thm ctxt msg (Thm_Name.empty, th);
--- a/src/Pure/thm_deps.ML	Mon Dec 02 11:08:36 2024 +0100
+++ b/src/Pure/thm_deps.ML	Mon Dec 02 11:22:44 2024 +0100
@@ -11,7 +11,7 @@
   val has_skip_proof: thm list -> bool
   val pretty_thm_oracles: Proof.context -> thm list -> Pretty.T
   val thm_deps: theory -> thm list -> (Proofterm.thm_id * Thm_Name.T) list
-  val pretty_thm_deps: theory -> thm list -> Pretty.T
+  val pretty_thm_deps: Proof.context -> thm list -> Pretty.T
   val unused_thms_cmd: theory list * theory list -> (Thm_Name.T * thm) list
 end;
 
@@ -71,10 +71,11 @@
       |-> Inttab.fold_rev (fn (_, SOME entry) => cons entry | _ => I)
   end;
 
-fun pretty_thm_deps thy thms =
+fun pretty_thm_deps ctxt thms =
   let
+    val thy = Proof_Context.theory_of ctxt;
     val facts = Global_Theory.facts_of thy;
-    val extern_fact = Name_Space.extern_global thy (Facts.space_of facts);
+    val extern_fact = Name_Space.extern ctxt (Facts.space_of facts);
     val deps =
       (case try (thm_deps thy) thms of
         SOME deps => deps
@@ -83,7 +84,7 @@
       deps
       |> map (fn (_, thm_name as (name, _)) => (extern_fact name, thm_name))
       |> sort_by #1
-      |> map (fn (_, thm_name) => Pretty.item [Global_Theory.pretty_thm_name thy thm_name])
+      |> map (fn (_, thm_name) => Pretty.item [Global_Theory.pretty_thm_name ctxt thm_name])
   in Pretty.big_list ("dependencies: " ^ string_of_int (length items)) items end;