src/Pure/variable.ML
author wenzelm
Mon Mar 10 15:04:01 2014 +0100 (2014-03-10)
changeset 56026 893fe12639bc
parent 56025 d74fed45fa8b
child 58668 1891f17c6124
permissions -rw-r--r--
tuned signature -- prefer Name_Space.get with its builtin error;
wenzelm@19899
     1
(*  Title:      Pure/variable.ML
wenzelm@19899
     2
    Author:     Makarius
wenzelm@19899
     3
wenzelm@19899
     4
Fixed type/term variables and polymorphic term abbreviations.
wenzelm@19899
     5
*)
wenzelm@19899
     6
wenzelm@19899
     7
signature VARIABLE =
wenzelm@19899
     8
sig
wenzelm@20303
     9
  val is_body: Proof.context -> bool
wenzelm@20303
    10
  val set_body: bool -> Proof.context -> Proof.context
wenzelm@20303
    11
  val restore_body: Proof.context -> Proof.context -> Proof.context
wenzelm@20303
    12
  val names_of: Proof.context -> Name.context
wenzelm@20303
    13
  val binds_of: Proof.context -> (typ * term) Vartab.table
wenzelm@24765
    14
  val maxidx_of: Proof.context -> int
wenzelm@28625
    15
  val sorts_of: Proof.context -> sort list
wenzelm@20303
    16
  val constraints_of: Proof.context -> typ Vartab.table * sort Vartab.table
wenzelm@20303
    17
  val is_declared: Proof.context -> string -> bool
wenzelm@42494
    18
  val check_name: binding -> string
wenzelm@20303
    19
  val default_type: Proof.context -> string -> typ option
wenzelm@20303
    20
  val def_type: Proof.context -> bool -> indexname -> typ option
wenzelm@20303
    21
  val def_sort: Proof.context -> indexname -> sort option
wenzelm@27280
    22
  val declare_names: term -> Proof.context -> Proof.context
wenzelm@20303
    23
  val declare_constraints: term -> Proof.context -> Proof.context
wenzelm@20303
    24
  val declare_term: term -> Proof.context -> Proof.context
wenzelm@27280
    25
  val declare_typ: typ -> Proof.context -> Proof.context
wenzelm@20303
    26
  val declare_prf: Proofterm.proof -> Proof.context -> Proof.context
wenzelm@20303
    27
  val declare_thm: thm -> Proof.context -> Proof.context
wenzelm@36603
    28
  val global_thm_context: thm -> Proof.context
wenzelm@20303
    29
  val variant_frees: Proof.context -> term list -> (string * 'a) list -> (string * 'a) list
wenzelm@30756
    30
  val bind_term: indexname * term option -> Proof.context -> Proof.context
wenzelm@20303
    31
  val expand_binds: Proof.context -> term -> term
wenzelm@25325
    32
  val lookup_const: Proof.context -> string -> string option
wenzelm@25316
    33
  val is_const: Proof.context -> string -> bool
wenzelm@25325
    34
  val declare_const: string * string -> Proof.context -> Proof.context
wenzelm@55635
    35
  val next_bound: string * typ -> Proof.context -> term * Proof.context
wenzelm@55014
    36
  val revert_bounds: Proof.context -> term -> term
wenzelm@42488
    37
  val is_fixed: Proof.context -> string -> bool
wenzelm@42488
    38
  val newly_fixed: Proof.context -> Proof.context -> string -> bool
wenzelm@42493
    39
  val fixed_ord: Proof.context -> string * string -> order
wenzelm@42488
    40
  val intern_fixed: Proof.context -> string -> string
wenzelm@42493
    41
  val markup_fixed: Proof.context -> string -> Markup.T
wenzelm@42488
    42
  val lookup_fixed: Proof.context -> string -> string option
wenzelm@42488
    43
  val revert_fixed: Proof.context -> string -> string
wenzelm@42482
    44
  val add_fixed_names: Proof.context -> term -> string list -> string list
wenzelm@42482
    45
  val add_fixed: Proof.context -> term -> (string * typ) list -> (string * typ) list
wenzelm@42482
    46
  val add_free_names: Proof.context -> term -> string list -> string list
wenzelm@42482
    47
  val add_frees: Proof.context -> term -> (string * typ) list -> (string * typ) list
wenzelm@42488
    48
  val add_fixes_binding: binding list -> Proof.context -> string list * Proof.context
wenzelm@20303
    49
  val add_fixes: string list -> Proof.context -> string list * Proof.context
wenzelm@20303
    50
  val add_fixes_direct: string list -> Proof.context -> Proof.context
wenzelm@21369
    51
  val auto_fixes: term -> Proof.context -> Proof.context
wenzelm@20797
    52
  val variant_fixes: string list -> Proof.context -> string list * Proof.context
wenzelm@42488
    53
  val dest_fixes: Proof.context -> (string * string) list
wenzelm@20303
    54
  val invent_types: sort list -> Proof.context -> (string * sort) list * Proof.context
wenzelm@20303
    55
  val export_terms: Proof.context -> Proof.context -> term list -> term list
wenzelm@20303
    56
  val exportT_terms: Proof.context -> Proof.context -> term list -> term list
wenzelm@20303
    57
  val exportT: Proof.context -> Proof.context -> thm list -> thm list
wenzelm@20303
    58
  val export_prf: Proof.context -> Proof.context -> Proofterm.proof -> Proofterm.proof
wenzelm@20303
    59
  val export: Proof.context -> Proof.context -> thm list -> thm list
wenzelm@21522
    60
  val export_morphism: Proof.context -> Proof.context -> morphism
wenzelm@20303
    61
  val importT_inst: term list -> Proof.context -> ((indexname * sort) * typ) list * Proof.context
wenzelm@20303
    62
  val import_inst: bool -> term list -> Proof.context ->
wenzelm@20303
    63
    (((indexname * sort) * typ) list * ((indexname * typ) * term) list) * Proof.context
