proper trim_context / transfer, e.g. for Specification.definition;
authorwenzelm
Tue, 06 Jun 2023 15:12:40 +0200
changeset 78138 0ea55458f867
parent 78137 9ccb1ae28f0d
child 78139 bb85bda12b8e
proper trim_context / transfer, e.g. for Specification.definition;
src/Pure/assumption.ML
--- a/src/Pure/assumption.ML	Tue Jun 06 14:19:53 2023 +0200
+++ b/src/Pure/assumption.ML	Tue Jun 06 15:12:40 2023 +0200
@@ -82,14 +82,19 @@
 );
 
 fun map_data f = Data.map (fn Data {rev_assms, rev_prems} => make_data (f (rev_assms, rev_prems)));
-fun rep_data ctxt = Data.get ctxt |> (fn Data rep => rep);
 
 
 (* all assumptions *)
 
-val all_assumptions_of = rev o #rev_assms o rep_data;
+fun all_assumptions_of ctxt =
+  let val Data {rev_assms, ...} = Data.get ctxt
+  in fold (cons o (apsnd o map) (Thm.transfer_cterm' ctxt)) rev_assms [] end;
+
+fun all_prems_of ctxt =
+  let val Data {rev_prems, ...} = Data.get ctxt
+  in fold (cons o Thm.transfer' ctxt) rev_prems [] end;
+
 val all_assms_of = maps #2 o all_assumptions_of;
-val all_prems_of = rev o #rev_prems o rep_data;
 
 
 (* local assumptions *)
@@ -129,7 +134,8 @@
   let val (new_prems, ctxt') = fold_map assume_hyps new_asms ctxt in
     ctxt'
     |> map_data (fn (rev_assms, rev_prems) =>
-        ((export, new_asms) :: rev_assms, fold cons new_prems rev_prems))
+      ((export, map Thm.trim_context_cterm new_asms) :: rev_assms,
+        fold (cons o Thm.trim_context) new_prems rev_prems))
     |> pair new_prems
   end;
 
@@ -154,11 +160,12 @@
 
 fun export_morphism inner outer =
   let
-    val export0 = export_thm false inner outer;
+    val assms0 = local_assumptions_of inner outer
+      |> (map o apsnd o map) Thm.trim_context_cterm;
     fun thm thy =
       let val norm = norm_hhf_protect (Proof_Context.init_global thy)
-      in norm #> export0 #> norm end;
-    val term = export_term inner outer;
+      in norm #> thm_export false assms0 #> norm end;
+    val term = term_export assms0;
     val typ = Logic.type_map term;
   in
     Morphism.morphism "Assumption.export"