renamed export to export_standard (again!), because it includes Drule.local_standard';
authorwenzelm
Wed, 25 Jan 2006 00:21:43 +0100
changeset 18785 5ae1f1c1b764
parent 18784 2d93559db27e
child 18786 591a37d48794
renamed export to export_standard (again!), because it includes Drule.local_standard'; added abs_def (from locale.ML);
src/Pure/Isar/proof_context.ML
--- a/src/Pure/Isar/proof_context.ML	Wed Jan 25 00:21:42 2006 +0100
+++ b/src/Pure/Isar/proof_context.ML	Wed Jan 25 00:21:43 2006 +0100
@@ -69,7 +69,7 @@
   val read_const: context -> string -> term
   val warn_extra_tfrees: context -> context -> context
   val generalize: context -> context -> term list -> term list
-  val export: context -> context -> thm -> thm
+  val export_standard: context -> context -> thm -> thm
   val exports: context -> context -> thm -> thm Seq.seq
   val goal_exports: context -> context -> thm -> thm Seq.seq
   val drop_schematic: indexname * term option -> indexname * term option
@@ -142,6 +142,7 @@
   val export_view: cterm list -> context -> context -> thm -> thm
   val mk_def: context -> (string * term) list -> term list
   val cert_def: context -> term -> string * term
+  val abs_def: term -> (string * typ) * term
   val def_export: export
   val add_def: string * term -> context -> ((string * typ) * thm) * context
   val add_cases: bool -> (string * RuleCases.T option) list -> context -> context
@@ -784,7 +785,7 @@
       end)
   end;
 
-fun export inner outer =
+fun export_standard inner outer =
   let val exp = common_exports false inner outer in
     fn th =>
       (case Seq.pull (exp th) of
@@ -1143,7 +1144,7 @@
     fun add (Free (x, T)) = if is_fixed ctxt x then I else insert (op =) (x, SOME T, NoSyn)
       | add _ = I;
     val fixes = rev (fold_aterms add t []);
-  in snd (add_fixes_i fixes ctxt) end;
+  in ctxt |> set_body false |> add_fixes_i fixes |> snd |> restore_body ctxt end;
 
 fun auto_fixes (arg as (ctxt, (propss, x))) =
   if is_body ctxt then arg
@@ -1216,7 +1217,7 @@
     val asms' = asms1 @ [(view, assume_export)] @ asms2;
   in (asms', prems) end);
 
-fun export_view view inner outer = export (add_view outer view inner) outer;
+fun export_view view inner outer = export_standard (add_view outer view inner) outer;
 
 
 (* definitions *)
@@ -1231,7 +1232,7 @@
 fun cert_def ctxt eq =
   let
     fun err msg = cat_error msg
-      ("The error(s) above occurred in local definition: " ^ string_of_term ctxt eq);
+      ("The error(s) above occurred in definition: " ^ string_of_term ctxt eq);
     val (lhs, rhs) = Logic.dest_equals (Term.strip_all_body eq)
       handle TERM _ => err "Not a meta-equality (==)";
     val (f, xs) = Term.strip_comb (Pattern.beta_eta_contract lhs);
@@ -1251,6 +1252,16 @@
     (c, Term.list_all_free (List.mapPartial (try Term.dest_Free) xs, eq))
   end;
 
+fun abs_def eq =
+  let
+    val body = Term.strip_all_body eq;
+    val vars = map Free (Term.rename_wrt_term body (Term.strip_all_vars eq));
+    val (lhs, rhs) = Logic.dest_equals (Term.subst_bounds (vars, body));
+    val (f, xs) = Term.strip_comb (Pattern.beta_eta_contract lhs);
+    val eq' = Term.list_abs_free (map Term.dest_Free xs, rhs);
+  in (Term.dest_Free f, eq') end;
+
+
 fun head_of_def cprop =
   #1 (Term.strip_comb (#1 (Logic.dest_equals (Term.strip_all_body (Thm.term_of cprop)))))
   |> Thm.cterm_of (Thm.theory_of_cterm cprop);