src/Pure/Isar/proof_context.ML
author wenzelm
Sun Nov 29 13:21:38 1998 +0100 (1998-11-29)
changeset 5994 7b84677315ed
parent 5935 6a82c8a1808f
child 6091 e3cdbd929a24
permissions -rw-r--r--
fixed declatation of patterns and skolem;
     1 (*  Title:      Pure/Isar/proof_context.ML
     2     ID:         $Id$
     3     Author:     Markus Wenzel, TU Muenchen
     4 
     5 Proof context information.
     6 
     7 TODO:
     8   - pretty_bind: use syntax (!?) (show_types etc.);
     9   - smash_unifiers: ever invents new vars (???);
    10 *)
    11 
    12 (* FIXME tmp *)
    13 val proof_debug = ref false;
    14 
    15 signature PROOF_CONTEXT =
    16 sig
    17   type context
    18   exception CONTEXT of string * context
    19   val theory_of: context -> theory
    20   val sign_of: context -> Sign.sg
    21   val print_binds: context -> unit
    22   val print_thms: context -> unit
    23   val print_context: context -> unit
    24   val print_proof_data: theory -> unit
    25   val init: theory -> context
    26   val read_typ: context -> string -> typ
    27   val cert_typ: context -> typ -> typ
    28   val read_termTs: context -> (string * typ) list -> term list * (indexname * typ) list
    29   val read_term: context -> string -> term
    30   val read_prop: context -> string -> term
    31   val read_term_pat: context -> string -> term
    32   val read_prop_pat: context -> string -> term
    33   val cert_term: context -> term -> term
    34   val cert_prop: context -> term -> term
    35   val declare_term: term -> context -> context
    36   val declare_terms: term list -> context -> context
    37   val declare_thm: thm -> context -> context
    38   val add_binds: (indexname * string) list -> context -> context
    39   val add_binds_i: (indexname * term) list -> context -> context
    40   val match_binds: (string list * string) list -> context -> context
    41   val match_binds_i: (term list * term) list -> context -> context
    42   val bind_propp: context * (string * string list) -> context * term
    43   val bind_propp_i: context * (term * term list) -> context * term
    44   val thms_closure: context -> xstring -> tthm list option
    45   val get_tthm: context -> string -> tthm
    46   val get_tthms: context -> string -> tthm list
    47   val get_tthmss: context -> string list -> tthm list
    48   val put_tthm: string * tthm -> context -> context
    49   val put_tthms: string * tthm list -> context -> context
    50   val put_tthmss: (string * tthm list) list -> context -> context
    51   val have_tthmss: string -> context attribute list
    52     -> (tthm list * context attribute list) list -> context -> context * (string * tthm list)
    53   val assumptions: context -> tthm list
    54   val fixed_names: context -> string list
    55   val assume: string -> context attribute list -> (string * string list) list -> context
    56     -> context * (string * tthm list)
    57   val assume_i: string -> context attribute list -> (term * term list) list -> context
    58     -> context * (string * tthm list)
    59   val fix: (string * string option) list -> context -> context
    60   val fix_i: (string * typ) list -> context -> context
    61   val setup: (theory -> theory) list
    62 end;
    63 
    64 signature PROOF_CONTEXT_PRIVATE =
    65 sig
    66   include PROOF_CONTEXT
    67   val init_data: Object.kind -> (theory -> Object.T) * (context -> Object.T -> unit)
    68     -> theory -> theory
    69   val print_data: Object.kind -> context -> unit
    70   val get_data: Object.kind -> (Object.T -> 'a) -> context -> 'a
    71   val put_data: Object.kind -> ('a -> Object.T) -> 'a -> context -> context
    72 end;
    73 
    74 structure ProofContext: PROOF_CONTEXT_PRIVATE =
    75 struct
    76 
    77 
    78 (** datatype context **)
    79 
    80 datatype context =
    81   Context of
    82    {thy: theory,                                (*current theory*)
    83     data: Object.T Symtab.table,                (*user data*)
    84     asms:
    85       (string * tthm list) list *               (*assumes: A ==> _*)
    86       ((string * string) list * string list),   (*fixes: !!x. _*)
    87     binds: (term * typ) Vartab.table,           (*term bindings*)
    88     thms: tthm list Symtab.table,               (*local thms*)
    89     defs:
    90       typ Vartab.table *                        (*type constraints*)
    91       sort Vartab.table *                       (*default sorts*)
    92       int *					(*maxidx*)
    93       string list};                             (*used type variable names*)
    94 
    95 exception CONTEXT of string * context;
    96 
    97 
    98 fun make_context (thy, data, asms, binds, thms, defs) =
    99   Context {thy = thy, data = data, asms = asms, binds = binds, thms = thms, defs = defs};
   100 
   101 fun map_context f (Context {thy, data, asms, binds, thms, defs}) =
   102   make_context (f (thy, data, asms, binds, thms, defs));
   103 
   104 fun theory_of (Context {thy, ...}) = thy;
   105 val sign_of = Theory.sign_of o theory_of;
   106 
   107 
   108 
   109 (** print context information **)
   110 
   111 (* FIXME tmp*)
   112 fun debug f x = if ! proof_debug then f x else ();
   113 
   114 fun print_items prt name items =
   115   let
   116     fun pretty_itms (name, [x]) = Pretty.block [Pretty.str (name ^ ":"), Pretty.brk 1, prt x]
   117       | pretty_itms (name, xs) = Pretty.big_list (name ^ ":") (map prt xs);
   118   in Pretty.writeln (Pretty.big_list name (map pretty_itms items)) end;
   119 
   120 
   121 (* term bindings *)
   122 
   123 fun print_binds (Context {thy, binds, ...}) =
   124   let
   125     val prt_term = Sign.pretty_term (Theory.sign_of thy);
   126 
   127     fun fix_var (x, i) =
   128       (case try Syntax.dest_binding x of
   129         None => Syntax.string_of_vname (x, i)
   130       | Some x' => if i = 0 then "??" ^ x' else Syntax.string_of_vname (x, i));
   131     fun pretty_bind (xi, (t, T)) = Pretty.block
   132       [Pretty.str (fix_var xi), Pretty.str " ==", Pretty.brk 1, prt_term t];
   133   in Pretty.writeln (Pretty.big_list "Term bindings:" (map pretty_bind (Vartab.dest binds))) end;
   134 
   135 
   136 (* local theorems *)
   137 
   138 fun print_thms (Context {thms, ...}) =
   139   print_items Attribute.pretty_tthm "Local theorems:" (Symtab.dest thms);
   140 
   141 
   142 (* main context *)
   143 
   144 fun print_context (ctxt as Context {thy, data = _, asms = (assumes, (fixes, _)), binds = _,
   145     thms = _, defs = (types, sorts, maxidx, used)}) =
   146   let
   147     val sign = Theory.sign_of thy;
   148 
   149     val term_of_tthm = #prop o Thm.rep_thm o Attribute.thm_of;
   150     val prt_term = Sign.pretty_term sign;
   151     val prt_typ = Sign.pretty_typ sign;
   152     val prt_sort = Sign.pretty_sort sign;
   153 
   154     (*theory*)
   155     val pretty_thy = Pretty.block [Pretty.str "Theory:", Pretty.brk 1, Sign.pretty_sg sign];
   156 
   157     (*fixes*)
   158     fun prt_fix (x, x') = Pretty.str (x ^ " = " ^ x');
   159 
   160     (* defaults *)
   161 
   162     fun prt_atom prt prtT (x, X) = Pretty.block
   163       [prt x, Pretty.str " ::", Pretty.brk 1, prtT X];
   164 
   165     fun prt_var (x, ~1) = prt_term (Syntax.free x)
   166       | prt_var xi = prt_term (Syntax.var xi);
   167 
   168     fun prt_varT (x, ~1) = prt_typ (TFree (x, []))
   169       | prt_varT xi = prt_typ (TVar (xi, []));
   170 
   171     val prt_defT = prt_atom prt_var prt_typ;
   172     val prt_defS = prt_atom prt_varT prt_sort;
   173   in
   174     debug Pretty.writeln pretty_thy;
   175     Pretty.writeln (Pretty.big_list "Fixed variables:" (map prt_fix (rev fixes)));
   176     print_items (prt_term o term_of_tthm) "Assumptions:" assumes;
   177     debug print_binds ctxt;
   178     debug print_thms ctxt;
   179     debug Pretty.writeln (Pretty.big_list "Type constraints:" (map prt_defT (Vartab.dest types)));
   180     debug Pretty.writeln (Pretty.big_list "Default sorts:" (map prt_defS (Vartab.dest sorts)));
   181     debug writeln ("Maxidx: " ^ string_of_int maxidx);
   182     debug Pretty.writeln (Pretty.strs ("Used type variable names:" :: used))
   183   end;
   184 
   185 
   186 
   187 (** user data **)
   188 
   189 (* errors *)
   190 
   191 fun of_theory thy = "\nof theory " ^ Sign.str_of_sg (Theory.sign_of thy);
   192 
   193 fun err_inconsistent kinds =
   194   error ("Attempt to merge different versions of " ^ commas_quote kinds ^ " proof data");
   195 
   196 fun err_dup_init thy kind =
   197   error ("Duplicate initialization of " ^ quote kind ^ " proof data" ^ of_theory thy);
   198 
   199 fun err_undef ctxt kind =
   200   raise CONTEXT ("Tried to access undefined " ^ quote kind ^ " proof data", ctxt);
   201 
   202 fun err_uninit ctxt kind =
   203   raise CONTEXT ("Tried to access uninitialized " ^ quote kind ^ " proof data" ^
   204     of_theory (theory_of ctxt), ctxt);
   205 
   206 fun err_access ctxt kind =
   207   raise CONTEXT ("Unauthorized access to " ^ quote kind ^ " proof data" ^
   208     of_theory (theory_of ctxt), ctxt);
   209 
   210 
   211 (* data kind 'Isar/proof_data' *)
   212 
   213 structure ProofDataDataArgs =
   214 struct
   215   val name = "Isar/proof_data";
   216   type T = (Object.kind * ((theory -> Object.T) * (context -> Object.T -> unit))) Symtab.table;
   217 
   218   val empty = Symtab.empty;
   219   val prep_ext = I;
   220   fun merge tabs = Symtab.merge (Object.eq_kind o pairself fst) tabs
   221     handle Symtab.DUPS kinds => err_inconsistent kinds;
   222   fun print _ tab = Pretty.writeln (Pretty.strs (map #1 (Symtab.dest tab)));
   223 end;
   224 
   225 structure ProofDataData = TheoryDataFun(ProofDataDataArgs);
   226 val print_proof_data = ProofDataData.print;
   227 
   228 
   229 (* init proof data *)
   230 
   231 fun init_data kind meths thy =
   232   let
   233     val name = Object.name_of_kind kind;
   234     val tab = Symtab.update_new ((name, (kind, meths)), ProofDataData.get thy)
   235       handle Symtab.DUP _ => err_dup_init thy name;
   236   in thy |> ProofDataData.put tab end;
   237 
   238 
   239 (* access data *)
   240 
   241 fun lookup_data (ctxt as Context {data, ...}) kind =
   242   let
   243     val thy = theory_of ctxt;
   244     val name = Object.name_of_kind kind;
   245   in
   246     (case Symtab.lookup (ProofDataData.get thy, name) of
   247       Some (k, meths) =>
   248         if Object.eq_kind (kind, k) then
   249           (case Symtab.lookup (data, name) of
   250             Some x => (x, meths)
   251           | None => err_undef ctxt name)
   252         else err_access ctxt name
   253     | None => err_uninit ctxt name)
   254   end;
   255 
   256 fun get_data kind f ctxt =
   257   let val (x, _) = lookup_data ctxt kind
   258   in f x handle Match => Object.kind_error kind end;
   259 
   260 fun print_data kind ctxt =
   261   let val (x, (_, prt)) = lookup_data ctxt kind
   262   in prt ctxt x end;
   263 
   264 fun put_data kind f x ctxt =
   265   (lookup_data ctxt kind;
   266     ctxt |> map_context (fn (thy, data, asms, binds, thms, defs) =>
   267       (thy, Symtab.update ((Object.name_of_kind kind, f x), data), asms, binds, thms, defs)));
   268 
   269 
   270 (* init context *)
   271 
   272 fun init thy =
   273   let val data = Symtab.map (fn (_, (f, _)) => f thy) (ProofDataData.get thy) in
   274     make_context (thy, data, ([], ([], [])), Vartab.empty, Symtab.empty,
   275       (Vartab.empty, Vartab.empty, ~1, []))
   276   end;
   277 
   278 
   279 
   280 (** prepare types **)
   281 
   282 fun read_typ (ctxt as Context {defs = (_, sorts, _, _), ...}) s =
   283   let
   284     val sign = sign_of ctxt;
   285     fun def_sort xi = Vartab.lookup (sorts, xi);
   286   in
   287     transform_error (Sign.read_typ (sign, def_sort)) s
   288       handle ERROR_MESSAGE msg => raise CONTEXT (msg, ctxt)
   289   end;
   290 
   291 fun cert_typ ctxt raw_T =
   292   Sign.certify_typ (sign_of ctxt) raw_T
   293     handle TYPE (msg, _, _) => raise CONTEXT (msg, ctxt);
   294 
   295 
   296 
   297 (** prepare terms and propositions **)
   298 
   299 (*
   300   (1) read / certify wrt. signature of context
   301   (2) intern Skolem constants
   302   (3) expand term bindings
   303 *)
   304 
   305 
   306 (* read / certify wrt. signature *)     (*exception ERROR*) (*exception TERM*)
   307 
   308 fun read_def_termTs freeze sg (types, sorts, used) sTs =
   309   let val (cts, env) = Thm.read_def_cterms (sg, types, sorts) used freeze sTs
   310   in (map Thm.term_of cts, env) end;
   311 
   312 fun read_def_termT freeze sg defs sT = apfst hd (read_def_termTs freeze sg defs [sT]);
   313 
   314 
   315 fun read_term_sg sg (defs as (_, _, used)) s =
   316   #1 (read_def_termT true sg defs (s, TVar ((variant used "'z", 0), logicS)));
   317 
   318 fun read_prop_sg sg defs s =
   319   #1 (read_def_termT true sg defs (s, propT));
   320 
   321 
   322 fun cert_term_sg sg t = Thm.term_of (Thm.cterm_of sg t);
   323 
   324 fun cert_prop_sg sg tm =
   325   let
   326     val ctm = Thm.cterm_of sg tm;
   327     val {t, T, ...} = Thm.rep_cterm ctm;
   328   in
   329     if T = propT then t
   330     else raise TERM ("Term not of type prop", [t])
   331   end;
   332 
   333 
   334 (* intern_skolem *)
   335 
   336 fun get_skolem (Context {asms = (_, (fixes, _)), ...}) x = assoc (fixes, x);
   337 
   338 fun check_skolem ctxt check x =
   339   if check andalso can Syntax.dest_skolem x then
   340     raise CONTEXT ("Illegal reference to internal Skolem constant: " ^ quote x, ctxt)
   341   else x;
   342 
   343 fun intern_skolem ctxt check =
   344   let
   345     fun intern (t as Free (x, T)) =
   346           (case get_skolem ctxt (check_skolem ctxt check x) of
   347             Some x' => Free (x', T)
   348           | None => t)
   349       | intern (t $ u) = intern t $ intern u
   350       | intern (Abs (x, T, t)) = Abs (x, T, intern t)
   351       | intern a = a;
   352   in intern end;
   353 
   354 
   355 (* norm_term *)
   356 
   357 (*beta normal form for terms (not eta normal form), chase variables in
   358   bindings environment (code taken from Pure/envir.ML)*)
   359 
   360 fun norm_term (ctxt as Context {binds, ...}) =
   361   let
   362     (*raised when norm has no effect on a term, to do sharing instead of copying*)
   363     exception SAME;
   364 
   365     fun norm (t as Var (xi, T)) =
   366           (case Vartab.lookup (binds, xi) of
   367             Some (u, U) =>
   368               if T = U then (norm u handle SAME => u)
   369               else raise TYPE ("norm_term: ill-typed variable assigment", [T, U], [t, u])
   370           | None =>
   371               if can Syntax.dest_binding (#1 xi) then
   372                 raise CONTEXT ("Unbound binding: " ^ Syntax.string_of_vname xi, ctxt)
   373               else raise SAME)
   374       | norm (Abs (a, T, body)) =  Abs (a, T, norm body)
   375       | norm (Abs (_, _, body) $ t) = normh (subst_bound (t, body))
   376       | norm (f $ t) =
   377           ((case norm f of
   378             Abs (_, _, body) => normh (subst_bound (t, body))
   379           | nf => nf $ (norm t handle SAME => t)) handle SAME => f $ norm t)
   380       | norm _ =  raise SAME
   381     and normh t = norm t handle SAME => t
   382   in normh end;
   383 
   384 
   385 (* read terms *)
   386 
   387 fun gen_read read app is_pat (ctxt as Context {binds, defs = (types, sorts, _, used), ...}) s =
   388   let
   389     val sign = sign_of ctxt;
   390 
   391     fun def_type xi =
   392       (case Vartab.lookup (types, xi) of
   393         None => if is_pat then None else apsome #2 (Vartab.lookup (binds, xi))
   394       | some => some);
   395 
   396     fun def_sort xi = Vartab.lookup (sorts, xi);
   397   in
   398     (transform_error (read sign (def_type, def_sort, used)) s
   399       handle TERM (msg, _) => raise CONTEXT (msg, ctxt)
   400       | ERROR_MESSAGE msg => raise CONTEXT (msg, ctxt))
   401     |> app (intern_skolem ctxt true)
   402     |> app (if is_pat then I else norm_term ctxt)
   403   end;
   404 
   405 val read_termTs = gen_read (read_def_termTs false) (apfst o map) false;
   406 val read_term = gen_read read_term_sg I false;
   407 val read_prop = gen_read read_prop_sg I false;
   408 val read_term_pat = gen_read read_term_sg I true;
   409 val read_prop_pat = gen_read read_prop_sg I true;
   410 
   411 
   412 (* certify terms *)
   413 
   414 fun gen_cert cert is_pat ctxt t =
   415   (cert (sign_of ctxt) t handle TERM (msg, _) => raise CONTEXT (msg, ctxt))
   416   |> intern_skolem ctxt false
   417   |> (if is_pat then I else norm_term ctxt);
   418 
   419 val cert_term = gen_cert cert_term_sg false;
   420 val cert_prop = gen_cert cert_prop_sg false;
   421 val cert_term_pat = gen_cert cert_term_sg true;
   422 val cert_prop_pat = gen_cert cert_prop_sg true;
   423 
   424 
   425 (* declare terms *)
   426 
   427 val ins_types = foldl_aterms
   428   (fn (types, Free (x, T)) => Vartab.update (((x, ~1), T), types)
   429     | (types, Var v) => Vartab.update (v, types)
   430     | (types, _) => types);
   431 
   432 val ins_sorts = foldl_types (foldl_atyps
   433   (fn (sorts, TFree (x, S)) => Vartab.update (((x, ~1), S), sorts)
   434     | (sorts, TVar v) => Vartab.update (v, sorts)
   435     | (sorts, _) => sorts));
   436 
   437 val ins_used = foldl_types (foldl_atyps
   438   (fn (used, TFree (x, _)) => x ins used
   439     | (used, TVar ((x, _), _)) => x ins used
   440     | (used, _) => used));
   441 
   442 fun ins_skolem def_type = foldr
   443   (fn ((x, x'), types) =>
   444     (case def_type x' of
   445       Some T => Vartab.update (((x, ~1), T), types)
   446     | None => types));
   447 
   448 fun map_defaults f = map_context
   449   (fn (thy, data, asms, binds, thms, defs) => (thy, data, asms, binds, thms, f defs));
   450 
   451 fun declare (ctxt as Context {asms = (_, (fixes, _)), ...}, t) =
   452   ctxt
   453   |> map_defaults (fn (types, sorts, maxidx, used) => (ins_types (types, t), sorts, maxidx, used))
   454   |> map_defaults (fn (types, sorts, maxidx, used) => (types, ins_sorts (sorts, t), maxidx, used))
   455   |> map_defaults (fn (types, sorts, maxidx, used) => (types, sorts, maxidx, ins_used (used, t)))
   456   |> map_defaults (fn (types, sorts, maxidx, used) =>
   457       (types, sorts, Int.max (maxidx, Term.maxidx_of_term t), used))
   458   |> map_defaults (fn (types, sorts, maxidx, used) =>
   459       (ins_skolem (fn x => Vartab.lookup (types, (x, ~1))) (fixes, types), sorts, maxidx, used));
   460 
   461 
   462 fun declare_term t ctxt = declare (ctxt, t);
   463 fun declare_terms ts ctxt = foldl declare (ctxt, ts);
   464 
   465 fun declare_thm thm ctxt =
   466   let val {prop, hyps, ...} = Thm.rep_thm thm
   467   in ctxt |> declare_terms (prop :: hyps) end;
   468 
   469 
   470 
   471 (** bindings **)
   472 
   473 (* update_binds *)
   474 
   475 fun upd_bind (ctxt, (xi, t)) =
   476   let val T = fastype_of t in
   477     ctxt
   478     |> declare_term t
   479     |> map_context (fn (thy, data, asms, binds, thms, defs) =>
   480         (thy, data, asms, Vartab.update ((xi, (t, T)), binds), thms, defs))
   481   end;
   482 
   483 fun update_binds bs ctxt = foldl upd_bind (ctxt, bs);
   484 fun update_binds_env env = update_binds (Envir.alist_of env);
   485 
   486 
   487 (* add_binds(_i) -- sequential *)
   488 
   489 fun gen_bind prep (ctxt, (xi as (x, _), raw_t)) =
   490   let val t = prep ctxt raw_t in
   491     if can Syntax.dest_binding x then ctxt |> update_binds [(xi, t)]
   492     else raise CONTEXT ("Illegal variable name for term binding: " ^
   493       quote (Syntax.string_of_vname xi), ctxt)
   494   end;
   495 
   496 fun gen_binds prep binds ctxt = foldl (gen_bind prep) (ctxt, binds);
   497 
   498 val add_binds = gen_binds read_term;
   499 val add_binds_i = gen_binds cert_term;
   500 
   501 
   502 (* match_binds(_i) -- parallel *)
   503 
   504 fun prep_declare_match (prep_pat, prep) (ctxt, (raw_pats, raw_t)) =
   505   let
   506     val t = prep ctxt raw_t;
   507     val ctxt' = ctxt |> declare_term t;
   508     val pats = map (prep_pat ctxt') raw_pats;		(* FIXME seq / par / simult (??) *)
   509   in (ctxt', (map (rpair t) pats, t)) end;
   510 
   511 fun gen_match_binds _ [] ctxt = ctxt
   512   | gen_match_binds prepp raw_pairs ctxt =
   513       let
   514         val (ctxt', matches) = foldl_map (prep_declare_match prepp) (ctxt, raw_pairs);
   515         val pairs = flat (map #1 matches);
   516         val Context {defs = (_, _, maxidx, _), ...} = ctxt';
   517         val envs = Unify.smash_unifiers (sign_of ctxt', Envir.empty maxidx, pairs);
   518         val env =
   519           (case Seq.pull envs of
   520             None => raise CONTEXT ("Pattern match failed!", ctxt')
   521           | Some (env, _) => env);
   522       in ctxt' |> update_binds_env env end;
   523 
   524 val match_binds = gen_match_binds (read_term_pat, read_term);
   525 val match_binds_i = gen_match_binds (cert_term_pat, cert_term);
   526 
   527 
   528 (* bind proposition patterns *)
   529 
   530 fun gen_bind_propp prepp (ctxt, (raw_prop, raw_pats)) =
   531   let val (ctxt', (pairs, prop)) = prep_declare_match prepp (ctxt, (raw_pats, raw_prop))
   532   in (ctxt' |> match_binds_i (map (apfst single) pairs), prop) end;
   533 
   534 val bind_propp = gen_bind_propp (read_prop_pat, read_prop);
   535 val bind_propp_i = gen_bind_propp (cert_prop_pat, cert_prop);
   536 
   537 
   538 
   539 (** theorems **)
   540 
   541 (* thms_closure *)
   542 
   543 fun thms_closure (Context {thy, thms, ...}) =
   544   let
   545     val global_closure = PureThy.thms_closure thy;
   546     fun get name =
   547       (case global_closure name of
   548         None => Symtab.lookup (thms, name)
   549       | some => some);
   550   in get end;
   551 
   552 
   553 (* get_tthm(s) *)
   554 
   555 fun get_tthm (ctxt as Context {thy, thms, ...}) name =
   556   (case Symtab.lookup (thms, name) of
   557     Some [th] => th
   558   | Some _ => raise CONTEXT ("Single theorem expected: " ^ quote name, ctxt)
   559   | None => (PureThy.get_tthm thy name handle THEORY (msg, _) => raise CONTEXT (msg, ctxt)));
   560 
   561 fun get_tthms (ctxt as Context {thy, thms, ...}) name =
   562   (case Symtab.lookup (thms, name) of
   563     Some ths => ths
   564   | None => (PureThy.get_tthms thy name handle THEORY (msg, _) => raise CONTEXT (msg, ctxt)));
   565 
   566 fun get_tthmss ctxt names = flat (map (get_tthms ctxt) names);
   567 
   568 
   569 (* put_tthm(s) *)
   570 
   571 fun put_tthms (name, ths) = map_context
   572   (fn (thy, data, asms, binds, thms, defs) =>
   573     (thy, data, asms, binds, Symtab.update ((name, ths), thms), defs));
   574 
   575 fun put_tthm (name, th) = put_tthms (name, [th]);
   576 
   577 fun put_tthmss [] ctxt = ctxt
   578   | put_tthmss (th :: ths) ctxt = ctxt |> put_tthms th |> put_tthmss ths;
   579 
   580 
   581 (* have_tthmss *)
   582 
   583 fun have_tthmss name more_attrs ths_attrs ctxt =
   584   let
   585     fun app ((ct, ths), (th, attrs)) =
   586       let val (ct', th') = Attribute.applys ((ct, th), attrs @ more_attrs)
   587       in (ct', th' :: ths) end
   588     val (ctxt', rev_thms) = foldl app ((ctxt, []), ths_attrs);
   589     val thms = flat (rev rev_thms);
   590   in (ctxt' |> put_tthms (name, thms), (name, thms)) end;
   591 
   592 
   593 
   594 (** assumptions **)
   595 
   596 (* get assumptions *)
   597 
   598 fun assumptions (Context {asms = (asms, _), ...}) = flat (map #2 asms);
   599 fun fixed_names (Context {asms = (_, (fixes, _)), ...}) = map #2 fixes;
   600 
   601 
   602 (* assume *)
   603 
   604 fun gen_assume prepp name attrs raw_prop_pats ctxt =
   605   let
   606     val (ctxt', props) = foldl_map prepp (ctxt, raw_prop_pats);
   607     val sign = sign_of ctxt';
   608 
   609     val asms = map (Attribute.tthm_of o Thm.assume o Thm.cterm_of sign) props;
   610 
   611     val ths = map (fn th => ([th], [])) asms;
   612     val (ctxt'', (_, tthms)) =
   613       ctxt'
   614       |> have_tthmss name (attrs @ [Attribute.tag_assumption]) ths
   615 
   616     val ctxt''' =
   617       ctxt''
   618       |> map_context (fn (thy, data, (assumes, fixes), binds, thms, defs) =>
   619         (thy, data, (assumes @ [(name, asms)], fixes), binds, thms, defs));
   620   in (ctxt''', (name, tthms)) end;
   621 
   622 val assume = gen_assume bind_propp;
   623 val assume_i = gen_assume bind_propp_i;
   624 
   625 
   626 (* fix *)
   627 
   628 fun read_skolemT (Context {defs = (_, _, _, used), ...}) None = Type.param used ("'z", logicS)
   629   | read_skolemT ctxt (Some s) = read_typ ctxt s;
   630 
   631 fun gen_fix prep check (ctxt, (x, raw_T)) =
   632   ctxt
   633   |> declare_term (Free (check_skolem ctxt check x, prep ctxt raw_T))
   634   |> map_context (fn (thy, data, (assumes, (fixes, names)), binds, thms, defs) =>
   635       let val x' = variant names x in
   636         (thy, data, (assumes, ((x, Syntax.skolem x') :: fixes, x' :: names)), binds, thms, defs)
   637       end);
   638 
   639 fun gen_fixs prep check xs ctxt = foldl (gen_fix prep check) (ctxt, xs);
   640 
   641 
   642 val fix = gen_fixs read_skolemT true;
   643 val fix_i = gen_fixs cert_typ false;
   644 
   645 
   646 
   647 (** theory setup **)
   648 
   649 val setup = [ProofDataData.init];
   650 
   651 
   652 end;