src/Pure/Isar/local_theory.ML
author wenzelm
Wed Feb 15 21:35:09 2006 +0100 (2006-02-15 ago)
changeset 19059 b4ca3100e818
parent 19032 d25dfb797612
child 19077 c36eb33c8428
permissions -rw-r--r--
init/exit no longer change the theory (no naming);
added naming, restore_naming, mapping;
wenzelm@18744
     1
(*  Title:      Pure/Isar/local_theory.ML
wenzelm@18744
     2
    ID:         $Id$
wenzelm@18744
     3
    Author:     Makarius
wenzelm@18744
     4
wenzelm@18744
     5
Local theory operations, with optional target locale.
wenzelm@18744
     6
*)
wenzelm@18744
     7
wenzelm@18951
     8
type local_theory = Proof.context;
wenzelm@18951
     9
wenzelm@18744
    10
signature LOCAL_THEORY =
wenzelm@18744
    11
sig
wenzelm@18951
    12
  val params_of: local_theory -> (string * typ) list
wenzelm@18951
    13
  val hyps_of: local_theory -> term list
wenzelm@18951
    14
  val standard: local_theory -> thm -> thm
wenzelm@18951
    15
  val pretty_consts: local_theory -> (string * typ -> bool) -> (string * typ) list -> Pretty.T
wenzelm@18951
    16
  val quiet_mode: bool ref
wenzelm@18951
    17
  val print_consts: local_theory -> (string * typ -> bool) -> (string * typ) list -> unit
wenzelm@18951
    18
  val theory: (theory -> theory) -> local_theory -> local_theory
