src/Pure/Isar/proof_context.ML
changeset 7575 e1e2d07287d8
parent 7557 1b977741f530
child 7606 7905a74eb068
equal deleted inserted replaced
7574:5bcb7fc31caa 7575:e1e2d07287d8
    15   val show_hyps: bool ref
    15   val show_hyps: bool ref
    16   val pretty_thm: thm -> Pretty.T
    16   val pretty_thm: thm -> Pretty.T
    17   val verbose: bool ref
    17   val verbose: bool ref
    18   val print_binds: context -> unit
    18   val print_binds: context -> unit
    19   val print_thms: context -> unit
    19   val print_thms: context -> unit
       
    20   val strings_of_prems: context -> string list
    20   val strings_of_context: context -> string list
    21   val strings_of_context: context -> string list
    21   val print_proof_data: theory -> unit
    22   val print_proof_data: theory -> unit
    22   val init: theory -> context
    23   val init: theory -> context
    23   val read_typ: context -> string -> typ
    24   val read_typ: context -> string -> typ
    24   val cert_typ: context -> typ -> typ
    25   val cert_typ: context -> typ -> typ
   110 
   111 
   111 
   112 
   112 (** print context information **)
   113 (** print context information **)
   113 
   114 
   114 val show_hyps = ref false;
   115 val show_hyps = ref false;
   115 fun pretty_thm th = setmp Display.show_hyps (! show_hyps) Display.pretty_thm th;
   116 
       
   117 fun pretty_thm thm =
       
   118   if ! show_hyps then setmp Display.show_hyps true Display.pretty_thm_no_quote thm
       
   119   else Display.pretty_cterm (#prop (Thm.crep_thm thm));
   116 
   120 
   117 val verbose = ref false;
   121 val verbose = ref false;
   118 fun verb f x = if ! verbose then f x else [];
   122 fun verb f x = if ! verbose then f x else [];
   119 val verb_string = verb (Library.single o Pretty.string_of);
   123 val verb_string = verb (Library.single o Pretty.string_of);
   120 
   124 
   128   end;
   132   end;
   129 
   133 
   130 
   134 
   131 (* term bindings *)
   135 (* term bindings *)
   132 
   136 
   133 fun strings_of_binds (Context {thy, binds, ...}) =
   137 fun strings_of_binds (ctxt as Context {binds, ...}) =
   134   let
   138   let
   135     val prt_term = Sign.pretty_term (Theory.sign_of thy);
   139     val prt_term = Sign.pretty_term (sign_of ctxt);
   136     fun pretty_bind (xi, (t, T)) = prt_term (Logic.mk_equals (Var (xi, T), t));
   140     fun pretty_bind (xi, (t, T)) = prt_term (Logic.mk_equals (Var (xi, T), t));
   137   in
   141   in
   138     if Vartab.is_empty binds andalso not (! verbose) then []
   142     if Vartab.is_empty binds andalso not (! verbose) then []
   139     else [Pretty.string_of (Pretty.big_list "Term bindings:"
   143     else [Pretty.string_of (Pretty.big_list "term bindings:"
   140       (map pretty_bind (Vartab.dest binds)))]
   144       (map pretty_bind (Vartab.dest binds)))]
   141   end;
   145   end;
   142 
   146 
   143 val print_binds = seq writeln o strings_of_binds;
   147 val print_binds = seq writeln o strings_of_binds;
   144 
   148 
   145 
   149 
   146 (* local theorems *)
   150 (* local theorems *)
   147 
   151 
   148 fun strings_of_thms (Context {thms, ...}) =
   152 fun strings_of_thms (Context {thms, ...}) =
   149   strings_of_items pretty_thm "Local theorems:" (Symtab.dest thms);
   153   strings_of_items pretty_thm "local theorems:" (Symtab.dest thms);
   150 
   154 
   151 val print_thms = seq writeln o strings_of_thms;
   155 val print_thms = seq writeln o strings_of_thms;
   152 
   156 
   153 
   157 
   154 (* main context *)
   158 (* main context *)
   155 
   159 
   156 fun strings_of_context (ctxt as Context {thy, data = _, asms = (_, (fixes, _)), binds = _,
   160 fun strings_of_prems ctxt =
   157     thms = _, defs = (types, sorts, maxidx, used)}) =
   161   (case prems_of ctxt of
   158   let
   162     [] => []
   159     val sign = Theory.sign_of thy;
   163   | prems => [Pretty.string_of (Pretty.big_list "prems:" (map pretty_thm prems))]);
   160     val prems = prems_of ctxt;
   164 
       
   165 fun strings_of_context (ctxt as Context {asms = (_, (fixes, _)),
       
   166     defs = (types, sorts, maxidx, used), ...}) =
       
   167   let
       
   168     val sign = sign_of ctxt;
   161 
   169 
   162     val prt_term = Sign.pretty_term sign;
   170     val prt_term = Sign.pretty_term sign;
   163     val prt_typ = Sign.pretty_typ sign;
   171     val prt_typ = Sign.pretty_typ sign;
   164     val prt_sort = Sign.pretty_sort sign;
   172     val prt_sort = Sign.pretty_sort sign;
   165 
   173 
   166     (*theory*)
   174     (*theory*)
   167     val pretty_thy = Pretty.block [Pretty.str "Theory:", Pretty.brk 1, Sign.pretty_sg sign];
   175     val pretty_thy = Pretty.block [Pretty.str "Theory:", Pretty.brk 1, Sign.pretty_sg sign];
   168 
   176 
   169     (*fixes*)
   177     (*fixes*)
   170     fun prt_fixes xs = Pretty.block (Pretty.str "Fixed variables:" :: Pretty.brk 1 ::
   178     fun prt_fixes xs = Pretty.block (Pretty.str "fixed variables:" :: Pretty.brk 1 ::
   171       Pretty.commas (map (fn (x, x') => Pretty.str (x ^ " = " ^ x')) xs));
   179       Pretty.commas (map (fn (x, x') => Pretty.str (x ^ " = " ^ x')) xs));
   172 
   180 
   173 
   181 
   174     (* defaults *)
   182     (* defaults *)
   175 
   183 
   184 
   192 
   185     val prt_defT = prt_atom prt_var prt_typ;
   193     val prt_defT = prt_atom prt_var prt_typ;
   186     val prt_defS = prt_atom prt_varT prt_sort;
   194     val prt_defS = prt_atom prt_varT prt_sort;
   187   in
   195   in
   188     verb_string pretty_thy @
   196     verb_string pretty_thy @
   189     (if null fixes andalso not (! verbose) then []
   197     (if null fixes then [] else [Pretty.string_of (prt_fixes (rev fixes))]) @
   190       else [Pretty.string_of (prt_fixes (rev fixes))]) @
   198     strings_of_prems ctxt @
   191     (if null prems andalso not (! verbose) then []
       
   192       else [Pretty.string_of (Pretty.big_list "Assumptions:"
       
   193         (map (prt_term o #prop o Thm.rep_thm) prems))]) @
       
   194     verb strings_of_binds ctxt @
   199     verb strings_of_binds ctxt @
   195     verb strings_of_thms ctxt @
   200     verb strings_of_thms ctxt @
   196     verb_string (Pretty.big_list "Type constraints:" (map prt_defT (Vartab.dest types))) @
   201     verb_string (Pretty.big_list "type constraints:" (map prt_defT (Vartab.dest types))) @
   197     verb_string (Pretty.big_list "Default sorts:" (map prt_defS (Vartab.dest sorts))) @
   202     verb_string (Pretty.big_list "default sorts:" (map prt_defS (Vartab.dest sorts))) @
   198     verb_string (Pretty.str ("Maxidx: " ^ string_of_int maxidx)) @
   203     verb_string (Pretty.str ("maxidx: " ^ string_of_int maxidx)) @
   199     verb_string (Pretty.strs ("Used type variable names:" :: used))
   204     verb_string (Pretty.strs ("used type variable names:" :: used))
   200   end;
   205   end;
   201 
   206 
   202 
   207 
   203 
   208 
   204 (** user data **)
   209 (** user data **)
   296 
   301 
   297 
   302 
   298 (** prepare types **)
   303 (** prepare types **)
   299 
   304 
   300 fun read_typ (ctxt as Context {defs = (_, sorts, _, _), ...}) s =
   305 fun read_typ (ctxt as Context {defs = (_, sorts, _, _), ...}) s =
   301   let
   306   let fun def_sort xi = Vartab.lookup (sorts, xi) in
   302     val sign = sign_of ctxt;
   307     transform_error (Sign.read_typ (sign_of ctxt, def_sort)) s
   303     fun def_sort xi = Vartab.lookup (sorts, xi);
       
   304   in
       
   305     transform_error (Sign.read_typ (sign, def_sort)) s
       
   306       handle ERROR_MESSAGE msg => raise CONTEXT (msg, ctxt)
   308       handle ERROR_MESSAGE msg => raise CONTEXT (msg, ctxt)
   307   end;
   309   end;
   308 
   310 
   309 fun cert_typ ctxt raw_T =
   311 fun cert_typ ctxt raw_T =
   310   Sign.certify_typ (sign_of ctxt) raw_T
   312   Sign.certify_typ (sign_of ctxt) raw_T
   423 
   425 
   424 (* read terms *)
   426 (* read terms *)
   425 
   427 
   426 fun gen_read read app is_pat (ctxt as Context {binds, defs = (types, sorts, _, used), ...}) s =
   428 fun gen_read read app is_pat (ctxt as Context {binds, defs = (types, sorts, _, used), ...}) s =
   427   let
   429   let
   428     val sign = sign_of ctxt;
       
   429 
       
   430     fun def_type xi =
   430     fun def_type xi =
   431       (case Vartab.lookup (types, xi) of
   431       (case Vartab.lookup (types, xi) of
   432         None => if is_pat then None else apsome #2 (Vartab.lookup (binds, xi))
   432         None => if is_pat then None else apsome #2 (Vartab.lookup (binds, xi))
   433       | some => some);
   433       | some => some);
   434 
   434 
   435     fun def_sort xi = Vartab.lookup (sorts, xi);
   435     fun def_sort xi = Vartab.lookup (sorts, xi);
   436   in
   436   in
   437     (transform_error (read sign (def_type, def_sort, used)) s
   437     (transform_error (read (sign_of ctxt) (def_type, def_sort, used)) s
   438       handle TERM (msg, _) => raise CONTEXT (msg, ctxt)
   438       handle TERM (msg, _) => raise CONTEXT (msg, ctxt)
   439       | ERROR_MESSAGE msg => raise CONTEXT (msg, ctxt))
   439       | ERROR_MESSAGE msg => raise CONTEXT (msg, ctxt))
   440     |> app (intern_skolem ctxt true)
   440     |> app (intern_skolem ctxt true)
   441     |> app (if is_pat then I else norm_term ctxt)
   441     |> app (if is_pat then I else norm_term ctxt)
   442     |> app (if is_pat then prepare_dummies else (reject_dummies ctxt))
   442     |> app (if is_pat then prepare_dummies else (reject_dummies ctxt))
   640 local
   640 local
   641 
   641 
   642 fun gen_assm prepp tac (ctxt, (name, attrs, raw_prop_pats)) =
   642 fun gen_assm prepp tac (ctxt, (name, attrs, raw_prop_pats)) =
   643   let
   643   let
   644     val (ctxt', props) = foldl_map prepp (ctxt, raw_prop_pats);
   644     val (ctxt', props) = foldl_map prepp (ctxt, raw_prop_pats);
   645     val sign = sign_of ctxt';
       
   646     val Context {defs = (_, _, maxidx, _), ...} = ctxt';
   645     val Context {defs = (_, _, maxidx, _), ...} = ctxt';
   647 
   646 
   648     val cprops = map (Thm.cterm_of sign) props;
   647     val cprops = map (Thm.cterm_of (sign_of ctxt')) props;
   649     val cprops_tac = map (rpair tac) cprops;
   648     val cprops_tac = map (rpair tac) cprops;
   650     val asms = map (Drule.forall_elim_vars (maxidx + 1) o Drule.assume_goal) cprops;
   649     val asms = map (Drule.forall_elim_vars (maxidx + 1) o Drule.assume_goal) cprops;
   651 
   650 
   652     val ths = map (fn th => ([th], [])) asms;
   651     val ths = map (fn th => ([th], [])) asms;
   653     val (ctxt'', (_, thms)) =
   652     val (ctxt'', (_, thms)) =