wenzelm@20303
    64
  val importT_terms: term list -> Proof.context -> term list * Proof.context
wenzelm@20303
    65
  val import_terms: bool -> term list -> Proof.context -> term list * Proof.context
wenzelm@32280
    66
  val importT: thm list -> Proof.context -> ((ctyp * ctyp) list * thm list) * Proof.context
wenzelm@20303
    67
  val import_prf: bool -> Proofterm.proof -> Proof.context -> Proofterm.proof * Proof.context
wenzelm@31794
    68
  val import: bool -> thm list -> Proof.context ->
wenzelm@32280
    69
    (((ctyp * ctyp) list * (cterm * cterm) list) * thm list) * Proof.context
wenzelm@21287
    70
  val tradeT: (Proof.context -> thm list -> thm list) -> Proof.context -> thm list -> thm list
wenzelm@21287
    71
  val trade: (Proof.context -> thm list -> thm list) -> Proof.context -> thm list -> thm list
wenzelm@42495
    72
  val focus: term -> Proof.context -> ((string * (string * typ)) list * term) * Proof.context
wenzelm@42495
    73
  val focus_cterm: cterm -> Proof.context -> ((string * cterm) list * cterm) * Proof.context
wenzelm@32199
    74
  val focus_subgoal: int -> thm -> Proof.context -> ((string * cterm) list * cterm) * Proof.context
wenzelm@20303
    75
  val warn_extra_tfrees: Proof.context -> Proof.context -> unit
wenzelm@24694
    76
  val polymorphic_types: Proof.context -> term list -> (indexname * sort) list * term list
wenzelm@20303
    77
  val polymorphic: Proof.context -> term list -> term list
wenzelm@19899
    78
end;
wenzelm@19899
    79
wenzelm@19899
    80
structure Variable: VARIABLE =
wenzelm@19899
    81
struct
wenzelm@19899
    82
wenzelm@19899
    83
(** local context data **)
wenzelm@19899
    84
wenzelm@42488
    85
type fixes = string Name_Space.table;
wenzelm@50201
    86
val empty_fixes: fixes = Name_Space.empty_table Markup.fixedN;
wenzelm@42488
    87
wenzelm@19899
    88
datatype data = Data of
wenzelm@20102
    89
 {is_body: bool,                        (*inner body mode*)
wenzelm@20162
    90
  names: Name.context,                  (*type/term variable names*)
wenzelm@25325
    91
  consts: string Symtab.table,          (*consts within the local scope*)
wenzelm@55014
    92
  bounds: int * ((string * typ) * string) list,  (*next index, internal name, type, external name*)
wenzelm@42488
    93
  fixes: fixes,                         (*term fixes -- global name space, intern ~> extern*)
wenzelm@20102
    94
  binds: (typ * term) Vartab.table,     (*term bindings*)
wenzelm@20162
    95
  type_occs: string list Symtab.table,  (*type variables -- possibly within term variables*)
wenzelm@24765
    96
  maxidx: int,                          (*maximum var index*)
wenzelm@40124
    97
  sorts: sort Ord_List.T,               (*declared sort occurrences*)
wenzelm@20162
    98
  constraints:
wenzelm@20102
    99
    typ Vartab.table *                  (*type constraints*)
wenzelm@20162
   100
    sort Vartab.table};                 (*default sorts*)
wenzelm@19899
   101
wenzelm@55014
   102
fun make_data
wenzelm@55014
   103
    (is_body, names, consts, bounds, fixes, binds, type_occs, maxidx, sorts, constraints) =
wenzelm@55014
   104
  Data {is_body = is_body, names = names, consts = consts, bounds = bounds, fixes = fixes,
wenzelm@55014
   105
    binds = binds, type_occs = type_occs, maxidx = maxidx, sorts = sorts, constraints = constraints};
wenzelm@19899
   106
wenzelm@33519
   107
structure Data = Proof_Data
wenzelm@19899
   108
(
wenzelm@19899
   109
  type T = data;
wenzelm@32784
   110
  fun init _ =
wenzelm@55014
   111
    make_data (false, Name.context, Symtab.empty, (0, []), empty_fixes, Vartab.empty,
wenzelm@42488
   112
      Symtab.empty, ~1, [], (Vartab.empty, Vartab.empty));
wenzelm@19899
   113
);
wenzelm@19899
   114
wenzelm@19899
   115
fun map_data f =
wenzelm@55014
   116
  Data.map (fn
wenzelm@55014
   117
      Data {is_body, names, consts, bounds, fixes, binds, type_occs, maxidx, sorts, constraints} =>
wenzelm@55014
   118
    make_data
wenzelm@55014
   119
      (f (is_body, names, consts, bounds, fixes, binds, type_occs, maxidx, sorts, constraints)));
wenzelm@25316
   120
wenzelm@25316
   121
fun map_names f =
wenzelm@55014
   122
  map_data (fn
wenzelm@55014
   123
      (is_body, names, consts, bounds, fixes, binds, type_occs, maxidx, sorts, constraints) =>
wenzelm@55014
   124
    (is_body, f names, consts, bounds, fixes, binds, type_occs, maxidx, sorts, constraints));
wenzelm@19899
   125
wenzelm@25325
   126
fun map_consts f =
wenzelm@55014
   127
  map_data (fn
wenzelm@55014
   128
      (is_body, names, consts, bounds, fixes, binds, type_occs, maxidx, sorts, constraints) =>
wenzelm@55014
   129
    (is_body, names, f consts, bounds, fixes, binds, type_occs, maxidx, sorts, constraints));
wenzelm@55014
   130
wenzelm@55014
   131
fun map_bounds f =
wenzelm@55014
   132
  map_data (fn
wenzelm@55014
   133
      (is_body, names, consts, bounds, fixes, binds, type_occs, maxidx, sorts, constraints) =>
wenzelm@55014
   134
    (is_body, names, consts, f bounds, fixes, binds, type_occs, maxidx, sorts, constraints));
