more accurate Global_Theory.name_facts: burrow into expression of attributed theorems;
authorwenzelm
Wed, 27 Dec 2023 16:10:10 +0100
changeset 79373 589d8d9018d8
parent 79372 d02c8adce4e6
child 79374 6c12ef5bb38c
more accurate Global_Theory.name_facts: burrow into expression of attributed theorems;
src/Pure/Isar/proof_context.ML
src/Pure/global_theory.ML
--- a/src/Pure/Isar/proof_context.ML	Wed Dec 27 15:57:42 2023 +0100
+++ b/src/Pure/Isar/proof_context.ML	Wed Dec 27 16:10:10 2023 +0100
@@ -1053,9 +1053,9 @@
   let
     val name_pos = full_name_pos ctxt b;
     fun app_fact (thms, atts) =
-      fold_map (Thm.proof_attributes (surround (Thm.kind kind) (atts @ more_atts)))
-        (Global_Theory.name_thms Global_Theory.unofficial1 name_pos thms);
-    val (thms', ctxt') = fold_maps app_fact facts ctxt;
+      fold_map (Thm.proof_attributes (surround (Thm.kind kind) (atts @ more_atts))) thms;
+    val (thms', ctxt') =
+      fold_maps app_fact (Global_Theory.name_facts Global_Theory.unofficial1 name_pos facts) ctxt;
     val thms'' = Global_Theory.name_thms Global_Theory.unofficial2 name_pos thms';
     val (_, ctxt'') = ctxt' |> add_facts {index = is_stmt ctxt} (b, Lazy.value thms'');
   in ((#1 name_pos, thms''), ctxt'') end;
--- a/src/Pure/global_theory.ML	Wed Dec 27 15:57:42 2023 +0100
+++ b/src/Pure/global_theory.ML	Wed Dec 27 16:10:10 2023 +0100
@@ -31,6 +31,7 @@
   val unofficial2: name_flags
   val name_thm: name_flags -> string * Position.T -> thm -> thm
   val name_thms: name_flags -> string * Position.T -> thm list -> thm list
+  val name_facts: name_flags -> string * Position.T -> (thm list * 'a) list -> (thm list * 'a) list
   val check_thms_lazy: thm list lazy -> thm list lazy
   val add_thms_lazy: string -> (binding * thm list lazy) -> theory -> theory
   val store_thm: binding * thm -> theory -> thm * theory
@@ -253,6 +254,10 @@
   Thm_Name.list name_pos thms
   |> map (fn (a, thm) => name_thm name_flags (Thm_Name.flatten a) thm);
 
+fun name_facts name_flags name_pos facts =
+  Thm_Name.expr name_pos facts
+  |> (map o apfst o map) (fn (a, thm) => name_thm name_flags (Thm_Name.flatten a) thm);
+
 end;
 
 
@@ -314,7 +319,7 @@
     else
       let
         val (thms', thy') = thy
-          |> app_facts (map (apfst (name_thms name_flags1 name)) facts)
+          |> app_facts (name_facts name_flags1 name facts)
           |>> name_thms name_flags2 name |-> register;
         val thy'' = thy' |> add_facts (b, Lazy.value thms');
       in (map (Thm.transfer thy'') thms', thy'') end