improved handling of warn_extra_tfrees;
authorwenzelm
Mon, 25 Oct 1999 20:38:03 +0200
changeset 792806a11f8cf573
parent 7927 b50446a33c16
child 7929 2010ae0393ca
improved handling of warn_extra_tfrees;
src/Pure/Isar/proof.ML
src/Pure/Isar/proof_context.ML
     1.1 --- a/src/Pure/Isar/proof.ML	Mon Oct 25 19:24:43 1999 +0200
     1.2 +++ b/src/Pure/Isar/proof.ML	Mon Oct 25 20:38:03 1999 +0200
     1.3 @@ -573,11 +573,11 @@
     1.4  
     1.5  fun setup_goal opt_block prepp kind after_qed name atts raw_propp state =
     1.6    let
     1.7 -    val (state', [prop]) =
     1.8 +    val (state', prop) =
     1.9        state
    1.10        |> assert_forward_or_chain
    1.11        |> enter_forward
    1.12 -      |> map_context_result (prepp [raw_propp]);
    1.13 +      |> map_context_result (prepp raw_propp);
    1.14      val cprop = Thm.cterm_of (sign_of state') prop;
    1.15      val goal = Drule.mk_triv_goal cprop;
    1.16    in
    1.17 @@ -593,22 +593,24 @@
    1.18  
    1.19  (*global goals*)
    1.20  fun global_goal prep kind name atts x thy =
    1.21 -  setup_goal I (prep false) kind Seq.single name atts x (init_state thy);
    1.22 +  setup_goal I prep kind Seq.single name atts x (init_state thy);
    1.23  
    1.24 -val theorem = global_goal ProofContext.bind_propps Theorem;
    1.25 -val theorem_i = global_goal ProofContext.bind_propps_i Theorem;
    1.26 -val lemma = global_goal ProofContext.bind_propps Lemma;
    1.27 -val lemma_i = global_goal ProofContext.bind_propps_i Lemma;
    1.28 +val theorem = global_goal ProofContext.bind_propp Theorem;
    1.29 +val theorem_i = global_goal ProofContext.bind_propp_i Theorem;
    1.30 +val lemma = global_goal ProofContext.bind_propp Lemma;
    1.31 +val lemma_i = global_goal ProofContext.bind_propp_i Lemma;
    1.32  
    1.33  
    1.34  (*local goals*)
    1.35 -fun local_goal prep kind f name atts x =
    1.36 -  setup_goal open_block (prep true) kind f name atts x;
    1.37 +fun local_goal prep kind f name atts args state =
    1.38 +  state
    1.39 +  |> setup_goal open_block prep kind f name atts args
    1.40 +  |> warn_extra_tfrees state;
    1.41  
    1.42 -val show   = local_goal ProofContext.bind_propps Goal;
    1.43 -val show_i = local_goal ProofContext.bind_propps_i Goal;
    1.44 -val have   = local_goal ProofContext.bind_propps Aux;
    1.45 -val have_i = local_goal ProofContext.bind_propps_i Aux;
    1.46 +val show   = local_goal ProofContext.bind_propp Goal;
    1.47 +val show_i = local_goal ProofContext.bind_propp_i Goal;
    1.48 +val have   = local_goal ProofContext.bind_propp Aux;
    1.49 +val have_i = local_goal ProofContext.bind_propp_i Aux;
    1.50  
    1.51  
    1.52  
     2.1 --- a/src/Pure/Isar/proof_context.ML	Mon Oct 25 19:24:43 1999 +0200
     2.2 +++ b/src/Pure/Isar/proof_context.ML	Mon Oct 25 20:38:03 1999 +0200
     2.3 @@ -40,10 +40,8 @@
     2.4    val auto_bind_facts: string -> term list -> context -> context
     2.5    val match_binds: (string list * string) list -> context -> context
     2.6    val match_binds_i: (term list * term) list -> context -> context
     2.7 -  val bind_propps: bool -> (string * (string list * string list)) list
     2.8 -    -> context -> context * term list
     2.9 -  val bind_propps_i: bool -> (term * (term list * term list)) list
    2.10 -    -> context -> context * term list
    2.11 +  val bind_propp: string * (string list * string list) -> context -> context * term
    2.12 +  val bind_propp_i: term * (term list * term list) -> context -> context * term
    2.13    val get_thm: context -> string -> thm
    2.14    val get_thms: context -> string -> thm list
    2.15    val get_thmss: context -> string list -> thm list
    2.16 @@ -529,7 +527,7 @@
    2.17    else
    2.18      (case Library.gen_rems (op =) (used2, used1) of
    2.19        [] => ()
    2.20 -    | extras => warning ("Introducing free type variables: " ^ commas extras));
    2.21 +    | extras => warning ("Introducing free type variables: " ^ commas (rev extras)));
    2.22  
    2.23  fun warn_extra_tfrees (ctxt1 as Context {defs = (_, _, used1), ...})
    2.24      (ctxt2 as Context {defs = (_, _, used2), ...}) = (warn_extra used1 used2; ctxt2);
    2.25 @@ -614,24 +612,14 @@
    2.26  
    2.27  (* bind proposition patterns *)
    2.28  
    2.29 -local
    2.30 -
    2.31 -fun gen_bind_propp prepp (ctxt, (raw_prop, (raw_pats1, raw_pats2))) =
    2.32 +fun gen_bind_propp prepp (raw_prop, (raw_pats1, raw_pats2)) ctxt =
    2.33    let
    2.34      val raw_pats = map (pair I) raw_pats1 @ map (pair Logic.strip_imp_concl) raw_pats2;
    2.35      val (ctxt', (pairs, prop)) = prep_declare_match prepp (ctxt, (raw_pats, raw_prop));
    2.36    in (ctxt' |> match_binds_i (map (apfst single) pairs), prop) end;
    2.37  
    2.38 -fun gen_bind_propps prepp warn args ctxt =
    2.39 -  apfst (if warn then warn_extra_tfrees ctxt else I)
    2.40 -    (foldl_map (gen_bind_propp prepp) (ctxt, args));
    2.41 -
    2.42 -in
    2.43 -
    2.44 -val bind_propps = gen_bind_propps (read_prop_pat, read_prop);
    2.45 -val bind_propps_i = gen_bind_propps (cert_prop_pat, cert_prop);
    2.46 -
    2.47 -end;
    2.48 +val bind_propp = gen_bind_propp (read_prop_pat, read_prop);
    2.49 +val bind_propp_i = gen_bind_propp (cert_prop_pat, cert_prop);
    2.50  
    2.51  
    2.52  
    2.53 @@ -699,7 +687,7 @@
    2.54  
    2.55  fun gen_assm prepp tac (ctxt, (name, attrs, raw_prop_pats)) =
    2.56    let
    2.57 -    val (ctxt', props) = prepp true raw_prop_pats ctxt;
    2.58 +    val (ctxt', props) = foldl_map (fn (c, x) => prepp x c) (ctxt, raw_prop_pats);
    2.59  
    2.60      val cprops = map (Thm.cterm_of (sign_of ctxt')) props;
    2.61      val cprops_tac = map (rpair tac) cprops;
    2.62 @@ -719,12 +707,12 @@
    2.63  
    2.64  fun gen_assms prepp tac args ctxt =
    2.65    let val (ctxt', thmss) = foldl_map (gen_assm prepp tac) (ctxt, args)
    2.66 -  in (ctxt', (thmss, prems_of ctxt')) end;
    2.67 +  in (warn_extra_tfrees ctxt ctxt', (thmss, prems_of ctxt')) end;
    2.68  
    2.69  in
    2.70  
    2.71 -val assume = gen_assms bind_propps;
    2.72 -val assume_i = gen_assms bind_propps_i;
    2.73 +val assume = gen_assms bind_propp;
    2.74 +val assume_i = gen_assms bind_propp_i;
    2.75  
    2.76  end;
    2.77