wenzelm@18951
    19
  val theory_result: (theory -> 'a * theory) -> local_theory -> 'a * local_theory
wenzelm@18951
    20
  val init: xstring option -> theory -> local_theory
wenzelm@18951
    21
  val init_i: string option -> theory -> local_theory
wenzelm@19017
    22
  val restore: local_theory -> local_theory
wenzelm@18951
    23
  val exit: local_theory -> local_theory * theory
wenzelm@19059
    24
  val restore_naming: local_theory -> local_theory
wenzelm@19059
    25
  val naming: local_theory -> local_theory
wenzelm@19059
    26
  val mapping: xstring option -> (local_theory -> local_theory) -> theory -> local_theory * theory
wenzelm@18951
    27
  val consts: ((bstring * typ) * mixfix) list -> local_theory -> term list * local_theory
wenzelm@18876
    28
  val consts_restricted: (string * typ -> bool) ->
wenzelm@18951
    29
    ((bstring * typ) * mixfix) list -> local_theory -> term list * local_theory
wenzelm@18951
    30
  val axioms: ((bstring * Attrib.src list) * term list) list -> local_theory ->
wenzelm@18951
    31
    (bstring * thm list) list * local_theory
wenzelm@18951
    32
  val axioms_finish: (local_theory -> thm -> thm) ->
wenzelm@18951
    33
    ((bstring * Attrib.src list) * term list) list -> local_theory ->
wenzelm@18951
    34
    (bstring * thm list) list * local_theory
wenzelm@18767
    35
  val notes: string -> ((bstring * Attrib.src list) * (thm list * Attrib.src list) list) list ->
wenzelm@18951
    36
    local_theory -> (bstring * thm list) list * local_theory
wenzelm@18951
    37
  val note: (bstring * Attrib.src list) * thm list -> local_theory ->
wenzelm@18951
    38
    (bstring * thm list) * local_theory
wenzelm@18823
    39
  val def: (bstring * mixfix) * ((bstring * Attrib.src list) * term) ->
wenzelm@18951
    40
    local_theory -> (term * (bstring * thm)) * local_theory
wenzelm@18951
    41
  val def_finish: (local_theory -> term -> thm -> thm) ->
wenzelm@18823
    42
    (bstring * mixfix) * ((bstring * Attrib.src list) * term) ->
wenzelm@18951
    43
    local_theory -> (term * (bstring * thm)) * local_theory
wenzelm@18744
    44
end;
wenzelm@18744
    45
wenzelm@18744
    46
structure LocalTheory: LOCAL_THEORY =
wenzelm@18744
    47
struct
wenzelm@18744
    48
wenzelm@19059
    49
wenzelm@18767
    50
(** local context data **)
wenzelm@18744
    51
wenzelm@18744
    52
structure Data = ProofDataFun
wenzelm@18744
    53
(
wenzelm@18876
    54
  val name = "Pure/local_theory";
wenzelm@18744
    55
  type T =
wenzelm@18805
    56
   {locale: (string * (cterm list * Proof.context)) option,
wenzelm@18744
    57
    params: (string * typ) list,
wenzelm@18744
    58
    hyps: term list,
wenzelm@19059
    59
    restore_naming: theory -> theory};
wenzelm@19059
    60
  fun init thy = {locale = NONE, params = [], hyps = [], restore_naming = I};
wenzelm@18744
    61
  fun print _ _ = ();
wenzelm@18744
    62
);
wenzelm@18744
    63
val _ = Context.add_setup Data.init;
wenzelm@18744
    64
wenzelm@19059
    65
fun map_locale f = Data.map (fn {locale, params, hyps, restore_naming} =>
wenzelm@18805
    66
  {locale = Option.map (fn (loc, (view, ctxt)) => (loc, (view, f ctxt))) locale,
wenzelm@19059
    67
    params = params, hyps = hyps, restore_naming = restore_naming});
wenzelm@18805
    68
wenzelm@18767
    69
val locale_of = #locale o Data.get;
wenzelm@18767
    70
val params_of = #params o Data.get;
wenzelm@18767
    71
val hyps_of = #hyps o Data.get;
wenzelm@18805
    72
wenzelm@18805
    73
fun standard ctxt =
wenzelm@18805
    74
  (case #locale (Data.get ctxt) of
wenzelm@18805
    75
    NONE => Drule.standard
wenzelm@18805
    76
  | SOME (_, (_, loc_ctxt)) => ProofContext.export_standard ctxt loc_ctxt);
wenzelm@18744
    77
wenzelm@18767
    78
wenzelm@18823
    79
(* print consts *)
wenzelm@18767
    80
wenzelm@18951
    81
val quiet_mode = ref false;
wenzelm@18951
    82
wenzelm@18767
    83
local
wenzelm@18767
    84
wenzelm@18767
    85
fun pretty_var ctxt (x, T) =
wenzelm@18767
    86
  Pretty.block [Pretty.str x, Pretty.str " ::", Pretty.brk 1,
wenzelm@18767
    87
    Pretty.quote (ProofContext.pretty_typ ctxt T)];
wenzelm@18744
    88
wenzelm@18767
    89
fun pretty_vars ctxt kind vs = Pretty.big_list kind (map (pretty_var ctxt) vs);
wenzelm@18767
    90
wenzelm@18767
    91
in
wenzelm@18767
    92
wenzelm@18876
    93
fun pretty_consts ctxt pred cs =
wenzelm@18876
    94
  (case filter pred (params_of ctxt) of
wenzelm@18767
    95
    [] => pretty_vars ctxt "constants" cs
wenzelm@18767
    96
  | ps => Pretty.chunks [pretty_vars ctxt "parameters" ps, pretty_vars ctxt "constants" cs]);
wenzelm@18767
    97
wenzelm@18876
    98
fun print_consts _ _ [] = ()
wenzelm@18951
    99
  | print_consts ctxt pred cs =
wenzelm@18951
   100
      if ! quiet_mode then () else Pretty.writeln (pretty_consts ctxt pred cs);
wenzelm@18823
   101
wenzelm@18767
   102
end;
wenzelm@18767
   103
wenzelm@18767
   104
wenzelm@18805
   105
(* theory/locale substructures *)
wenzelm@18781
   106
wenzelm@18781
   107
fun theory_result f ctxt =
wenzelm@18781
   108
  let val (res, thy') = f (ProofContext.theory_of ctxt)
wenzelm@19032
   109
  in (res, ctxt |> map_locale (ProofContext.transfer thy') |> ProofContext.transfer thy') end;
wenzelm@19032
   110
wenzelm@19032
   111
fun theory f ctxt = #2 (theory_result (f #> pair ()) ctxt);
wenzelm@18805
   112
wenzelm@18805
   113
fun locale_result f ctxt =
wenzelm@18805
   114
  (case locale_of ctxt of
wenzelm@18805
   115
    NONE => error "Local theory: no locale context"
wenzelm@19017
   116
  | SOME (_, view_ctxt) =>
wenzelm@18805
   117
      let
wenzelm@19017
   118
        val (res, loc_ctxt') = f view_ctxt;
wenzelm@18805
   119
        val thy' = ProofContext.theory_of loc_ctxt';
wenzelm@19032
   120
      in (res, ctxt |> map_locale (K loc_ctxt') |> ProofContext.transfer thy') end);
wenzelm@18805
   121
wenzelm@19017
   122
fun locale f ctxt =
wenzelm@19017
   123
  if is_none (locale_of ctxt) then ctxt
wenzelm@19017
   124
  else #2 (locale_result (f #> pair ()) ctxt);
wenzelm@18805
   125
wenzelm@19017
   126
wenzelm@19017
   127
(* init -- restore -- exit *)
wenzelm@18781
   128
wenzelm@18781
   129
fun init_i NONE thy = ProofContext.init thy
wenzelm@18781
   130
  | init_i (SOME loc) thy =
wenzelm@18781
   131
      thy
wenzelm@18781
   132
      |> Locale.init loc
wenzelm@18805
   133
      ||>> ProofContext.inferred_fixes
wenzelm@18805
   134
      |> (fn ((view, params), ctxt) => Data.put
wenzelm@18805
   135
          {locale = SOME (loc, (view, ctxt)),
wenzelm@18781
   136
           params = params,
wenzelm@18781
   137
           hyps = ProofContext.assms_of ctxt,
wenzelm@19059
   138
           restore_naming = Sign.restore_naming thy} ctxt);
wenzelm@18781
   139
wenzelm@18805
   140
fun init loc thy = init_i (Option.map (Locale.intern thy) loc) thy;
wenzelm@18781
   141
wenzelm@19017
   142
fun restore ctxt =
wenzelm@19017
   143
  (case locale_of ctxt of
wenzelm@19017
   144
    NONE => ctxt
wenzelm@19017
   145
  | SOME (_, (_, loc_ctxt)) => loc_ctxt |> Data.put (Data.get ctxt));
wenzelm@19017
   146
wenzelm@19059
   147
fun exit ctxt = (ctxt, ProofContext.theory_of ctxt);
wenzelm@19059
   148
wenzelm@19059
   149
wenzelm@19059
   150
(* local naming *)
wenzelm@19059
   151
wenzelm@19059
   152
fun naming ctxt =
wenzelm@19059
   153
  (case locale_of ctxt of
wenzelm@19059
   154
    NONE => ctxt
wenzelm@19059
   155
  | SOME (loc, _) => ctxt |> theory (Sign.sticky_prefix (Sign.base_name loc)));
wenzelm@19059
   156
wenzelm@19059
   157
fun restore_naming ctxt = theory (#restore_naming (Data.get ctxt)) ctxt;
wenzelm@19059
   158
wenzelm@19059
   159
fun mapping loc f =
wenzelm@19059
   160
  init loc #> naming #> f #> restore_naming #> exit;
wenzelm@18781
   161
wenzelm@18781
   162
wenzelm@18781
   163
wenzelm@18781
   164
(** local theory **)
wenzelm@18781
   165
wenzelm@18767
   166
(* consts *)
wenzelm@18744
   167
wenzelm@18876
   168
fun consts_restricted pred decls ctxt =
wenzelm@18744
   169
  let
wenzelm@18744
   170
    val thy = ProofContext.theory_of ctxt;
wenzelm@18876
   171
    val params = filter pred (params_of ctxt);
wenzelm@18744
   172
    val ps = map Free params;
wenzelm@18805
   173
    val Ps = map #2 params;
wenzelm@19017
   174
    val abbrevs = decls |> map (fn ((c, T), mx) =>
wenzelm@19017
   175
      let val t = Term.list_comb (Const (Sign.full_name thy c, Ps ---> T), ps)
wenzelm@19017
   176
      in (c, t, mx) end);
wenzelm@18744
   177
  in
wenzelm@19017
   178
    ctxt |>
wenzelm@19017
   179
    (case locale_of ctxt of
wenzelm@19017
   180
      NONE => theory (Sign.add_consts_i (map (fn ((c, T), mx) => (c, T, mx)) decls))
wenzelm@19017
   181
    | SOME (loc, _) =>
wenzelm@19017
   182
        theory (Sign.add_consts_i (map (fn ((c, T), _) => (c, Ps ---> T, NoSyn)) decls)) #>
wenzelm@19017
   183
        locale (Locale.add_abbrevs loc true abbrevs) #>
wenzelm@19017
   184
        ProofContext.add_abbrevs_i true abbrevs)
wenzelm@19017
   185
    |> pair (map #2 abbrevs)
wenzelm@18767
   186
  end;
wenzelm@18767
   187
wenzelm@18876
   188
val consts = consts_restricted (K true);
wenzelm@18876
   189
wenzelm@18767
   190
wenzelm@18805
   191
(* fact definitions *)
wenzelm@18767
   192
wenzelm@18767
   193
fun notes kind facts ctxt =
wenzelm@18805
   194
  let
wenzelm@18805
   195
    val attrib = Attrib.attribute_i (ProofContext.theory_of ctxt);
wenzelm@18805
   196
    val facts' = map (apsnd (map (apfst (map (standard ctxt))))) facts;
wenzelm@18805
   197
  in
wenzelm@18805
   198
    ctxt |>
wenzelm@18805
   199
    (case locale_of ctxt of
wenzelm@18805
   200
      NONE => theory_result (PureThy.note_thmss_i kind (Attrib.map_facts attrib facts'))
wenzelm@19017
   201
    | SOME (loc, _) =>
wenzelm@19017
   202
        locale_result (apfst #1 o Locale.add_thmss kind loc facts'))
wenzelm@18805
   203
    ||> (#2 o ProofContext.note_thmss_i (Attrib.map_facts attrib facts))
wenzelm@18805
   204
  end;
wenzelm@18767
   205
wenzelm@18781
   206
fun note (a, ths) ctxt =
wenzelm@18805
   207
  ctxt |> notes PureThy.theoremK [(a, [(ths, [])])] |>> hd;
wenzelm@18767
   208
wenzelm@18767
   209
wenzelm@18767
   210
(* axioms *)
wenzelm@18767
   211
wenzelm@18781
   212
local
wenzelm@18781
   213
wenzelm@18781
   214
fun add_axiom hyps (name, prop) thy =
wenzelm@18767
   215
  let
wenzelm@18781
   216
    val name' = if name = "" then "axiom_" ^ string_of_int (serial ()) else name;
wenzelm@18767
   217
    val frees = rev ([] |> Term.add_frees prop |> fold Term.add_frees hyps);
wenzelm@18767
   218
    val prop' = Term.list_all_free (frees, Logic.list_implies (hyps, prop));
wenzelm@18767
   219
    val thy' = thy |> Theory.add_axioms_i [(name', prop')];
wenzelm@18781
   220
wenzelm@18781
   221
    val cert = Thm.cterm_of thy';
wenzelm@18781
   222
    fun all_polymorphic (x, T) th =
wenzelm@18781
   223
      let val var = cert (Var ((x, 0), #1 (Logic.dest_all (Thm.prop_of th))))
wenzelm@18781
   224
      in ((var, cert (Free (x, T))), Thm.forall_elim var th) end;
wenzelm@18781
   225
    fun implies_polymorphic hyp th = Thm.assume (cert hyp) COMP th;
wenzelm@18767
   226
    val th =
wenzelm@18767
   227
      Thm.get_axiom_i thy' (Sign.full_name thy' name')
wenzelm@18781
   228
      |> fold_map all_polymorphic frees |-> Drule.cterm_instantiate
wenzelm@18781
   229
      |> fold implies_polymorphic hyps
wenzelm@18767
   230
  in (th, thy') end;
wenzelm@18767
   231
wenzelm@18781
   232
in
wenzelm@18781
   233
wenzelm@18805
   234
fun axioms_finish finish = fold_map (fn ((name, atts), props) =>
wenzelm@18805
   235
  fold ProofContext.fix_frees props
wenzelm@18805
   236
  #> (fn ctxt => ctxt
wenzelm@18805
   237
    |> theory_result (fold_map (add_axiom (hyps_of ctxt)) (PureThy.name_multi name props))
wenzelm@18805
   238
    |-> (fn ths => note ((name, atts), map (finish ctxt) ths))));
wenzelm@18805
   239
wenzelm@18805
   240
val axioms = axioms_finish (K I);
wenzelm@18744
   241
wenzelm@18744
   242
end;
wenzelm@18781
   243
wenzelm@18781
   244
wenzelm@18805
   245
(* constant definitions *)
wenzelm@18781
   246
wenzelm@18781
   247
local
wenzelm@18781
   248
wenzelm@18805
   249
fun add_def (name, prop) =
wenzelm@18805
   250
  Theory.add_defs_i false [(name, prop)] #> (fn thy =>
wenzelm@18805
   251
    let
wenzelm@18805
   252
      val th = Thm.get_axiom_i thy (Sign.full_name thy name);
wenzelm@18805
   253
      val cert = Thm.cterm_of thy;
wenzelm@18805
   254
      val subst = map2 (fn var => fn free => (cert (Var var), cert (Free free)))
wenzelm@18805
   255
        (Term.add_vars (Thm.prop_of th) []) (Term.add_frees prop []);
wenzelm@18805
   256
    in (Drule.cterm_instantiate subst th, thy) end);
wenzelm@18781
   257
wenzelm@18781
   258
in
wenzelm@18781
   259
wenzelm@18805
   260
fun def_finish finish (var, spec) ctxt =
wenzelm@18781
   261
  let
wenzelm@18781
   262
    val (x, mx) = var;
wenzelm@18781
   263
    val ((name, atts), rhs) = spec;
wenzelm@18781
   264
    val name' = if name = "" then Thm.def_name x else name;
wenzelm@18876
   265
    val rhs_frees = Term.add_frees rhs [];
wenzelm@18781
   266
  in
wenzelm@18781
   267
    ctxt
wenzelm@18876
   268
    |> consts_restricted (member (op =) rhs_frees) [((x, Term.fastype_of rhs), mx)]
wenzelm@18781
   269
    |-> (fn [lhs] =>
wenzelm@18781
   270
      theory_result (add_def (name', Logic.mk_equals (lhs, rhs)))
wenzelm@18781
   271
      #-> (fn th => fn ctxt' => note ((name', atts), [finish ctxt' lhs th]) ctxt')
wenzelm@18781
   272
      #> apfst (fn (b, [th]) => (lhs, (b, th))))
wenzelm@18781
   273
  end;
wenzelm@18781
   274
wenzelm@18805
   275
val def = def_finish (K (K I));
wenzelm@18805
   276
wenzelm@18781
   277
end;
wenzelm@18781
   278
wenzelm@18781
   279
end;