wenzelm@20162
   135
wenzelm@25316
   136
fun map_fixes f =
wenzelm@55014
   137
  map_data (fn
wenzelm@55014
   138
      (is_body, names, consts, bounds, fixes, binds, type_occs, maxidx, sorts, constraints) =>
wenzelm@55014
   139
    (is_body, names, consts, bounds, f fixes, binds, type_occs, maxidx, sorts, constraints));
wenzelm@19899
   140
wenzelm@25316
   141
fun map_binds f =
wenzelm@55014
   142
  map_data (fn
wenzelm@55014
   143
      (is_body, names, consts, bounds, fixes, binds, type_occs, maxidx, sorts, constraints) =>
wenzelm@55014
   144
    (is_body, names, consts, bounds, fixes, f binds, type_occs, maxidx, sorts, constraints));
wenzelm@24765
   145
wenzelm@25316
   146
fun map_type_occs f =
wenzelm@55014
   147
  map_data (fn
wenzelm@55014
   148
      (is_body, names, consts, bounds, fixes, binds, type_occs, maxidx, sorts, constraints) =>
wenzelm@55014
   149
    (is_body, names, consts, bounds, fixes, binds, f type_occs, maxidx, sorts, constraints));
wenzelm@19899
   150
wenzelm@25316
   151
fun map_maxidx f =
wenzelm@55014
   152
  map_data (fn
wenzelm@55014
   153
      (is_body, names, consts, bounds, fixes, binds, type_occs, maxidx, sorts, constraints) =>
wenzelm@55014
   154
    (is_body, names, consts, bounds, fixes, binds, type_occs, f maxidx, sorts, constraints));
wenzelm@28625
   155
wenzelm@28625
   156
fun map_sorts f =
wenzelm@55014
   157
  map_data (fn
wenzelm@55014
   158
      (is_body, names, consts, bounds, fixes, binds, type_occs, maxidx, sorts, constraints) =>
wenzelm@55014
   159
    (is_body, names, consts, bounds, fixes, binds, type_occs, maxidx, f sorts, constraints));
wenzelm@20102
   160
wenzelm@25316
   161
fun map_constraints f =
wenzelm@55014
   162
  map_data (fn
wenzelm@55014
   163
      (is_body, names, consts, bounds, fixes, binds, type_occs, maxidx, sorts, constraints) =>
wenzelm@55014
   164
    (is_body, names, consts, bounds, fixes, binds, type_occs, maxidx, sorts, f constraints));
wenzelm@19899
   165
wenzelm@45650
   166
fun rep_data ctxt = Data.get ctxt |> (fn Data rep => rep);
wenzelm@19899
   167
wenzelm@19899
   168
val is_body = #is_body o rep_data;
wenzelm@24765
   169
wenzelm@28625
   170
fun set_body b =
wenzelm@55014
   171
  map_data (fn (_, names, consts, bounds, fixes, binds, type_occs, maxidx, sorts, constraints) =>
wenzelm@55014
   172
    (b, names, consts, bounds, fixes, binds, type_occs, maxidx, sorts, constraints));
wenzelm@24765
   173
wenzelm@19899
   174
fun restore_body ctxt = set_body (is_body ctxt);
wenzelm@19899
   175
wenzelm@20102
   176
val names_of = #names o rep_data;
wenzelm@20102
   177
val fixes_of = #fixes o rep_data;
wenzelm@56025
   178
val fixes_space = Name_Space.space_of_table o fixes_of;
wenzelm@19899
   179
val binds_of = #binds o rep_data;
wenzelm@20162
   180
val type_occs_of = #type_occs o rep_data;
wenzelm@24765
   181
val maxidx_of = #maxidx o rep_data;
wenzelm@28625
   182
val sorts_of = #sorts o rep_data;
wenzelm@20162
   183
val constraints_of = #constraints o rep_data;
wenzelm@19899
   184
wenzelm@20162
   185
val is_declared = Name.is_declared o names_of;
wenzelm@19899
   186
wenzelm@47021
   187
val check_name = Name_Space.base_name o tap Binding.check;
wenzelm@42357
   188
wenzelm@19899
   189
wenzelm@19899
   190
wenzelm@19899
   191
(** declarations **)
wenzelm@19899
   192
wenzelm@19899
   193
(* default sorts and types *)
wenzelm@19899
   194
wenzelm@20162
   195
