src/Pure/Isar/theory_target.ML

rearranged target theories

(*  Title:      Pure/Isar/theory_target.ML
    Author:     Makarius

Common theory/locale/class/instantiation/overloading targets.
*)

signature THEORY_TARGET =
sig
  val peek: local_theory -> {target: string, new_locale: bool, is_locale: bool,
    is_class: bool, instantiation: string list * (string * sort) list * sort,
    overloading: (string * (string * typ) * bool) list}
  val init: string option -> theory -> local_theory
  val begin: string -> Proof.context -> local_theory
  val context: xstring -> theory -> local_theory
  val instantiation: string list * (string * sort) list * sort -> theory -> local_theory
  val instantiation_cmd: xstring list * sort * xstring -> theory -> local_theory
  val overloading: (string * (string * typ) * bool) list -> theory -> local_theory
  val overloading_cmd: (string * string * bool) list -> theory -> local_theory
end;

structure TheoryTarget: THEORY_TARGET =
struct

(* new locales *)

fun locale_extern new_locale x = 
  if new_locale then NewLocale.extern x else Locale.extern x;
fun locale_add_type_syntax new_locale x =
  if new_locale then NewLocale.add_type_syntax x else Locale.add_type_syntax x;
fun locale_add_term_syntax new_locale x =
  if new_locale then NewLocale.add_term_syntax x else Locale.add_term_syntax x;
fun locale_add_declaration new_locale x =
  if new_locale then NewLocale.add_declaration x else Locale.add_declaration x;
fun locale_add_thmss new_locale x =
  if new_locale then NewLocale.add_thmss x else Locale.add_thmss x;
fun locale_init new_locale x =
  if new_locale then NewLocale.init x else Locale.init x;
fun locale_intern new_locale x =
  if new_locale then NewLocale.intern x else Locale.intern x;

(* context data *)

datatype target = Target of {target: string, new_locale: bool, is_locale: bool,
  is_class: bool, instantiation: string list * (string * sort) list * sort,
  overloading: (string * (string * typ) * bool) list};

fun make_target target new_locale is_locale is_class instantiation overloading =
  Target {target = target, new_locale = new_locale, is_locale = is_locale,
    is_class = is_class, instantiation = instantiation, overloading = overloading};

val global_target = make_target "" false false false ([], [], []) [];

structure Data = ProofDataFun
(
  type T = target;
  fun init _ = global_target;
);

val peek = (fn Target args => args) o Data.get;


(* pretty *)

fun pretty_thy ctxt target is_locale is_class =
  let
    val thy = ProofContext.theory_of ctxt;
    val target_name = (if is_class then "class " else "locale ") ^ locale_extern is_class thy target;
    val fixes = map (fn (x, T) => (Binding.name x, SOME T, NoSyn))
      (#1 (ProofContext.inferred_fixes ctxt));
    val assumes = map (fn A => (Attrib.empty_binding, [(Thm.term_of A, [])]))
      (Assumption.assms_of ctxt);
    val elems =
      (if null fixes then [] else [Element.Fixes fixes]) @
      (if null assumes then [] else [Element.Assumes assumes]);
  in
    if target = "" then []
    else if null elems then [Pretty.str target_name]
    else [Pretty.big_list (target_name ^ " =")
      (map (Pretty.chunks o Element.pretty_ctxt ctxt) elems)]
  end;

fun pretty (Target {target, is_locale, is_class, instantiation, overloading, ...}) ctxt =
  Pretty.block [Pretty.str "theory", Pretty.brk 1,
      Pretty.str (Context.theory_name (ProofContext.theory_of ctxt))] ::
    (if not (null overloading) then [Overloading.pretty ctxt]
     else if not (null (#1 instantiation)) then [Class_Target.pretty_instantiation ctxt]
     else pretty_thy ctxt target is_locale is_class);


(* target declarations *)

fun target_decl add (Target {target, new_locale, ...}) d lthy =
  let
    val d' = Morphism.transform (LocalTheory.target_morphism lthy) d;
    val d0 = Morphism.form d';
  in
    if target = "" then
      lthy
      |> LocalTheory.theory (Context.theory_map d0)
      |> LocalTheory.target (Context.proof_map d0)
    else
      lthy
      |> LocalTheory.target (add new_locale target d')
  end;

val type_syntax = target_decl locale_add_type_syntax;
val term_syntax = target_decl locale_add_term_syntax;
val declaration = target_decl locale_add_declaration;

fun class_target (Target {target, ...}) f =
  LocalTheory.raw_theory f #>
  LocalTheory.target (Class_Target.refresh_syntax target);


(* notes *)

fun import_export_proof ctxt (name, raw_th) =
  let
    val thy = ProofContext.theory_of ctxt;
    val thy_ctxt = ProofContext.init thy;
    val certT = Thm.ctyp_of thy;
    val cert = Thm.cterm_of thy;

    (*export assumes/defines*)
    val th = Goal.norm_result raw_th;
    val (defs, th') = LocalDefs.export ctxt thy_ctxt th;
    val concl_conv = MetaSimplifier.rewrite true defs (Thm.cprop_of th);
    val assms = map (MetaSimplifier.rewrite_rule defs o Thm.assume) (Assumption.assms_of ctxt);
    val nprems = Thm.nprems_of th' - Thm.nprems_of th;

    (*export fixes*)
    val tfrees = map TFree (Thm.fold_terms Term.add_tfrees th' []);
    val frees = map Free (Thm.fold_terms Term.add_frees th' []);
    val (th'' :: vs) = (th' :: map (Drule.mk_term o cert) (map Logic.mk_type tfrees @ frees))
      |> Variable.export ctxt thy_ctxt
      |> Drule.zero_var_indexes_list;

    (*thm definition*)
    val result = PureThy.name_thm true true Position.none name th'';

    (*import fixes*)
    val (tvars, vars) =
      chop (length tfrees) (map (Thm.term_of o Drule.dest_term) vs)
      |>> map Logic.dest_type;

    val instT = map_filter (fn (TVar v, T) => SOME (v, T) | _ => NONE) (tvars ~~ tfrees);
    val inst = filter (is_Var o fst) (vars ~~ frees);
    val cinstT = map (pairself certT o apfst TVar) instT;
    val cinst = map (pairself (cert o Term.map_types (TermSubst.instantiateT instT))) inst;
    val result' = Thm.instantiate (cinstT, cinst) result;