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