fun default_type ctxt x = Vartab.lookup (#1 (constraints_of ctxt)) (x, ~1);
wenzelm@19899
   196
wenzelm@19899
   197
fun def_type ctxt pattern xi =
wenzelm@20162
   198
  let val {binds, constraints = (types, _), ...} = rep_data ctxt in
wenzelm@19899
   199
    (case Vartab.lookup types xi of
wenzelm@19899
   200
      NONE =>
wenzelm@19899
   201
        if pattern then NONE
wenzelm@39290
   202
        else Vartab.lookup binds xi |> Option.map (Type.mark_polymorphic o #1)
wenzelm@19899
   203
    | some => some)
wenzelm@19899
   204
  end;
wenzelm@19899
   205
wenzelm@20162
   206
val def_sort = Vartab.lookup o #2 o constraints_of;
wenzelm@20162
   207
wenzelm@20162
   208
wenzelm@20162
   209
(* names *)
wenzelm@20162
   210
wenzelm@24765
   211
fun declare_type_names t =
wenzelm@29279
   212
  map_names (fold_types (fold_atyps Term.declare_typ_names) t) #>
wenzelm@24765
   213
  map_maxidx (fold_types Term.maxidx_typ t);
wenzelm@20162
   214
wenzelm@20162
   215
fun declare_names t =
wenzelm@20162
   216
  declare_type_names t #>
wenzelm@29279
   217
  map_names (fold_aterms Term.declare_term_frees t) #>
wenzelm@24765
   218
  map_maxidx (Term.maxidx_term t);
wenzelm@20162
   219
wenzelm@20162
   220
wenzelm@20162
   221
(* type occurrences *)
wenzelm@20162
   222
wenzelm@24719
   223
fun decl_type_occsT T = fold_atyps (fn TFree (a, _) => Symtab.default (a, []) | _ => I) T;
wenzelm@24719
   224
wenzelm@22671
   225
val decl_type_occs = fold_term_types
wenzelm@20162
   226
  (fn Free (x, _) => fold_atyps (fn TFree (a, _) => Symtab.insert_list (op =) (a, x) | _ => I)
wenzelm@24719
   227
    | _ => decl_type_occsT);
wenzelm@19899
   228
wenzelm@24719
   229
val declare_type_occsT = map_type_occs o fold_types decl_type_occsT;
wenzelm@22671
   230
val declare_type_occs = map_type_occs o decl_type_occs;
wenzelm@22671
   231
wenzelm@19899
   232
wenzelm@20162
   233
(* constraints *)
wenzelm@19899
   234
wenzelm@49685
   235
fun constrain_tvar (xi, raw_S) =
wenzelm@49688
   236
  let val S = #2 (Term_Position.decode_positionS raw_S)
wenzelm@49685
   237
  in if S = dummyS then Vartab.delete_safe xi else Vartab.update (xi, S) end;
wenzelm@21355
   238
wenzelm@20162
   239
fun declare_constraints t = map_constraints (fn (types, sorts) =>
wenzelm@20162
   240
  let
wenzelm@20162
   241
    val types' = fold_aterms
wenzelm@20162
   242
      (fn Free (x, T) => Vartab.update ((x, ~1), T)
wenzelm@20162
   243
        | Var v => Vartab.update v
wenzelm@20162
   244
        | _ => I) t types;
wenzelm@45426
   245
    val sorts' = (fold_types o fold_atyps)
wenzelm@21355
   246
      (fn TFree (x, S) => constrain_tvar ((x, ~1), S)
wenzelm@21355
   247
        | TVar v => constrain_tvar v
wenzelm@45426
   248
        | _ => I) t sorts;
wenzelm@20162
   249
  in (types', sorts') end)
wenzelm@24719
   250
  #> declare_type_occsT t
wenzelm@22711
   251
  #> declare_type_names t;
wenzelm@19899
   252
wenzelm@20162
   253
wenzelm@20162
   254
(* common declarations *)
wenzelm@20162
   255
wenzelm@20162
   256
fun declare_internal t =
wenzelm@20162
   257
  declare_names t #>
wenzelm@28625
   258
  declare_type_occs t #>
wenzelm@28625
   259
  map_sorts (Sorts.insert_term t);
wenzelm@19911
   260
wenzelm@20162
   261
fun declare_term t =
wenzelm@20162
   262
  declare_internal t #>
wenzelm@20162
   263
  declare_constraints t;
wenzelm@19899
   264
wenzelm@27280
   265
val declare_typ = declare_term o Logic.mk_type;
wenzelm@27280
   266
wenzelm@20303
   267
val declare_prf = Proofterm.fold_proof_terms declare_internal (declare_internal o Logic.mk_type);
wenzelm@20303
   268
wenzelm@22691
   269
val declare_thm = Thm.fold_terms declare_internal;
wenzelm@42360
   270
fun global_thm_context th = declare_thm th (Proof_Context.init_global (Thm.theory_of_thm th));
wenzelm@19899
   271
wenzelm@19899
   272
wenzelm@19899
   273
(* renaming term/type frees *)
wenzelm@19899
   274
wenzelm@20162
   275
fun variant_frees ctxt ts frees =
wenzelm@19899
   276
  let
wenzelm@20162
   277
    val names = names_of (fold declare_names ts ctxt);
wenzelm@43326
   278
    val xs = fst (fold_map Name.variant (map #1 frees) names);
wenzelm@20084
   279
  in xs ~~ map snd frees end;
wenzelm@19899
   280
wenzelm@19899
   281
wenzelm@19899
   282
wenzelm@20303
   283
(** term bindings **)
wenzelm@20303
   284
wenzelm@30756
   285
fun bind_term (xi, NONE) = map_binds (Vartab.delete_safe xi)
wenzelm@30756
   286
  | bind_term ((x, i), SOME t) =
wenzelm@20303
   287
      let
wenzelm@25051
   288
        val u = Term.close_schematic_term t;
wenzelm@25051
   289
        val U = Term.fastype_of u;
wenzelm@25051
   290
      in declare_term u #> map_binds (Vartab.update ((x, i), (U, u))) end;
wenzelm@20303
   291
wenzelm@20303
   292
fun expand_binds ctxt =
wenzelm@20303
   293
  let
wenzelm@20303
   294
    val binds = binds_of ctxt;
wenzelm@21799
   295
    val get = fn Var (xi, _) => Vartab.lookup binds xi | _ => NONE;
wenzelm@21799
   296
  in Envir.beta_norm o Envir.expand_term get end;
wenzelm@20303
   297
wenzelm@20303
   298
wenzelm@20303
   299
wenzelm@25325
   300
(** consts **)
wenzelm@25316
   301
wenzelm@25325
   302
val lookup_const = Symtab.lookup o #consts o rep_data;
wenzelm@25325
   303
val is_const = is_some oo lookup_const;
wenzelm@25316
   304
wenzelm@25325
   305
val declare_fixed = map_consts o Symtab.delete_safe;
wenzelm@25325
   306
val declare_const = map_consts o Symtab.update;
wenzelm@25316
   307
wenzelm@25316
   308
wenzelm@25316
   309
wenzelm@55014
   310
(** bounds **)
wenzelm@55014
   311
wenzelm@55014
   312
fun next_bound (a, T) ctxt =
wenzelm@55014
   313
  let
wenzelm@55014
   314
    val b = Name.bound (#1 (#bounds (rep_data ctxt)));
wenzelm@55014
   315
    val ctxt' = ctxt |> map_bounds (fn (next, bounds) => (next + 1, ((b, T), a) :: bounds));
wenzelm@55635
   316
  in (Free (b, T), ctxt') end;
wenzelm@55014
   317
wenzelm@55014
   318
fun revert_bounds ctxt t =
wenzelm@55014
   319
  (case #2 (#bounds (rep_data ctxt)) of
wenzelm@55014
   320
    [] => t
wenzelm@55014
   321
  | bounds =>
wenzelm@55014
   322
      let
wenzelm@55014
   323
        val names = Term.declare_term_names t (names_of ctxt);
wenzelm@55014
   324
        val xs = rev (#1 (fold_map Name.variant (rev (map #2 bounds)) names));
wenzelm@55014
   325
        fun subst ((b, T), _) x' = (Free (b, T), Syntax_Trans.mark_bound_abs (x', T));
wenzelm@55014
   326
      in Term.subst_atomic (map2 subst bounds xs) t end);
wenzelm@55014
   327
wenzelm@55014
   328
wenzelm@55014
   329
wenzelm@19911
   330
(** fixes **)
wenzelm@19911
   331
wenzelm@42488
   332
(* specialized name space *)
wenzelm@42488
   333
wenzelm@46869
   334
val is_fixed = Name_Space.defined_entry o fixes_space;
wenzelm@46869
   335
fun newly_fixed inner outer = is_fixed inner andf (not o is_fixed outer);
wenzelm@42488
   336
wenzelm@42493
   337
val fixed_ord = Name_Space.entry_ord o fixes_space;
wenzelm@42493
   338
val intern_fixed = Name_Space.intern o fixes_space;
wenzelm@42488
   339
wenzelm@42488
   340
fun lookup_fixed ctxt x =
wenzelm@42488
   341
  let val x' = intern_fixed ctxt x
wenzelm@42488
   342
  in if is_fixed ctxt x' then SOME x' else NONE end;
wenzelm@42488
   343
wenzelm@42488
   344
fun revert_fixed ctxt x =
wenzelm@56025
   345
  (case Name_Space.lookup_key (fixes_of ctxt) x of
wenzelm@56025
   346
    SOME (_, x') => if intern_fixed ctxt x' = x then x' else x
wenzelm@42488
   347
  | NONE => x);
wenzelm@42488
   348
wenzelm@45472
   349
fun markup_fixed ctxt x =
wenzelm@45472
   350
  Name_Space.markup (fixes_space ctxt) x
wenzelm@45472
   351
  |> Markup.name (revert_fixed ctxt x);
wenzelm@45472
   352
wenzelm@42488
   353
fun dest_fixes ctxt =
wenzelm@56025
   354
  Name_Space.fold_table (fn (x, y) => cons (y, x)) (fixes_of ctxt) []
wenzelm@56025
   355
  |> sort (Name_Space.entry_ord (fixes_space ctxt) o pairself #2);
wenzelm@42488
   356
wenzelm@42488
   357
wenzelm@42482
   358
(* collect variables *)
wenzelm@42482
   359
wenzelm@42482
   360
fun add_free_names ctxt =
wenzelm@42482
   361
  fold_aterms (fn Free (x, _) => not (is_fixed ctxt x) ? insert (op =) x | _ => I);
wenzelm@42482
   362
wenzelm@42482
   363
fun add_frees ctxt =
wenzelm@42482
   364
  fold_aterms (fn Free (x, T) => not (is_fixed ctxt x) ? insert (op =) (x, T) | _ => I);
wenzelm@42482
   365
wenzelm@42482
   366
fun add_fixed_names ctxt =
wenzelm@42482
   367
  fold_aterms (fn Free (x, _) => is_fixed ctxt x ? insert (op =) x | _ => I);
wenzelm@42482
   368
wenzelm@42482
   369
fun add_fixed ctxt =
wenzelm@42482
   370
  fold_aterms (fn Free (x, T) => is_fixed ctxt x ? insert (op =) (x, T) | _ => I);
wenzelm@42482
   371
wenzelm@42482
   372
wenzelm@42482
   373
(* declarations *)
wenzelm@42482
   374
wenzelm@20084
   375
local
wenzelm@20084
   376
wenzelm@42488
   377
fun err_dups dups =
wenzelm@42488
   378
  error ("Duplicate fixed variable(s): " ^ commas (map Binding.print dups));
wenzelm@19911
   379
wenzelm@42488
   380
fun new_fixed ((x, x'), pos) ctxt =
wenzelm@42488
   381
  if is_some (lookup_fixed ctxt x') then err_dups [Binding.make (x, pos)]
wenzelm@42488
   382
  else
wenzelm@47005
   383
    let val context = Context.Proof ctxt |> Name_Space.map_naming (K Name_Space.default_naming) in
wenzelm@47005
   384
      ctxt
wenzelm@47005
   385
      |> map_fixes
wenzelm@56025
   386
        (Name_Space.define context true (Binding.make (x', pos), x) #> snd #>
wenzelm@56025
   387
          Name_Space.alias_table Name_Space.default_naming (Binding.make (x, pos)) x')
wenzelm@47005
   388
      |> declare_fixed x
wenzelm@47005
   389
      |> declare_constraints (Syntax.free x')
wenzelm@47005
   390
  end;
wenzelm@42488
   391
wenzelm@42488
   392
fun new_fixes names' xs xs' ps =
wenzelm@20102
   393
  map_names (K names') #>
wenzelm@42488
   394
  fold new_fixed ((xs ~~ xs') ~~ ps) #>
wenzelm@20084
   395
  pair xs';
wenzelm@20084
   396
wenzelm@20084
   397
in
wenzelm@20084
   398
wenzelm@42488
   399
fun add_fixes_binding bs ctxt =
wenzelm@19911
   400
  let
wenzelm@19911
   401
    val _ =
wenzelm@55948
   402
      (case filter (Name.is_skolem o Binding.name_of) bs of
wenzelm@42488
   403
        [] => ()
wenzelm@42488
   404
      | bads => error ("Illegal internal Skolem constant(s): " ^ commas (map Binding.print bads)));
wenzelm@42488
   405
    val _ =
wenzelm@42488
   406
      (case duplicates (op = o pairself Binding.name_of) bs of
wenzelm@42488
   407
        [] => ()
wenzelm@42488
   408
      | dups => err_dups dups);
wenzelm@42488
   409
wenzelm@42494
   410
    val xs = map check_name bs;
wenzelm@20102
   411
    val names = names_of ctxt;
wenzelm@20084
   412
    val (xs', names') =
wenzelm@43326
   413
      if is_body ctxt then fold_map Name.variant xs names |>> map Name.skolem
wenzelm@42488
   414
      else (xs, fold Name.declare xs names);
wenzelm@42488
   415
  in ctxt |> new_fixes names' xs xs' (map Binding.pos_of bs) end;
wenzelm@19911
   416
wenzelm@20797
   417
fun variant_fixes raw_xs ctxt =
wenzelm@20084
   418
  let
wenzelm@20102
   419
    val names = names_of ctxt;
wenzelm@55948
   420
    val xs = map (fn x => Name.clean x |> Name.is_internal x ? Name.internal) raw_xs;
wenzelm@43326
   421
    val (xs', names') = fold_map Name.variant xs names |>> (is_body ctxt ? map Name.skolem);
wenzelm@42488
   422
  in ctxt |> new_fixes names' xs xs' (replicate (length xs) Position.none) end;
wenzelm@20084
   423
wenzelm@20084
   424
end;
wenzelm@19911
   425
wenzelm@42488
   426
val add_fixes = add_fixes_binding o map Binding.name;
wenzelm@20251
   427
wenzelm@20251
   428
fun add_fixes_direct xs ctxt = ctxt
wenzelm@20251
   429
  |> set_body false
wenzelm@20251
   430
  |> (snd o add_fixes xs)
wenzelm@20251
   431
  |> restore_body ctxt;
wenzelm@20251
   432
wenzelm@42482
   433
fun auto_fixes t ctxt = ctxt
wenzelm@42482
   434
  |> not (is_body ctxt) ? add_fixes_direct (rev (add_free_names ctxt t []))
wenzelm@20251
   435
  |> declare_term t;
wenzelm@20251
   436
wenzelm@19911
   437
fun invent_types Ss ctxt =
wenzelm@19911
   438
  let
wenzelm@43329
   439
    val tfrees = Name.invent (names_of ctxt) Name.aT (length Ss) ~~ Ss;
wenzelm@20162
   440
    val ctxt' = fold (declare_constraints o Logic.mk_type o TFree) tfrees ctxt;
wenzelm@19911
   441
  in (tfrees, ctxt') end;
wenzelm@19911
   442
wenzelm@19911
   443
wenzelm@19911
   444
wenzelm@22671
   445
(** export -- generalize type/term variables (beware of closure sizes) **)
wenzelm@19911
   446
wenzelm@19911
   447
fun export_inst inner outer =
wenzelm@19911
   448
  let
wenzelm@20162
   449
    val declared_outer = is_declared outer;
wenzelm@46869
   450
    val still_fixed = not o newly_fixed inner outer;
wenzelm@19911
   451
wenzelm@42488
   452
    val gen_fixes =
wenzelm@56025
   453
      Name_Space.fold_table (fn (y, _) => not (is_fixed outer y) ? cons y)
wenzelm@56025
   454
        (fixes_of inner) [];
wenzelm@22671
   455
wenzelm@22671
   456
    val type_occs_inner = type_occs_of inner;
wenzelm@22671
   457
    fun gen_fixesT ts =
wenzelm@19911
   458
      Symtab.fold (fn (a, xs) =>
wenzelm@20162
   459
        if declared_outer a orelse exists still_fixed xs
wenzelm@22671
   460
        then I else cons a) (fold decl_type_occs ts type_occs_inner) [];
wenzelm@19911
   461
  in (gen_fixesT, gen_fixes) end;
wenzelm@19911
   462
wenzelm@19911
   463
fun exportT_inst inner outer = #1 (export_inst inner outer);
wenzelm@19911
   464
wenzelm@22671
   465
fun exportT_terms inner outer =
wenzelm@22671
   466
  let val mk_tfrees = exportT_inst inner outer in
wenzelm@22671
   467
    fn ts => ts |> map
wenzelm@31977
   468
      (Term_Subst.generalize (mk_tfrees ts, [])
wenzelm@22671
   469
        (fold (Term.fold_types Term.maxidx_typ) ts ~1 + 1))
wenzelm@22671
   470
  end;
wenzelm@19911
   471
wenzelm@22671
   472
fun export_terms inner outer =
wenzelm@22671
   473
  let val (mk_tfrees, tfrees) = export_inst inner outer in
wenzelm@22671
   474
    fn ts => ts |> map
wenzelm@31977
   475
      (Term_Subst.generalize (mk_tfrees ts, tfrees)
wenzelm@22671
   476
        (fold Term.maxidx_term ts ~1 + 1))
wenzelm@22671
   477
  end;
wenzelm@19911
   478
wenzelm@20303
   479
fun export_prf inner outer prf =
wenzelm@20303
   480
  let
wenzelm@22671
   481
    val (mk_tfrees, frees) = export_inst (declare_prf prf inner) outer;
wenzelm@22671
   482
    val tfrees = mk_tfrees [];
wenzelm@20303
   483
    val idx = Proofterm.maxidx_proof prf ~1 + 1;
wenzelm@36620
   484
    val gen_term = Term_Subst.generalize_same (tfrees, frees) idx;
wenzelm@36620
   485
    val gen_typ = Term_Subst.generalizeT_same tfrees idx;
wenzelm@36620
   486
  in Same.commit (Proofterm.map_proof_terms_same gen_term gen_typ) prf end;
wenzelm@20303
   487
wenzelm@22671
   488
wenzelm@22671
   489
fun gen_export (mk_tfrees, frees) ths =
wenzelm@19911
   490
  let
wenzelm@22671
   491
    val tfrees = mk_tfrees (map Thm.full_prop_of ths);
wenzelm@22671
   492
    val maxidx = fold Thm.maxidx_thm ths ~1;
wenzelm@22671
   493
  in map (Thm.generalize (tfrees, frees) (maxidx + 1)) ths end;
wenzelm@19911
   494
wenzelm@22671
   495
fun exportT inner outer = gen_export (exportT_inst inner outer, []);
wenzelm@22671
   496
fun export inner outer = gen_export (export_inst inner outer);
wenzelm@19911
   497
wenzelm@21522
   498
fun export_morphism inner outer =
wenzelm@21522
   499
  let
wenzelm@21522
   500
    val fact = export inner outer;
wenzelm@21522
   501
    val term = singleton (export_terms inner outer);
wenzelm@21522
   502
    val typ = Logic.type_map term;
wenzelm@54740
   503
  in
wenzelm@54740
   504
    Morphism.morphism "Variable.export" {binding = [], typ = [typ], term = [term], fact = [fact]}
wenzelm@54740
   505
  end;
wenzelm@19911
   506
wenzelm@19911
   507
wenzelm@24765
   508
wenzelm@19911
   509
(** import -- fix schematic type/term variables **)
wenzelm@19911
   510
wenzelm@19911
   511
fun importT_inst ts ctxt =
wenzelm@19911
   512
  let
wenzelm@19911
   513
    val tvars = rev (fold Term.add_tvars ts []);
wenzelm@19911
   514
    val (tfrees, ctxt') = invent_types (map #2 tvars) ctxt;
wenzelm@19911
   515
  in (tvars ~~ map TFree tfrees, ctxt') end;
wenzelm@19911
   516
wenzelm@19911
   517
fun import_inst is_open ts ctxt =
wenzelm@19911
   518
  let
wenzelm@26714
   519
    val ren = Name.clean #> (if is_open then I else Name.internal);
wenzelm@19911
   520
    val (instT, ctxt') = importT_inst ts ctxt;
wenzelm@31977
   521
    val vars = map (apsnd (Term_Subst.instantiateT instT)) (rev (fold Term.add_vars ts []));
wenzelm@20797
   522
    val (xs, ctxt'') = variant_fixes (map (ren o #1 o #1) vars) ctxt';
wenzelm@19911
   523
    val inst = vars ~~ map Free (xs ~~ map #2 vars);
wenzelm@19911
   524
  in ((instT, inst), ctxt'') end;
wenzelm@19911
   525
wenzelm@19911
   526
fun importT_terms ts ctxt =
wenzelm@19911
   527
  let val (instT, ctxt') = importT_inst ts ctxt
wenzelm@31977
   528
  in (map (Term_Subst.instantiate (instT, [])) ts, ctxt') end;
wenzelm@19911
   529
wenzelm@19911
   530
fun import_terms is_open ts ctxt =
wenzelm@19911
   531
  let val (inst, ctxt') = import_inst is_open ts ctxt
wenzelm@31977
   532
  in (map (Term_Subst.instantiate inst) ts, ctxt') end;
wenzelm@19911
   533
wenzelm@31794
   534
fun importT ths ctxt =
wenzelm@19911
   535
  let
wenzelm@42360
   536
    val thy = Proof_Context.theory_of ctxt;
wenzelm@19911
   537
    val (instT, ctxt') = importT_inst (map Thm.full_prop_of ths) ctxt;
wenzelm@32280
   538
    val insts' as (instT', _) = Thm.certify_inst thy (instT, []);
wenzelm@32280
   539
    val ths' = map (Thm.instantiate insts') ths;
wenzelm@32280
   540
  in ((instT', ths'), ctxt') end;
wenzelm@19911
   541
wenzelm@20303
   542
fun import_prf is_open prf ctxt =
wenzelm@20303
   543
  let
wenzelm@20303
   544
    val ts = rev (Proofterm.fold_proof_terms cons (cons o Logic.mk_type) prf []);
wenzelm@20303
   545
    val (insts, ctxt') = import_inst is_open ts ctxt;
wenzelm@20303
   546
  in (Proofterm.instantiate insts prf, ctxt') end;
wenzelm@20303
   547
wenzelm@31794
   548
fun import is_open ths ctxt =
wenzelm@19911
   549
  let
wenzelm@42360
   550
    val thy = Proof_Context.theory_of ctxt;
wenzelm@32280
   551
    val (insts, ctxt') = import_inst is_open (map Thm.full_prop_of ths) ctxt;
wenzelm@32280
   552
    val insts' = Thm.certify_inst thy insts;
wenzelm@32280
   553
    val ths' = map (Thm.instantiate insts') ths;
wenzelm@32280
   554
  in ((insts', ths'), ctxt') end;
wenzelm@19911
   555
wenzelm@19911
   556
wenzelm@19926
   557
(* import/export *)
wenzelm@19926
   558
wenzelm@21287
   559
fun gen_trade imp exp f ctxt ths =
wenzelm@20220
   560
  let val ((_, ths'), ctxt') = imp ths ctxt
wenzelm@21287
   561
  in exp ctxt' ctxt (f ctxt' ths') end;
wenzelm@19926
   562
wenzelm@31794
   563
val tradeT = gen_trade importT exportT;
wenzelm@31794
   564
val trade = gen_trade (import true) export;
wenzelm@19926
   565
wenzelm@19926
   566
wenzelm@42495
   567
(* focus on outermost parameters: !!x y z. B *)
wenzelm@42495
   568
wenzelm@42495
   569
fun focus_params t ctxt =
wenzelm@42495
   570
  let
wenzelm@42495
   571
    val (xs, Ts) =
wenzelm@42495
   572
      split_list (Term.variant_frees t (Term.strip_all_vars t));  (*as they are printed :-*)
wenzelm@42495
   573
    val (xs', ctxt') = variant_fixes xs ctxt;
wenzelm@42495
   574
    val ps = xs' ~~ Ts;
wenzelm@42495
   575
    val ctxt'' = ctxt' |> fold (declare_constraints o Free) ps;
wenzelm@42495
   576
  in ((xs, ps), ctxt'') end;
wenzelm@42495
   577
wenzelm@42495
   578
fun focus t ctxt =
wenzelm@42495
   579
  let
wenzelm@42495
   580
    val ((xs, ps), ctxt') = focus_params t ctxt;
wenzelm@42495
   581
    val t' = Term.subst_bounds (rev (map Free ps), Term.strip_all_body t);
wenzelm@42495
   582
  in (((xs ~~ ps), t'), ctxt') end;
wenzelm@20149
   583
wenzelm@20149
   584
fun forall_elim_prop t prop =
wenzelm@46497
   585
  Thm.beta_conversion false (Thm.apply (Thm.dest_arg prop) t)
wenzelm@20579
   586
  |> Thm.cprop_of |> Thm.dest_arg;
wenzelm@20149
   587
wenzelm@42495
   588
fun focus_cterm goal ctxt =
wenzelm@20149
   589
  let
wenzelm@20149
   590
    val cert = Thm.cterm_of (Thm.theory_of_cterm goal);
wenzelm@42495
   591
    val ((xs, ps), ctxt') = focus_params (Thm.term_of goal) ctxt;
wenzelm@42495
   592
    val ps' = map (cert o Free) ps;
wenzelm@20220
   593
    val goal' = fold forall_elim_prop ps' goal;
wenzelm@42495
   594
  in ((xs ~~ ps', goal'), ctxt') end;
wenzelm@20149
   595
wenzelm@20303
   596
fun focus_subgoal i st =
wenzelm@20303
   597
  let
wenzelm@22691
   598
    val all_vars = Thm.fold_terms Term.add_vars st [];
wenzelm@20303
   599
    val no_binds = map (fn (xi, _) => (xi, NONE)) all_vars;
wenzelm@20303
   600
  in
wenzelm@30756
   601
    fold bind_term no_binds #>
wenzelm@20303
   602
    fold (declare_constraints o Var) all_vars #>
wenzelm@42495
   603
    focus_cterm (Thm.cprem_of st i)
wenzelm@20303
   604
  end;
wenzelm@20303
   605
wenzelm@20303
   606
wenzelm@19911
   607
wenzelm@19911
   608
(** implicit polymorphism **)
wenzelm@19899
   609
wenzelm@19899
   610
(* warn_extra_tfrees *)
wenzelm@19899
   611
wenzelm@19899
   612
fun warn_extra_tfrees ctxt1 ctxt2 =
wenzelm@19899
   613
  let
wenzelm@19911
   614
    fun occs_typ a = Term.exists_subtype (fn TFree (b, _) => a = b | _ => false);
wenzelm@20162
   615
    fun occs_free a x =
wenzelm@20162
   616
      (case def_type ctxt1 false (x, ~1) of
wenzelm@20162
   617
        SOME T => if occs_typ a T then I else cons (a, x)
wenzelm@20162
   618
      | NONE => cons (a, x));
wenzelm@19899
   619
wenzelm@20162
   620
    val occs1 = type_occs_of ctxt1;
wenzelm@20162
   621
    val occs2 = type_occs_of ctxt2;
wenzelm@19911
   622
    val extras = Symtab.fold (fn (a, xs) =>
wenzelm@19911
   623
      if Symtab.defined occs1 a then I else fold (occs_free a) xs) occs2 [];
wenzelm@19899
   624
    val tfrees = map #1 extras |> sort_distinct string_ord;
wenzelm@19899
   625
    val frees = map #2 extras |> sort_distinct string_ord;
wenzelm@19899
   626
  in
wenzelm@38831
   627
    if null extras orelse not (Context_Position.is_visible ctxt2) then ()
wenzelm@19899
   628
    else warning ("Introduced fixed type variable(s): " ^ commas tfrees ^ " in " ^
wenzelm@19899
   629
      space_implode " or " (map quote frees))
wenzelm@19899
   630
  end;
wenzelm@19899
   631
wenzelm@19899
   632
wenzelm@20149
   633
(* polymorphic terms *)
wenzelm@19899
   634
wenzelm@24694
   635
fun polymorphic_types ctxt ts =
wenzelm@20003
   636
  let
wenzelm@20003
   637
    val ctxt' = fold declare_term ts ctxt;
wenzelm@20162
   638
    val occs = type_occs_of ctxt;
wenzelm@20162
   639
    val occs' = type_occs_of ctxt';
wenzelm@20162
   640
    val types = Symtab.fold (fn (a, _) => if Symtab.defined occs a then I else cons a) occs' [];
wenzelm@24765
   641
    val idx = maxidx_of ctxt' + 1;
wenzelm@24694
   642
    val Ts' = (fold o fold_types o fold_atyps)
wenzelm@24694
   643
      (fn T as TFree _ =>
wenzelm@31977
   644
          (case Term_Subst.generalizeT types idx T of TVar v => insert (op =) v | _ => I)
wenzelm@24694
   645
        | _ => I) ts [];
wenzelm@31977
   646
    val ts' = map (Term_Subst.generalize (types, []) idx) ts;
wenzelm@24694
   647
  in (rev Ts', ts') end;
wenzelm@24694
   648
wenzelm@24694
   649
fun polymorphic ctxt ts = snd (polymorphic_types ctxt ts);
wenzelm@20003
   650
wenzelm@19899
   651
end;