1.1 --- a/doc-src/IsarImplementation/Thy/ML.thy Wed Jan 21 15:26:02 2009 +0100
1.2 +++ b/doc-src/IsarImplementation/Thy/ML.thy Wed Jan 21 20:05:31 2009 +0100
1.3 @@ -317,7 +317,7 @@
1.4 a theory by constant declararion and primitive definitions:
1.5
1.6 \smallskip\begin{mldecls}
1.7 - @{ML "Sign.declare_const: Properties.T -> (Binding.T * typ) * mixfix
1.8 + @{ML "Sign.declare_const: Properties.T -> (binding * typ) * mixfix
1.9 -> theory -> term * theory"} \\
1.10 @{ML "Thm.add_def: bool -> bool -> bstring * term -> theory -> thm * theory"}
1.11 \end{mldecls}
2.1 --- a/doc-src/IsarImplementation/Thy/document/ML.tex Wed Jan 21 15:26:02 2009 +0100
2.2 +++ b/doc-src/IsarImplementation/Thy/document/ML.tex Wed Jan 21 20:05:31 2009 +0100
2.3 @@ -366,7 +366,7 @@
2.4 a theory by constant declararion and primitive definitions:
2.5
2.6 \smallskip\begin{mldecls}
2.7 - \verb|Sign.declare_const: Properties.T -> (Binding.T * typ) * mixfix|\isasep\isanewline%
2.8 + \verb|Sign.declare_const: Properties.T -> (binding * typ) * mixfix|\isasep\isanewline%
2.9 \verb| -> theory -> term * theory| \\
2.10 \verb|Thm.add_def: bool -> bool -> bstring * term -> theory -> thm * theory|
2.11 \end{mldecls}
3.1 --- a/doc-src/IsarImplementation/Thy/document/logic.tex Wed Jan 21 15:26:02 2009 +0100
3.2 +++ b/doc-src/IsarImplementation/Thy/document/logic.tex Wed Jan 21 20:05:31 2009 +0100
3.3 @@ -325,9 +325,9 @@
3.4 \indexml{fastype\_of}\verb|fastype_of: term -> typ| \\
3.5 \indexml{lambda}\verb|lambda: term -> term -> term| \\
3.6 \indexml{betapply}\verb|betapply: term * term -> term| \\
3.7 - \indexml{Sign.declare\_const}\verb|Sign.declare_const: Properties.T -> (Binding.T * typ) * mixfix ->|\isasep\isanewline%
3.8 + \indexml{Sign.declare\_const}\verb|Sign.declare_const: Properties.T -> (binding * typ) * mixfix ->|\isasep\isanewline%
3.9 \verb| theory -> term * theory| \\
3.10 - \indexml{Sign.add\_abbrev}\verb|Sign.add_abbrev: string -> Properties.T -> Binding.T * term ->|\isasep\isanewline%
3.11 + \indexml{Sign.add\_abbrev}\verb|Sign.add_abbrev: string -> Properties.T -> binding * term ->|\isasep\isanewline%
3.12 \verb| theory -> (term * term) * theory| \\
3.13 \indexml{Sign.const\_typargs}\verb|Sign.const_typargs: theory -> string * typ -> typ list| \\
3.14 \indexml{Sign.const\_instance}\verb|Sign.const_instance: theory -> string * typ list -> typ| \\
4.1 --- a/doc-src/IsarImplementation/Thy/document/prelim.tex Wed Jan 21 15:26:02 2009 +0100
4.2 +++ b/doc-src/IsarImplementation/Thy/document/prelim.tex Wed Jan 21 20:05:31 2009 +0100
4.3 @@ -816,13 +816,13 @@
4.4 \indexmltype{NameSpace.naming}\verb|type NameSpace.naming| \\
4.5 \indexml{NameSpace.default\_naming}\verb|NameSpace.default_naming: NameSpace.naming| \\
4.6 \indexml{NameSpace.add\_path}\verb|NameSpace.add_path: string -> NameSpace.naming -> NameSpace.naming| \\
4.7 - \indexml{NameSpace.full\_name}\verb|NameSpace.full_name: NameSpace.naming -> Binding.T -> string| \\
4.8 + \indexml{NameSpace.full\_name}\verb|NameSpace.full_name: NameSpace.naming -> binding -> string| \\
4.9 \end{mldecls}
4.10 \begin{mldecls}
4.11 \indexmltype{NameSpace.T}\verb|type NameSpace.T| \\
4.12 \indexml{NameSpace.empty}\verb|NameSpace.empty: NameSpace.T| \\
4.13 \indexml{NameSpace.merge}\verb|NameSpace.merge: NameSpace.T * NameSpace.T -> NameSpace.T| \\
4.14 - \indexml{NameSpace.declare}\verb|NameSpace.declare: NameSpace.naming -> Binding.T -> NameSpace.T -> string * NameSpace.T| \\
4.15 + \indexml{NameSpace.declare}\verb|NameSpace.declare: NameSpace.naming -> binding -> NameSpace.T -> string * NameSpace.T| \\
4.16 \indexml{NameSpace.intern}\verb|NameSpace.intern: NameSpace.T -> string -> string| \\
4.17 \indexml{NameSpace.extern}\verb|NameSpace.extern: NameSpace.T -> string -> string| \\
4.18 \end{mldecls}
5.1 --- a/doc-src/IsarImplementation/Thy/logic.thy Wed Jan 21 15:26:02 2009 +0100
5.2 +++ b/doc-src/IsarImplementation/Thy/logic.thy Wed Jan 21 20:05:31 2009 +0100
5.3 @@ -323,9 +323,9 @@
5.4 @{index_ML fastype_of: "term -> typ"} \\
5.5 @{index_ML lambda: "term -> term -> term"} \\
5.6 @{index_ML betapply: "term * term -> term"} \\
5.7 - @{index_ML Sign.declare_const: "Properties.T -> (Binding.T * typ) * mixfix ->
5.8 + @{index_ML Sign.declare_const: "Properties.T -> (binding * typ) * mixfix ->
5.9 theory -> term * theory"} \\
5.10 - @{index_ML Sign.add_abbrev: "string -> Properties.T -> Binding.T * term ->
5.11 + @{index_ML Sign.add_abbrev: "string -> Properties.T -> binding * term ->
5.12 theory -> (term * term) * theory"} \\
5.13 @{index_ML Sign.const_typargs: "theory -> string * typ -> typ list"} \\
5.14 @{index_ML Sign.const_instance: "theory -> string * typ list -> typ"} \\
6.1 --- a/doc-src/IsarImplementation/Thy/prelim.thy Wed Jan 21 15:26:02 2009 +0100
6.2 +++ b/doc-src/IsarImplementation/Thy/prelim.thy Wed Jan 21 20:05:31 2009 +0100
6.3 @@ -707,13 +707,13 @@
6.4 @{index_ML_type NameSpace.naming} \\
6.5 @{index_ML NameSpace.default_naming: NameSpace.naming} \\
6.6 @{index_ML NameSpace.add_path: "string -> NameSpace.naming -> NameSpace.naming"} \\
6.7 - @{index_ML NameSpace.full_name: "NameSpace.naming -> Binding.T -> string"} \\
6.8 + @{index_ML NameSpace.full_name: "NameSpace.naming -> binding -> string"} \\
6.9 \end{mldecls}
6.10 \begin{mldecls}
6.11 @{index_ML_type NameSpace.T} \\
6.12 @{index_ML NameSpace.empty: NameSpace.T} \\
6.13 @{index_ML NameSpace.merge: "NameSpace.T * NameSpace.T -> NameSpace.T"} \\
6.14 - @{index_ML NameSpace.declare: "NameSpace.naming -> Binding.T -> NameSpace.T -> string * NameSpace.T"} \\
6.15 + @{index_ML NameSpace.declare: "NameSpace.naming -> binding -> NameSpace.T -> string * NameSpace.T"} \\
6.16 @{index_ML NameSpace.intern: "NameSpace.T -> string -> string"} \\
6.17 @{index_ML NameSpace.extern: "NameSpace.T -> string -> string"} \\
6.18 \end{mldecls}
7.1 --- a/src/HOL/ATP_Linkup.thy Wed Jan 21 15:26:02 2009 +0100
7.2 +++ b/src/HOL/ATP_Linkup.thy Wed Jan 21 20:05:31 2009 +0100
7.3 @@ -1,5 +1,4 @@
7.4 (* Title: HOL/ATP_Linkup.thy
7.5 - ID: $Id$
7.6 Author: Lawrence C Paulson
7.7 Author: Jia Meng, NICTA
7.8 Author: Fabian Immler, TUM
8.1 --- a/src/HOL/Code_Eval.thy Wed Jan 21 15:26:02 2009 +0100
8.2 +++ b/src/HOL/Code_Eval.thy Wed Jan 21 20:05:31 2009 +0100
8.3 @@ -1,5 +1,4 @@
8.4 (* Title: HOL/Code_Eval.thy
8.5 - ID: $Id$
8.6 Author: Florian Haftmann, TU Muenchen
8.7 *)
8.8
8.9 @@ -24,7 +23,7 @@
8.10 code_datatype Const App
8.11
8.12 class term_of = typerep +
8.13 - fixes term_of :: "'a \<Rightarrow> term"
8.14 + fixes term_of :: "'a::{} \<Rightarrow> term"
8.15
8.16 lemma term_of_anything: "term_of x \<equiv> t"
8.17 by (rule eq_reflection) (cases "term_of x", cases t, simp)
9.1 --- a/src/HOL/Datatype.thy Wed Jan 21 15:26:02 2009 +0100
9.2 +++ b/src/HOL/Datatype.thy Wed Jan 21 20:05:31 2009 +0100
9.3 @@ -1,5 +1,4 @@
9.4 (* Title: HOL/Datatype.thy
9.5 - ID: $Id$
9.6 Author: Lawrence C Paulson, Cambridge University Computer Laboratory
9.7 Author: Stefan Berghofer and Markus Wenzel, TU Muenchen
9.8
10.1 --- a/src/HOL/Finite_Set.thy Wed Jan 21 15:26:02 2009 +0100
10.2 +++ b/src/HOL/Finite_Set.thy Wed Jan 21 20:05:31 2009 +0100
10.3 @@ -1,5 +1,4 @@
10.4 (* Title: HOL/Finite_Set.thy
10.5 - ID: $Id$
10.6 Author: Tobias Nipkow, Lawrence C Paulson and Markus Wenzel
10.7 with contributions by Jeremy Avigad
10.8 *)
11.1 --- a/src/HOL/FunDef.thy Wed Jan 21 15:26:02 2009 +0100
11.2 +++ b/src/HOL/FunDef.thy Wed Jan 21 20:05:31 2009 +0100
11.3 @@ -1,5 +1,4 @@
11.4 (* Title: HOL/FunDef.thy
11.5 - ID: $Id$
11.6 Author: Alexander Krauss, TU Muenchen
11.7 *)
11.8
12.1 --- a/src/HOL/Import/hol4rews.ML Wed Jan 21 15:26:02 2009 +0100
12.2 +++ b/src/HOL/Import/hol4rews.ML Wed Jan 21 20:05:31 2009 +0100
12.3 @@ -390,7 +390,7 @@
12.4 val thm2 = standard thm1;
12.5 in
12.6 thy
12.7 - |> PureThy.store_thm (bthm, thm2)
12.8 + |> PureThy.store_thm (Binding.name bthm, thm2)
12.9 |> snd
12.10 |> add_hol4_theorem bthy bthm hth
12.11 end;
13.1 --- a/src/HOL/Import/proof_kernel.ML Wed Jan 21 15:26:02 2009 +0100
13.2 +++ b/src/HOL/Import/proof_kernel.ML Wed Jan 21 20:05:31 2009 +0100
13.3 @@ -1928,7 +1928,7 @@
13.4 Replaying _ => thy
13.5 | _ => (ImportRecorder.add_consts [(constname, ctype, csyn)]; Sign.add_consts_i [(constname,ctype,csyn)] thy)
13.6 val eq = mk_defeq constname rhs' thy1
13.7 - val (thms, thy2) = PureThy.add_defs false [((thmname,eq),[])] thy1
13.8 + val (thms, thy2) = PureThy.add_defs false [((Binding.name thmname,eq),[])] thy1
13.9 val _ = ImportRecorder.add_defs thmname eq
13.10 val def_thm = hd thms
13.11 val thm' = def_thm RS meta_eq_to_obj_eq_thm
14.1 --- a/src/HOL/Import/replay.ML Wed Jan 21 15:26:02 2009 +0100
14.2 +++ b/src/HOL/Import/replay.ML Wed Jan 21 20:05:31 2009 +0100
14.3 @@ -340,7 +340,7 @@
14.4 | delta (Hol_move (fullname, moved_thmname)) thy =
14.5 add_hol4_move fullname moved_thmname thy
14.6 | delta (Defs (thmname, eq)) thy =
14.7 - snd (PureThy.add_defs false [((thmname, eq), [])] thy)
14.8 + snd (PureThy.add_defs false [((Binding.name thmname, eq), [])] thy)
14.9 | delta (Hol_theorem (thyname, thmname, th)) thy =
14.10 add_hol4_theorem thyname thmname ([], th_of thy th) thy
14.11 | delta (Typedef (thmname, typ, c, repabs, th)) thy =
15.1 --- a/src/HOL/Lattices.thy Wed Jan 21 15:26:02 2009 +0100
15.2 +++ b/src/HOL/Lattices.thy Wed Jan 21 20:05:31 2009 +0100
15.3 @@ -1,5 +1,4 @@
15.4 (* Title: HOL/Lattices.thy
15.5 - ID: $Id$
15.6 Author: Tobias Nipkow
15.7 *)
15.8
16.1 --- a/src/HOL/Nominal/nominal_atoms.ML Wed Jan 21 15:26:02 2009 +0100
16.2 +++ b/src/HOL/Nominal/nominal_atoms.ML Wed Jan 21 20:05:31 2009 +0100
16.3 @@ -90,6 +90,9 @@
16.4 let val T = fastype_of x
16.5 in Const ("List.list.Cons", T --> HOLogic.listT T --> HOLogic.listT T) $ x $ xs end;
16.6
16.7 +fun add_thms_string args = PureThy.add_thms ((map o apfst o apfst) Binding.name args);
16.8 +fun add_thmss_string args = PureThy.add_thmss ((map o apfst o apfst) Binding.name args);
16.9 +
16.10 (* this function sets up all matters related to atom- *)
16.11 (* kinds; the user specifies a list of atom-kind names *)
16.12 (* atom_decl <ak1> ... <akn> *)
16.13 @@ -121,7 +124,7 @@
16.14 atac 1]
16.15
16.16 val (inj_thm,thy2) =
16.17 - PureThy.add_thms [((ak^"_inj",Goal.prove_global thy1 [] [] stmnt1 proof1), [])] thy1
16.18 + add_thms_string [((ak^"_inj",Goal.prove_global thy1 [] [] stmnt1 proof1), [])] thy1
16.19
16.20 (* second statement *)
16.21 val y = Free ("y",ak_type)
16.22 @@ -136,7 +139,7 @@
16.23
16.24 (* third statement *)
16.25 val (inject_thm,thy3) =
16.26 - PureThy.add_thms [((ak^"_injection",Goal.prove_global thy2 [] [] stmnt2 proof2), [])] thy2
16.27 + add_thms_string [((ak^"_injection",Goal.prove_global thy2 [] [] stmnt2 proof2), [])] thy2
16.28
16.29 val stmnt3 = HOLogic.mk_Trueprop
16.30 (HOLogic.mk_not
16.31 @@ -152,7 +155,7 @@
16.32 simp_tac (HOL_basic_ss addsimps simp3) 1]
16.33
16.34 val (inf_thm,thy4) =
16.35 - PureThy.add_thms [((ak^"_infinite",Goal.prove_global thy3 [] [] stmnt3 proof3), [])] thy3
16.36 + add_thms_string [((ak^"_infinite",Goal.prove_global thy3 [] [] stmnt3 proof3), [])] thy3
16.37 in
16.38 ((inj_thm,inject_thm,inf_thm),thy4)
16.39 end) ak_names thy
16.40 @@ -186,7 +189,7 @@
16.41 val def2 = Logic.mk_equals (cswap $ ab $ c, cswap_akname $ ab $ c)
16.42 in
16.43 thy |> Sign.add_consts_i [("swap_" ^ ak_name, swapT, NoSyn)]
16.44 - |> PureThy.add_defs_unchecked true [((name, def2),[])]
16.45 + |> PureThy.add_defs_unchecked true [((Binding.name name, def2),[])]
16.46 |> snd
16.47 |> OldPrimrecPackage.add_primrec_unchecked_i "" [(("", def1),[])]
16.48 end) ak_names_types thy1;
16.49 @@ -241,14 +244,14 @@
16.50 val def = Logic.mk_equals
16.51 (cperm $ pi $ a, if ak_name = ak_name' then cperm_def $ pi $ a else a)
16.52 in
16.53 - PureThy.add_defs_unchecked true [((name, def),[])] thy'
16.54 + PureThy.add_defs_unchecked true [((Binding.name name, def),[])] thy'
16.55 end) ak_names_types thy) ak_names_types thy4;
16.56
16.57 (* proves that every atom-kind is an instance of at *)
16.58 (* lemma at_<ak>_inst: *)
16.59 (* at TYPE(<ak>) *)
16.60 val (prm_cons_thms,thy6) =
16.61 - thy5 |> PureThy.add_thms (map (fn (ak_name, T) =>
16.62 + thy5 |> add_thms_string (map (fn (ak_name, T) =>
16.63 let
16.64 val ak_name_qu = Sign.full_bname thy5 (ak_name);
16.65 val i_type = Type(ak_name_qu,[]);
16.66 @@ -309,7 +312,7 @@
16.67 (* lemma pt_<ak>_inst: *)
16.68 (* pt TYPE('x::pt_<ak>) TYPE(<ak>) *)
16.69 val (prm_inst_thms,thy8) =
16.70 - thy7 |> PureThy.add_thms (map (fn (ak_name, T) =>
16.71 + thy7 |> add_thms_string (map (fn (ak_name, T) =>
16.72 let
16.73 val ak_name_qu = Sign.full_bname thy7 ak_name;
16.74 val pt_name_qu = Sign.full_bname thy7 ("pt_"^ak_name);
16.75 @@ -355,7 +358,7 @@
16.76 (* lemma abst_<ak>_inst: *)
16.77 (* fs TYPE('x::pt_<ak>) TYPE (<ak>) *)
16.78 val (fs_inst_thms,thy12) =
16.79 - thy11 |> PureThy.add_thms (map (fn (ak_name, T) =>
16.80 + thy11 |> add_thms_string (map (fn (ak_name, T) =>
16.81 let
16.82 val ak_name_qu = Sign.full_bname thy11 ak_name;
16.83 val fs_name_qu = Sign.full_bname thy11 ("fs_"^ak_name);
16.84 @@ -428,7 +431,7 @@
16.85 rtac allI 1, rtac allI 1, rtac allI 1,
16.86 rtac cp1 1];
16.87 in
16.88 - yield_singleton PureThy.add_thms ((name,
16.89 + yield_singleton add_thms_string ((name,
16.90 Goal.prove_global thy' [] [] statement proof), []) thy'
16.91 end)
16.92 ak_names_types thy) ak_names_types thy12b;
16.93 @@ -460,7 +463,7 @@
16.94
16.95 val proof = fn _ => simp_tac simp_s 1;
16.96 in
16.97 - PureThy.add_thms [((name, Goal.prove_global thy' [] [] statement proof), [])] thy'
16.98 + add_thms_string [((name, Goal.prove_global thy' [] [] statement proof), [])] thy'
16.99 end
16.100 else
16.101 ([],thy'))) (* do nothing branch, if ak_name = ak_name' *)
16.102 @@ -870,114 +873,114 @@
16.103 fun inst_pt_pt_at_cp_dj thms = inst_zip djs (inst_pt_pt_at_cp thms);
16.104 in
16.105 thy32
16.106 - |> PureThy.add_thmss [(("alpha", inst_pt_at [abs_fun_eq]),[])]
16.107 - ||>> PureThy.add_thmss [(("alpha'", inst_pt_at [abs_fun_eq']),[])]
16.108 - ||>> PureThy.add_thmss [(("alpha_fresh", inst_pt_at [abs_fun_fresh]),[])]
16.109 - ||>> PureThy.add_thmss [(("alpha_fresh'", inst_pt_at [abs_fun_fresh']),[])]
16.110 - ||>> PureThy.add_thmss [(("perm_swap", inst_pt_at [pt_swap_bij] @ inst_pt_at [pt_swap_bij']),[])]
16.111 - ||>> PureThy.add_thmss
16.112 + |> add_thmss_string [(("alpha", inst_pt_at [abs_fun_eq]),[])]
16.113 + ||>> add_thmss_string [(("alpha'", inst_pt_at [abs_fun_eq']),[])]
16.114 + ||>> add_thmss_string [(("alpha_fresh", inst_pt_at [abs_fun_fresh]),[])]
16.115 + ||>> add_thmss_string [(("alpha_fresh'", inst_pt_at [abs_fun_fresh']),[])]
16.116 + ||>> add_thmss_string [(("perm_swap", inst_pt_at [pt_swap_bij] @ inst_pt_at [pt_swap_bij']),[])]
16.117 + ||>> add_thmss_string
16.118 let val thms1 = inst_at at_swap_simps
16.119 and thms2 = inst_dj [dj_perm_forget]
16.120 in [(("swap_simps", thms1 @ thms2),[])] end
16.121 - ||>> PureThy.add_thmss
16.122 + ||>> add_thmss_string
16.123 let val thms1 = inst_pt_at [pt_pi_rev];
16.124 val thms2 = inst_pt_at [pt_rev_pi];
16.125 in [(("perm_pi_simp",thms1 @ thms2),[])] end
16.126 - ||>> PureThy.add_thmss [(("perm_fresh_fresh", inst_pt_at [pt_fresh_fresh]),[])]
16.127 - ||>> PureThy.add_thmss [(("perm_bij", inst_pt_at [pt_bij]),[])]
16.128 - ||>> PureThy.add_thmss
16.129 + ||>> add_thmss_string [(("perm_fresh_fresh", inst_pt_at [pt_fresh_fresh]),[])]
16.130 + ||>> add_thmss_string [(("perm_bij", inst_pt_at [pt_bij]),[])]
16.131 + ||>> add_thmss_string
16.132 let val thms1 = inst_pt_at [pt_perm_compose];
16.133 val thms2 = instR cp1 (Library.flat cps');
16.134 in [(("perm_compose",thms1 @ thms2),[])] end
16.135 - ||>> PureThy.add_thmss [(("perm_compose'",inst_pt_at [pt_perm_compose']),[])]
16.136 - ||>> PureThy.add_thmss [(("perm_app", inst_pt_at [perm_app]),[])]
16.137 - ||>> PureThy.add_thmss [(("supp_atm", (inst_at [at_supp]) @ (inst_dj [dj_supp])),[])]
16.138 - ||>> PureThy.add_thmss [(("exists_fresh", inst_at [at_exists_fresh]),[])]
16.139 - ||>> PureThy.add_thmss [(("exists_fresh'", inst_at [at_exists_fresh']),[])]
16.140 - ||>> PureThy.add_thmss
16.141 + ||>> add_thmss_string [(("perm_compose'",inst_pt_at [pt_perm_compose']),[])]
16.142 + ||>> add_thmss_string [(("perm_app", inst_pt_at [perm_app]),[])]
16.143 + ||>> add_thmss_string [(("supp_atm", (inst_at [at_supp]) @ (inst_dj [dj_supp])),[])]
16.144 + ||>> add_thmss_string [(("exists_fresh", inst_at [at_exists_fresh]),[])]
16.145 + ||>> add_thmss_string [(("exists_fresh'", inst_at [at_exists_fresh']),[])]
16.146 + ||>> add_thmss_string
16.147 let
16.148 val thms1 = inst_pt_at [all_eqvt];
16.149 val thms2 = map (fold_rule [inductive_forall_def]) thms1
16.150 in
16.151 [(("all_eqvt", thms1 @ thms2), [NominalThmDecls.eqvt_force_add])]
16.152 end
16.153 - ||>> PureThy.add_thmss [(("ex_eqvt", inst_pt_at [ex_eqvt]),[NominalThmDecls.eqvt_force_add])]
16.154 - ||>> PureThy.add_thmss [(("ex1_eqvt", inst_pt_at [ex1_eqvt]),[NominalThmDecls.eqvt_force_add])]
16.155 - ||>> PureThy.add_thmss [(("the_eqvt", inst_pt_at [the_eqvt]),[NominalThmDecls.eqvt_force_add])]
16.156 - ||>> PureThy.add_thmss
16.157 + ||>> add_thmss_string [(("ex_eqvt", inst_pt_at [ex_eqvt]),[NominalThmDecls.eqvt_force_add])]
16.158 + ||>> add_thmss_string [(("ex1_eqvt", inst_pt_at [ex1_eqvt]),[NominalThmDecls.eqvt_force_add])]
16.159 + ||>> add_thmss_string [(("the_eqvt", inst_pt_at [the_eqvt]),[NominalThmDecls.eqvt_force_add])]
16.160 + ||>> add_thmss_string
16.161 let val thms1 = inst_at [at_fresh]
16.162 val thms2 = inst_dj [at_fresh_ineq]
16.163 in [(("fresh_atm", thms1 @ thms2),[])] end
16.164 - ||>> PureThy.add_thmss
16.165 + ||>> add_thmss_string
16.166 let val thms1 = inst_at at_calc
16.167 and thms2 = inst_dj [dj_perm_forget]
16.168 in [(("calc_atm", thms1 @ thms2),[])] end
16.169 - ||>> PureThy.add_thmss
16.170 + ||>> add_thmss_string
16.171 let val thms1 = inst_pt_at [abs_fun_pi]
16.172 and thms2 = inst_pt_pt_at_cp [abs_fun_pi_ineq]
16.173 in [(("abs_perm", thms1 @ thms2),[NominalThmDecls.eqvt_add])] end
16.174 - ||>> PureThy.add_thmss
16.175 + ||>> add_thmss_string
16.176 let val thms1 = inst_dj [dj_perm_forget]
16.177 and thms2 = inst_dj [dj_pp_forget]
16.178 in [(("perm_dj", thms1 @ thms2),[])] end
16.179 - ||>> PureThy.add_thmss
16.180 + ||>> add_thmss_string
16.181 let val thms1 = inst_pt_at_fs [fresh_iff]
16.182 and thms2 = inst_pt_at [fresh_iff]
16.183 and thms3 = inst_pt_pt_at_cp_dj [fresh_iff_ineq]
16.184 in [(("abs_fresh", thms1 @ thms2 @ thms3),[])] end
16.185 - ||>> PureThy.add_thmss
16.186 + ||>> add_thmss_string
16.187 let val thms1 = inst_pt_at [abs_fun_supp]
16.188 and thms2 = inst_pt_at_fs [abs_fun_supp]
16.189 and thms3 = inst_pt_pt_at_cp_dj [abs_fun_supp_ineq]
16.190 in [(("abs_supp", thms1 @ thms2 @ thms3),[])] end
16.191 - ||>> PureThy.add_thmss
16.192 + ||>> add_thmss_string
16.193 let val thms1 = inst_pt_at [fresh_left]
16.194 and thms2 = inst_pt_pt_at_cp [fresh_left_ineq]
16.195 in [(("fresh_left", thms1 @ thms2),[])] end
16.196 - ||>> PureThy.add_thmss
16.197 + ||>> add_thmss_string
16.198 let val thms1 = inst_pt_at [fresh_right]
16.199 and thms2 = inst_pt_pt_at_cp [fresh_right_ineq]
16.200 in [(("fresh_right", thms1 @ thms2),[])] end
16.201 - ||>> PureThy.add_thmss
16.202 + ||>> add_thmss_string
16.203 let val thms1 = inst_pt_at [fresh_bij]
16.204 and thms2 = inst_pt_pt_at_cp [fresh_bij_ineq]
16.205 in [(("fresh_bij", thms1 @ thms2),[])] end
16.206 - ||>> PureThy.add_thmss
16.207 + ||>> add_thmss_string
16.208 let val thms1 = inst_pt_at fresh_star_bij
16.209 and thms2 = flat (map (fn ti => inst_pt_pt_at_cp [ti]) fresh_star_bij_ineq);
16.210 in [(("fresh_star_bij", thms1 @ thms2),[])] end
16.211 - ||>> PureThy.add_thmss
16.212 + ||>> add_thmss_string
16.213 let val thms1 = inst_pt_at [fresh_eqvt]
16.214 and thms2 = inst_pt_pt_at_cp_dj [fresh_eqvt_ineq]
16.215 in [(("fresh_eqvt", thms1 @ thms2),[NominalThmDecls.eqvt_add])] end
16.216 - ||>> PureThy.add_thmss
16.217 + ||>> add_thmss_string
16.218 let val thms1 = inst_pt_at [in_eqvt]
16.219 in [(("in_eqvt", thms1),[NominalThmDecls.eqvt_add])] end
16.220 - ||>> PureThy.add_thmss
16.221 + ||>> add_thmss_string
16.222 let val thms1 = inst_pt_at [eq_eqvt]
16.223 in [(("eq_eqvt", thms1),[NominalThmDecls.eqvt_add])] end
16.224 - ||>> PureThy.add_thmss
16.225 + ||>> add_thmss_string
16.226 let val thms1 = inst_pt_at [set_diff_eqvt]
16.227 in [(("set_diff_eqvt", thms1),[NominalThmDecls.eqvt_add])] end
16.228 - ||>> PureThy.add_thmss
16.229 + ||>> add_thmss_string
16.230 let val thms1 = inst_pt_at [subseteq_eqvt]
16.231 in [(("subseteq_eqvt", thms1),[NominalThmDecls.eqvt_add])] end
16.232 - ||>> PureThy.add_thmss [(("insert_eqvt", inst_pt_at [insert_eqvt]), [NominalThmDecls.eqvt_add])]
16.233 - ||>> PureThy.add_thmss [(("set_eqvt", inst_pt_at [set_eqvt]), [NominalThmDecls.eqvt_add])]
16.234 - ||>> PureThy.add_thmss [(("perm_set_eq", inst_pt_at [perm_set_eq]), [])]
16.235 - ||>> PureThy.add_thmss
16.236 + ||>> add_thmss_string [(("insert_eqvt", inst_pt_at [insert_eqvt]), [NominalThmDecls.eqvt_add])]
16.237 + ||>> add_thmss_string [(("set_eqvt", inst_pt_at [set_eqvt]), [NominalThmDecls.eqvt_add])]
16.238 + ||>> add_thmss_string [(("perm_set_eq", inst_pt_at [perm_set_eq]), [])]
16.239 + ||>> add_thmss_string
16.240 let val thms1 = inst_pt_at [fresh_aux]
16.241 and thms2 = inst_pt_pt_at_cp_dj [fresh_perm_app_ineq]
16.242 in [(("fresh_aux", thms1 @ thms2),[])] end
16.243 - ||>> PureThy.add_thmss
16.244 + ||>> add_thmss_string
16.245 let val thms1 = inst_pt_at [fresh_perm_app]
16.246 and thms2 = inst_pt_pt_at_cp_dj [fresh_perm_app_ineq]
16.247 in [(("fresh_perm_app", thms1 @ thms2),[])] end
16.248 - ||>> PureThy.add_thmss
16.249 + ||>> add_thmss_string
16.250 let val thms1 = inst_pt_at [pt_perm_supp]
16.251 and thms2 = inst_pt_pt_at_cp [pt_perm_supp_ineq]
16.252 in [(("supp_eqvt", thms1 @ thms2),[NominalThmDecls.eqvt_add])] end
16.253 - ||>> PureThy.add_thmss [(("fin_supp",fs_axs),[])]
16.254 + ||>> add_thmss_string [(("fin_supp",fs_axs),[])]
16.255 end;
16.256
16.257 in
17.1 --- a/src/HOL/Nominal/nominal_induct.ML Wed Jan 21 15:26:02 2009 +0100
17.2 +++ b/src/HOL/Nominal/nominal_induct.ML Wed Jan 21 20:05:31 2009 +0100
17.3 @@ -6,7 +6,7 @@
17.4
17.5 structure NominalInduct:
17.6 sig
17.7 - val nominal_induct_tac: Proof.context -> (Binding.T option * term) option list list ->
17.8 + val nominal_induct_tac: Proof.context -> (binding option * term) option list list ->
17.9 (string * typ) list -> (string * typ) list list -> thm list ->
17.10 thm list -> int -> RuleCases.cases_tactic
17.11 val nominal_induct_method: Method.src -> Proof.context -> Method.method
18.1 --- a/src/HOL/Nominal/nominal_inductive.ML Wed Jan 21 15:26:02 2009 +0100
18.2 +++ b/src/HOL/Nominal/nominal_inductive.ML Wed Jan 21 20:05:31 2009 +0100
18.3 @@ -562,17 +562,17 @@
18.4 [ind_case_names, RuleCases.consumes 1]);
18.5 val ([strong_induct'], thy') = thy |>
18.6 Sign.add_path rec_name |>
18.7 - PureThy.add_thms [(("strong_induct", #1 strong_induct), #2 strong_induct)];
18.8 + PureThy.add_thms [((Binding.name "strong_induct", #1 strong_induct), #2 strong_induct)];
18.9 val strong_inducts =
18.10 ProjectRule.projects ctxt (1 upto length names) strong_induct'
18.11 in
18.12 thy' |>
18.13 - PureThy.add_thmss [(("strong_inducts", strong_inducts),
18.14 + PureThy.add_thmss [((Binding.name "strong_inducts", strong_inducts),
18.15 [ind_case_names, RuleCases.consumes 1])] |> snd |>
18.16 Sign.parent_path |>
18.17 fold (fn ((name, elim), (_, cases)) =>
18.18 Sign.add_path (Sign.base_name name) #>
18.19 - PureThy.add_thms [(("strong_cases", elim),
18.20 + PureThy.add_thms [((Binding.name "strong_cases", elim),
18.21 [RuleCases.case_names (map snd cases),
18.22 RuleCases.consumes 1])] #> snd #>
18.23 Sign.parent_path) (strong_cases ~~ induct_cases')
18.24 @@ -653,7 +653,7 @@
18.25 in
18.26 fold (fn (name, ths) =>
18.27 Sign.add_path (Sign.base_name name) #>
18.28 - PureThy.add_thmss [(("eqvt", ths), [NominalThmDecls.eqvt_add])] #> snd #>
18.29 + PureThy.add_thmss [((Binding.name "eqvt", ths), [NominalThmDecls.eqvt_add])] #> snd #>
18.30 Sign.parent_path) (names ~~ transp thss) thy
18.31 end;
18.32
19.1 --- a/src/HOL/Nominal/nominal_inductive2.ML Wed Jan 21 15:26:02 2009 +0100
19.2 +++ b/src/HOL/Nominal/nominal_inductive2.ML Wed Jan 21 20:05:31 2009 +0100
19.3 @@ -458,12 +458,12 @@
19.4 [ind_case_names, RuleCases.consumes 1]);
19.5 val ([strong_induct'], thy') = thy |>
19.6 Sign.add_path rec_name |>
19.7 - PureThy.add_thms [(("strong_induct", #1 strong_induct), #2 strong_induct)];
19.8 + PureThy.add_thms [((Binding.name "strong_induct", #1 strong_induct), #2 strong_induct)];
19.9 val strong_inducts =
19.10 ProjectRule.projects ctxt (1 upto length names) strong_induct'
19.11 in
19.12 thy' |>
19.13 - PureThy.add_thmss [(("strong_inducts", strong_inducts),
19.14 + PureThy.add_thmss [((Binding.name "strong_inducts", strong_inducts),
19.15 [ind_case_names, RuleCases.consumes 1])] |> snd |>
19.16 Sign.parent_path
19.17 end))
20.1 --- a/src/HOL/Nominal/nominal_package.ML Wed Jan 21 15:26:02 2009 +0100
20.2 +++ b/src/HOL/Nominal/nominal_package.ML Wed Jan 21 20:05:31 2009 +0100
20.3 @@ -490,13 +490,13 @@
20.4 (full_new_type_names' ~~ tyvars) thy
20.5 end) atoms |>
20.6 PureThy.add_thmss
20.7 - [((space_implode "_" new_type_names ^ "_unfolded_perm_eq",
20.8 + [((Binding.name (space_implode "_" new_type_names ^ "_unfolded_perm_eq"),
20.9 unfolded_perm_eq_thms), [Simplifier.simp_add]),
20.10 - ((space_implode "_" new_type_names ^ "_perm_empty",
20.11 + ((Binding.name (space_implode "_" new_type_names ^ "_perm_empty"),
20.12 perm_empty_thms), [Simplifier.simp_add]),
20.13 - ((space_implode "_" new_type_names ^ "_perm_append",
20.14 + ((Binding.name (space_implode "_" new_type_names ^ "_perm_append"),
20.15 perm_append_thms), [Simplifier.simp_add]),
20.16 - ((space_implode "_" new_type_names ^ "_perm_eq",
20.17 + ((Binding.name (space_implode "_" new_type_names ^ "_perm_eq"),
20.18 perm_eq_thms), [Simplifier.simp_add])];
20.19
20.20 (**** Define representing sets ****)
20.21 @@ -627,7 +627,7 @@
20.22 val pi = Free ("pi", permT);
20.23 val T = Type (Sign.intern_type thy name, map TFree tvs);
20.24 in apfst (pair r o hd)
20.25 - (PureThy.add_defs_unchecked true [(("prm_" ^ name ^ "_def", Logic.mk_equals
20.26 + (PureThy.add_defs_unchecked true [((Binding.name ("prm_" ^ name ^ "_def"), Logic.mk_equals
20.27 (Const ("Nominal.perm", permT --> T --> T) $ pi $ Free ("x", T),
20.28 Const (Sign.intern_const thy ("Abs_" ^ name), U --> T) $
20.29 (Const ("Nominal.perm", permT --> U --> U) $ pi $
20.30 @@ -801,7 +801,7 @@
20.31 val def_name = (Sign.base_name cname) ^ "_def";
20.32 val ([def_thm], thy') = thy |>
20.33 Sign.add_consts_i [(cname', constrT, mx)] |>
20.34 - (PureThy.add_defs false o map Thm.no_attributes) [(def_name, def)]
20.35 + (PureThy.add_defs false o map Thm.no_attributes) [(Binding.name def_name, def)]
20.36 in (thy', defs @ [def_thm], eqns @ [eqn]) end;
20.37
20.38 fun dt_constr_defs ((thy, defs, eqns, dist_lemmas), ((((((_, (_, _, constrs)),
20.39 @@ -1114,8 +1114,8 @@
20.40
20.41 val (_, thy9) = thy8 |>
20.42 Sign.add_path big_name |>
20.43 - PureThy.add_thms [(("induct", dt_induct), [case_names_induct])] ||>>
20.44 - PureThy.add_thmss [(("inducts", projections dt_induct), [case_names_induct])] ||>
20.45 + PureThy.add_thms [((Binding.name "induct", dt_induct), [case_names_induct])] ||>>
20.46 + PureThy.add_thmss [((Binding.name "inducts", projections dt_induct), [case_names_induct])] ||>
20.47 Sign.parent_path ||>>
20.48 DatatypeAux.store_thmss_atts "distinct" new_type_names simp_atts distinct_thms ||>>
20.49 DatatypeAux.store_thmss "constr_rep" new_type_names constr_rep_thmss ||>>
20.50 @@ -1405,9 +1405,9 @@
20.51
20.52 val (_, thy10) = thy9 |>
20.53 Sign.add_path big_name |>
20.54 - PureThy.add_thms [(("strong_induct'", induct_aux), [])] ||>>
20.55 - PureThy.add_thms [(("strong_induct", induct), [case_names_induct])] ||>>
20.56 - PureThy.add_thmss [(("strong_inducts", projections induct), [case_names_induct])];
20.57 + PureThy.add_thms [((Binding.name "strong_induct'", induct_aux), [])] ||>>
20.58 + PureThy.add_thms [((Binding.name "strong_induct", induct), [case_names_induct])] ||>>
20.59 + PureThy.add_thmss [((Binding.name "strong_inducts", projections induct), [case_names_induct])];
20.60
20.61 (**** recursion combinator ****)
20.62
20.63 @@ -2015,7 +2015,7 @@
20.64 (Sign.base_name name, rec_fn_Ts @ [T] ---> T', NoSyn))
20.65 (reccomb_names ~~ recTs ~~ rec_result_Ts))
20.66 |> (PureThy.add_defs false o map Thm.no_attributes) (map (fn ((((name, comb), set), T), T') =>
20.67 - ((Sign.base_name name) ^ "_def", Logic.mk_equals (comb, absfree ("x", T,
20.68 + (Binding.name (Sign.base_name name ^ "_def"), Logic.mk_equals (comb, absfree ("x", T,
20.69 Const ("The", (T' --> HOLogic.boolT) --> T') $ absfree ("y", T',
20.70 set $ Free ("x", T) $ Free ("y", T'))))))
20.71 (reccomb_names ~~ reccombs ~~ rec_sets ~~ recTs ~~ rec_result_Ts));
20.72 @@ -2052,12 +2052,12 @@
20.73 (* FIXME: theorems are stored in database for testing only *)
20.74 val (_, thy13) = thy12 |>
20.75 PureThy.add_thmss
20.76 - [(("rec_equiv", List.concat rec_equiv_thms), []),
20.77 - (("rec_equiv'", List.concat rec_equiv_thms'), []),
20.78 - (("rec_fin_supp", List.concat rec_fin_supp_thms), []),
20.79 - (("rec_fresh", List.concat rec_fresh_thms), []),
20.80 - (("rec_unique", map standard rec_unique_thms), []),
20.81 - (("recs", rec_thms), [])] ||>
20.82 + [((Binding.name "rec_equiv", List.concat rec_equiv_thms), []),
20.83 + ((Binding.name "rec_equiv'", List.concat rec_equiv_thms'), []),
20.84 + ((Binding.name "rec_fin_supp", List.concat rec_fin_supp_thms), []),
20.85 + ((Binding.name "rec_fresh", List.concat rec_fresh_thms), []),
20.86 + ((Binding.name "rec_unique", map standard rec_unique_thms), []),
20.87 + ((Binding.name "recs", rec_thms), [])] ||>
20.88 Sign.parent_path ||>
20.89 map_nominal_datatypes (fold Symtab.update dt_infos);
20.90
21.1 --- a/src/HOL/Nominal/nominal_primrec.ML Wed Jan 21 15:26:02 2009 +0100
21.2 +++ b/src/HOL/Nominal/nominal_primrec.ML Wed Jan 21 20:05:31 2009 +0100
21.3 @@ -9,8 +9,8 @@
21.4 signature NOMINAL_PRIMREC =
21.5 sig
21.6 val add_primrec: term list option -> term option ->
21.7 - (Binding.T * typ option * mixfix) list ->
21.8 - (Binding.T * typ option * mixfix) list ->
21.9 + (binding * typ option * mixfix) list ->
21.10 + (binding * typ option * mixfix) list ->
21.11 (Attrib.binding * term) list -> local_theory -> Proof.state
21.12 end;
21.13
22.1 --- a/src/HOL/Nominal/nominal_thmdecls.ML Wed Jan 21 15:26:02 2009 +0100
22.2 +++ b/src/HOL/Nominal/nominal_thmdecls.ML Wed Jan 21 20:05:31 2009 +0100
22.3 @@ -187,8 +187,8 @@
22.4 "equivariance theorem declaration (without checking the form of the lemma)"),
22.5 ("fresh", Attrib.add_del_args fresh_add fresh_del, "freshness theorem declaration"),
22.6 ("bij", Attrib.add_del_args bij_add bij_del, "bijection theorem declaration")] #>
22.7 - PureThy.add_thms_dynamic ("eqvts", #eqvts o Data.get) #>
22.8 - PureThy.add_thms_dynamic ("freshs", #freshs o Data.get) #>
22.9 - PureThy.add_thms_dynamic ("bijs", #bijs o Data.get);
22.10 + PureThy.add_thms_dynamic (Binding.name "eqvts", #eqvts o Data.get) #>
22.11 + PureThy.add_thms_dynamic (Binding.name "freshs", #freshs o Data.get) #>
22.12 + PureThy.add_thms_dynamic (Binding.name "bijs", #bijs o Data.get);
22.13
22.14 end;
23.1 --- a/src/HOL/Orderings.thy Wed Jan 21 15:26:02 2009 +0100
23.2 +++ b/src/HOL/Orderings.thy Wed Jan 21 20:05:31 2009 +0100
23.3 @@ -1,5 +1,4 @@
23.4 (* Title: HOL/Orderings.thy
23.5 - ID: $Id$
23.6 Author: Tobias Nipkow, Markus Wenzel, and Larry Paulson
23.7 *)
23.8
24.1 --- a/src/HOL/Tools/TFL/tfl.ML Wed Jan 21 15:26:02 2009 +0100
24.2 +++ b/src/HOL/Tools/TFL/tfl.ML Wed Jan 21 20:05:31 2009 +0100
24.3 @@ -390,7 +390,7 @@
24.4 (wfrec $ map_types poly_tvars R)
24.5 $ functional
24.6 val def_term = mk_const_def thy (x, Ty, wfrec_R_M)
24.7 - val ([def], thy') = PureThy.add_defs false [Thm.no_attributes (def_name, def_term)] thy
24.8 + val ([def], thy') = PureThy.add_defs false [Thm.no_attributes (Binding.name def_name, def_term)] thy
24.9 in (thy', def) end;
24.10 end;
24.11
24.12 @@ -549,7 +549,7 @@
24.13 val ([def0], theory) =
24.14 thy
24.15 |> PureThy.add_defs false
24.16 - [Thm.no_attributes (fid ^ "_def", defn)]
24.17 + [Thm.no_attributes (Binding.name (fid ^ "_def"), defn)]
24.18 val def = Thm.freezeT def0;
24.19 val dummy = if !trace then writeln ("DEF = " ^ Display.string_of_thm def)
24.20 else ()
25.1 --- a/src/HOL/Tools/datatype_abs_proofs.ML Wed Jan 21 15:26:02 2009 +0100
25.2 +++ b/src/HOL/Tools/datatype_abs_proofs.ML Wed Jan 21 20:05:31 2009 +0100
25.3 @@ -238,7 +238,7 @@
25.4 (Sign.base_name name, reccomb_fn_Ts @ [T] ---> T', NoSyn))
25.5 (reccomb_names ~~ recTs ~~ rec_result_Ts))
25.6 |> (PureThy.add_defs false o map Thm.no_attributes) (map (fn ((((name, comb), set), T), T') =>
25.7 - ((Sign.base_name name) ^ "_def", Logic.mk_equals (comb, absfree ("x", T,
25.8 + (Binding.name (Sign.base_name name ^ "_def"), Logic.mk_equals (comb, absfree ("x", T,
25.9 Const ("The", (T' --> HOLogic.boolT) --> T') $ absfree ("y", T',
25.10 set $ Free ("x", T) $ Free ("y", T'))))))
25.11 (reccomb_names ~~ reccombs ~~ rec_sets ~~ recTs ~~ rec_result_Ts))
25.12 @@ -262,7 +262,7 @@
25.13 in
25.14 thy2
25.15 |> Sign.add_path (space_implode "_" new_type_names)
25.16 - |> PureThy.add_thmss [(("recs", rec_thms), [])]
25.17 + |> PureThy.add_thmss [((Binding.name "recs", rec_thms), [])]
25.18 ||> Sign.parent_path
25.19 ||> Theory.checkpoint
25.20 |-> (fn thms => pair (reccomb_names, Library.flat thms))
25.21 @@ -316,7 +316,7 @@
25.22 fns2 @ (List.concat (Library.drop (i + 1, case_dummy_fns)));
25.23 val reccomb = Const (recname, (map fastype_of fns) @ [T] ---> T');
25.24 val decl = ((Binding.name (Sign.base_name name), caseT), NoSyn);
25.25 - val def = ((Sign.base_name name) ^ "_def",
25.26 + val def = (Binding.name (Sign.base_name name ^ "_def"),
25.27 Logic.mk_equals (list_comb (Const (name, caseT), fns1),
25.28 list_comb (reccomb, (List.concat (Library.take (i, case_dummy_fns))) @
25.29 fns2 @ (List.concat (Library.drop (i + 1, case_dummy_fns))) )));
26.1 --- a/src/HOL/Tools/datatype_aux.ML Wed Jan 21 15:26:02 2009 +0100
26.2 +++ b/src/HOL/Tools/datatype_aux.ML Wed Jan 21 20:05:31 2009 +0100
26.3 @@ -76,7 +76,7 @@
26.4 fun store_thmss_atts label tnames attss thmss =
26.5 fold_map (fn ((tname, atts), thms) =>
26.6 Sign.add_path tname
26.7 - #> PureThy.add_thmss [((label, thms), atts)]
26.8 + #> PureThy.add_thmss [((Binding.name label, thms), atts)]
26.9 #-> (fn thm::_ => Sign.parent_path #> pair thm)) (tnames ~~ attss ~~ thmss)
26.10 ##> Theory.checkpoint;
26.11
26.12 @@ -85,7 +85,7 @@
26.13 fun store_thms_atts label tnames attss thmss =
26.14 fold_map (fn ((tname, atts), thms) =>
26.15 Sign.add_path tname
26.16 - #> PureThy.add_thms [((label, thms), atts)]
26.17 + #> PureThy.add_thms [((Binding.name label, thms), atts)]
26.18 #-> (fn thm::_ => Sign.parent_path #> pair thm)) (tnames ~~ attss ~~ thmss)
26.19 ##> Theory.checkpoint;
26.20
27.1 --- a/src/HOL/Tools/datatype_package.ML Wed Jan 21 15:26:02 2009 +0100
27.2 +++ b/src/HOL/Tools/datatype_package.ML Wed Jan 21 20:05:31 2009 +0100
27.3 @@ -196,13 +196,13 @@
27.4
27.5 fun add_rules simps case_thms rec_thms inject distinct
27.6 weak_case_congs cong_att =
27.7 - PureThy.add_thmss [(("simps", simps), []),
27.8 - (("", flat case_thms @
27.9 + PureThy.add_thmss [((Binding.name "simps", simps), []),
27.10 + ((Binding.empty, flat case_thms @
27.11 flat distinct @ rec_thms), [Simplifier.simp_add]),
27.12 - (("", rec_thms), [Code.add_default_eqn_attribute]),
27.13 - (("", flat inject), [iff_add]),
27.14 - (("", map (fn th => th RS notE) (flat distinct)), [Classical.safe_elim NONE]),
27.15 - (("", weak_case_congs), [cong_att])]
27.16 + ((Binding.empty, rec_thms), [Code.add_default_eqn_attribute]),
27.17 + ((Binding.empty, flat inject), [iff_add]),
27.18 + ((Binding.empty, map (fn th => th RS notE) (flat distinct)), [Classical.safe_elim NONE]),
27.19 + ((Binding.empty, weak_case_congs), [cong_att])]
27.20 #> snd;
27.21
27.22
27.23 @@ -213,15 +213,15 @@
27.24 val inducts = ProjectRule.projections (ProofContext.init thy) induction;
27.25
27.26 fun named_rules (name, {index, exhaustion, ...}: datatype_info) =
27.27 - [(("", nth inducts index), [Induct.induct_type name]),
27.28 - (("", exhaustion), [Induct.cases_type name])];
27.29 + [((Binding.empty, nth inducts index), [Induct.induct_type name]),
27.30 + ((Binding.empty, exhaustion), [Induct.cases_type name])];
27.31 fun unnamed_rule i =
27.32 - (("", nth inducts i), [Thm.kind_internal, Induct.induct_type ""]);
27.33 + ((Binding.empty, nth inducts i), [Thm.kind_internal, Induct.induct_type ""]);
27.34 in
27.35 thy |> PureThy.add_thms
27.36 (maps named_rules infos @
27.37 map unnamed_rule (length infos upto length inducts - 1)) |> snd
27.38 - |> PureThy.add_thmss [(("inducts", inducts), [])] |> snd
27.39 + |> PureThy.add_thmss [((Binding.name "inducts", inducts), [])] |> snd
27.40 end;
27.41
27.42
27.43 @@ -451,7 +451,7 @@
27.44 |> store_thmss "inject" new_type_names inject
27.45 ||>> store_thmss "distinct" new_type_names distinct
27.46 ||> Sign.add_path (space_implode "_" new_type_names)
27.47 - ||>> PureThy.add_thms [(("induct", induct), [case_names_induct])];
27.48 + ||>> PureThy.add_thms [((Binding.name "induct", induct), [case_names_induct])];
27.49
27.50 val dt_infos = map (make_dt_info alt_names descr sorts induct' reccomb_names rec_thms)
27.51 ((0 upto length descr - 1) ~~ descr ~~ case_names ~~ case_thms ~~ casedist_thms ~~
28.1 --- a/src/HOL/Tools/datatype_realizer.ML Wed Jan 21 15:26:02 2009 +0100
28.2 +++ b/src/HOL/Tools/datatype_realizer.ML Wed Jan 21 20:05:31 2009 +0100
28.3 @@ -130,7 +130,7 @@
28.4 val vs = map (fn i => List.nth (pnames, i)) is;
28.5 val (thm', thy') = thy
28.6 |> Sign.absolute_path
28.7 - |> PureThy.store_thm (space_implode "_" (ind_name :: vs @ ["correctness"]), thm)
28.8 + |> PureThy.store_thm (Binding.name (space_implode "_" (ind_name :: vs @ ["correctness"])), thm)
28.9 ||> Sign.restore_naming thy;
28.10
28.11 val ivs = rev (Term.add_vars (Logic.varify (DatatypeProp.make_ind [descr] sorts)) []);
28.12 @@ -196,7 +196,7 @@
28.13 val exh_name = Thm.get_name exhaustion;
28.14 val (thm', thy') = thy
28.15 |> Sign.absolute_path
28.16 - |> PureThy.store_thm (exh_name ^ "_P_correctness", thm)
28.17 + |> PureThy.store_thm (Binding.name (exh_name ^ "_P_correctness"), thm)
28.18 ||> Sign.restore_naming thy;
28.19
28.20 val P = Var (("P", 0), rT' --> HOLogic.boolT);
29.1 --- a/src/HOL/Tools/datatype_rep_proofs.ML Wed Jan 21 15:26:02 2009 +0100
29.2 +++ b/src/HOL/Tools/datatype_rep_proofs.ML Wed Jan 21 20:05:31 2009 +0100
29.3 @@ -242,7 +242,7 @@
29.4 val ([def_thm], thy') =
29.5 thy
29.6 |> Sign.add_consts_i [(cname', constrT, mx)]
29.7 - |> (PureThy.add_defs false o map Thm.no_attributes) [(def_name, def)];
29.8 + |> (PureThy.add_defs false o map Thm.no_attributes) [(Binding.name def_name, def)];
29.9
29.10 in (thy', defs @ [def_thm], eqns @ [eqn], i + 1) end;
29.11
29.12 @@ -343,7 +343,7 @@
29.13
29.14 val (fs, eqns, isos) = Library.foldl process_dt (([], [], []), ds);
29.15 val fTs = map fastype_of fs;
29.16 - val defs = map (fn (rec_name, (T, iso_name)) => ((Sign.base_name iso_name) ^ "_def",
29.17 + val defs = map (fn (rec_name, (T, iso_name)) => (Binding.name (Sign.base_name iso_name ^ "_def"),
29.18 Logic.mk_equals (Const (iso_name, T --> Univ_elT),
29.19 list_comb (Const (rec_name, fTs @ [T] ---> Univ_elT), fs)))) (rec_names ~~ isos);
29.20 val (def_thms, thy') =
29.21 @@ -631,7 +631,7 @@
29.22 val ([dt_induct'], thy7) =
29.23 thy6
29.24 |> Sign.add_path big_name
29.25 - |> PureThy.add_thms [(("induct", dt_induct), [case_names_induct])]
29.26 + |> PureThy.add_thms [((Binding.name "induct", dt_induct), [case_names_induct])]
29.27 ||> Sign.parent_path
29.28 ||> Theory.checkpoint;
29.29
30.1 --- a/src/HOL/Tools/function_package/fundef_package.ML Wed Jan 21 15:26:02 2009 +0100
30.2 +++ b/src/HOL/Tools/function_package/fundef_package.ML Wed Jan 21 20:05:31 2009 +0100
30.3 @@ -9,14 +9,14 @@
30.4
30.5 signature FUNDEF_PACKAGE =
30.6 sig
30.7 - val add_fundef : (Binding.T * string option * mixfix) list
30.8 + val add_fundef : (binding * string option * mixfix) list
30.9 -> (Attrib.binding * string) list
30.10 -> FundefCommon.fundef_config
30.11 -> bool list
30.12 -> local_theory
30.13 -> Proof.state
30.14
30.15 - val add_fundef_i: (Binding.T * typ option * mixfix) list
30.16 + val add_fundef_i: (binding * typ option * mixfix) list
30.17 -> (Attrib.binding * term) list
30.18 -> FundefCommon.fundef_config
30.19 -> bool list
31.1 --- a/src/HOL/Tools/function_package/size.ML Wed Jan 21 15:26:02 2009 +0100
31.2 +++ b/src/HOL/Tools/function_package/size.ML Wed Jan 21 20:05:31 2009 +0100
31.3 @@ -144,7 +144,7 @@
31.4 (size_names ~~ recTs1))
31.5 |> PureThy.add_defs false
31.6 (map (Thm.no_attributes o apsnd (Logic.mk_equals o apsnd (app fs)))
31.7 - (def_names ~~ (size_fns ~~ rec_combs1)))
31.8 + (map Binding.name def_names ~~ (size_fns ~~ rec_combs1)))
31.9 ||> TheoryTarget.instantiation
31.10 (map (#1 o snd) descr', map dest_TFree paramTs, [HOLogic.class_size])
31.11 ||>> fold_map define_overloaded
31.12 @@ -208,7 +208,7 @@
31.13 prove_size_eqs is_rec_type overloaded_size_fns (K NONE) simpset3;
31.14
31.15 val ([size_thms], thy'') = PureThy.add_thmss
31.16 - [(("size", size_eqns),
31.17 + [((Binding.name "size", size_eqns),
31.18 [Simplifier.simp_add, Thm.declaration_attribute
31.19 (fn thm => Context.mapping (Code.add_default_eqn thm) I)])] thy'
31.20
32.1 --- a/src/HOL/Tools/inductive_package.ML Wed Jan 21 15:26:02 2009 +0100
32.2 +++ b/src/HOL/Tools/inductive_package.ML Wed Jan 21 20:05:31 2009 +0100
32.3 @@ -38,17 +38,17 @@
32.4 thm list list * local_theory
32.5 type inductive_flags
32.6 val add_inductive_i:
32.7 - inductive_flags -> ((Binding.T * typ) * mixfix) list ->
32.8 + inductive_flags -> ((binding * typ) * mixfix) list ->
32.9 (string * typ) list -> (Attrib.binding * term) list -> thm list -> local_theory ->
32.10 inductive_result * local_theory
32.11 val add_inductive: bool -> bool ->
32.12 - (Binding.T * string option * mixfix) list ->
32.13 - (Binding.T * string option * mixfix) list ->
32.14 + (binding * string option * mixfix) list ->
32.15 + (binding * string option * mixfix) list ->
32.16 (Attrib.binding * string) list ->
32.17 (Facts.ref * Attrib.src list) list ->
32.18 bool -> local_theory -> inductive_result * local_theory
32.19 val add_inductive_global: string -> inductive_flags ->
32.20 - ((Binding.T * typ) * mixfix) list -> (string * typ) list -> (Attrib.binding * term) list ->
32.21 + ((binding * typ) * mixfix) list -> (string * typ) list -> (Attrib.binding * term) list ->
32.22 thm list -> theory -> inductive_result * theory
32.23 val arities_of: thm -> (string * int) list
32.24 val params_of: thm -> term list
32.25 @@ -63,16 +63,16 @@
32.26 sig
32.27 include BASIC_INDUCTIVE_PACKAGE
32.28 type add_ind_def
32.29 - val declare_rules: string -> Binding.T -> bool -> bool -> string list ->
32.30 - thm list -> Binding.T list -> Attrib.src list list -> (thm * string list) list ->
32.31 + val declare_rules: string -> binding -> bool -> bool -> string list ->
32.32 + thm list -> binding list -> Attrib.src list list -> (thm * string list) list ->
32.33 thm -> local_theory -> thm list * thm list * thm * local_theory
32.34 val add_ind_def: add_ind_def
32.35 val gen_add_inductive_i: add_ind_def -> inductive_flags ->
32.36 - ((Binding.T * typ) * mixfix) list -> (string * typ) list -> (Attrib.binding * term) list ->
32.37 + ((binding * typ) * mixfix) list -> (string * typ) list -> (Attrib.binding * term) list ->
32.38 thm list -> local_theory -> inductive_result * local_theory
32.39 val gen_add_inductive: add_ind_def -> bool -> bool ->
32.40 - (Binding.T * string option * mixfix) list ->
32.41 - (Binding.T * string option * mixfix) list ->
32.42 + (binding * string option * mixfix) list ->
32.43 + (binding * string option * mixfix) list ->
32.44 (Attrib.binding * string) list -> (Facts.ref * Attrib.src list) list ->
32.45 bool -> local_theory -> inductive_result * local_theory
32.46 val gen_ind_decl: add_ind_def -> bool ->
32.47 @@ -720,13 +720,13 @@
32.48 in (intrs', elims', induct', ctxt3) end;
32.49
32.50 type inductive_flags =
32.51 - {quiet_mode: bool, verbose: bool, kind: string, alt_name: Binding.T,
32.52 + {quiet_mode: bool, verbose: bool, kind: string, alt_name: binding,
32.53 coind: bool, no_elim: bool, no_ind: bool, skip_mono: bool, fork_mono: bool}
32.54
32.55 type add_ind_def =
32.56 inductive_flags ->
32.57 term list -> (Attrib.binding * term) list -> thm list ->
32.58 - term list -> (Binding.T * mixfix) list ->
32.59 + term list -> (binding * mixfix) list ->
32.60 local_theory -> inductive_result * local_theory
32.61
32.62 fun add_ind_def {quiet_mode, verbose, kind, alt_name, coind, no_elim, no_ind, skip_mono, fork_mono}
33.1 --- a/src/HOL/Tools/inductive_realizer.ML Wed Jan 21 15:26:02 2009 +0100
33.2 +++ b/src/HOL/Tools/inductive_realizer.ML Wed Jan 21 20:05:31 2009 +0100
33.3 @@ -391,14 +391,14 @@
33.4 REPEAT ((resolve_tac prems THEN_ALL_NEW EVERY'
33.5 [K (rewrite_goals_tac rews), ObjectLogic.atomize_prems_tac,
33.6 DEPTH_SOLVE_1 o FIRST' [atac, etac allE, etac impE]]) 1)]);
33.7 - val (thm', thy') = PureThy.store_thm (space_implode "_"
33.8 - (NameSpace.qualified qualifier "induct" :: vs' @ Ps @ ["correctness"]), thm) thy;
33.9 + val (thm', thy') = PureThy.store_thm (Binding.name (space_implode "_"
33.10 + (NameSpace.qualified qualifier "induct" :: vs' @ Ps @ ["correctness"])), thm) thy;
33.11 val thms = map (fn th => zero_var_indexes (rotate_prems ~1 (th RS mp)))
33.12 (DatatypeAux.split_conj_thm thm');
33.13 val ([thms'], thy'') = PureThy.add_thmss
33.14 - [((space_implode "_"
33.15 + [((Binding.name (space_implode "_"
33.16 (NameSpace.qualified qualifier "inducts" :: vs' @ Ps @
33.17 - ["correctness"]), thms), [])] thy';
33.18 + ["correctness"])), thms), [])] thy';
33.19 val realizers = inducts ~~ thms' ~~ rlzs ~~ rs;
33.20 in
33.21 Extraction.add_realizers_i
33.22 @@ -451,8 +451,8 @@
33.23 rewrite_goals_tac rews,
33.24 REPEAT ((resolve_tac prems THEN_ALL_NEW (ObjectLogic.atomize_prems_tac THEN'
33.25 DEPTH_SOLVE_1 o FIRST' [atac, etac allE, etac impE])) 1)]);
33.26 - val (thm', thy') = PureThy.store_thm (space_implode "_"
33.27 - (name_of_thm elim :: vs @ Ps @ ["correctness"]), thm) thy
33.28 + val (thm', thy') = PureThy.store_thm (Binding.name (space_implode "_"
33.29 + (name_of_thm elim :: vs @ Ps @ ["correctness"])), thm) thy
33.30 in
33.31 Extraction.add_realizers_i
33.32 [mk_realizer thy' (vs @ Ps) (name_of_thm elim, elim, thm', rlz, r)] thy'
34.1 --- a/src/HOL/Tools/inductive_set_package.ML Wed Jan 21 15:26:02 2009 +0100
34.2 +++ b/src/HOL/Tools/inductive_set_package.ML Wed Jan 21 20:05:31 2009 +0100
34.3 @@ -12,13 +12,13 @@
34.4 val pred_set_conv_att: attribute
34.5 val add_inductive_i:
34.6 InductivePackage.inductive_flags ->
34.7 - ((Binding.T * typ) * mixfix) list ->
34.8 + ((binding * typ) * mixfix) list ->
34.9 (string * typ) list ->
34.10 (Attrib.binding * term) list -> thm list ->
34.11 local_theory -> InductivePackage.inductive_result * local_theory
34.12 val add_inductive: bool -> bool ->
34.13 - (Binding.T * string option * mixfix) list ->
34.14 - (Binding.T * string option * mixfix) list ->
34.15 + (binding * string option * mixfix) list ->
34.16 + (binding * string option * mixfix) list ->
34.17 (Attrib.binding * string) list -> (Facts.ref * Attrib.src list) list ->
34.18 bool -> local_theory -> InductivePackage.inductive_result * local_theory
34.19 val codegen_preproc: theory -> thm list -> thm list
35.1 --- a/src/HOL/Tools/old_primrec_package.ML Wed Jan 21 15:26:02 2009 +0100
35.2 +++ b/src/HOL/Tools/old_primrec_package.ML Wed Jan 21 20:05:31 2009 +0100
35.3 @@ -305,11 +305,11 @@
35.4 end;
35.5
35.6 fun thy_note ((name, atts), thms) =
35.7 - PureThy.add_thmss [((name, thms), atts)] #-> (fn [thms] => pair (name, thms));
35.8 + PureThy.add_thmss [((Binding.name name, thms), atts)] #-> (fn [thms] => pair (name, thms));
35.9 fun thy_def false ((name, atts), t) =
35.10 - PureThy.add_defs false [((name, t), atts)] #-> (fn [thm] => pair (name, thm))
35.11 + PureThy.add_defs false [((Binding.name name, t), atts)] #-> (fn [thm] => pair (name, thm))
35.12 | thy_def true ((name, atts), t) =
35.13 - PureThy.add_defs_unchecked false [((name, t), atts)] #-> (fn [thm] => pair (name, thm));
35.14 + PureThy.add_defs_unchecked false [((Binding.name name, t), atts)] #-> (fn [thm] => pair (name, thm));
35.15
35.16 in
35.17
36.1 --- a/src/HOL/Tools/primrec_package.ML Wed Jan 21 15:26:02 2009 +0100
36.2 +++ b/src/HOL/Tools/primrec_package.ML Wed Jan 21 20:05:31 2009 +0100
36.3 @@ -7,12 +7,12 @@
36.4
36.5 signature PRIMREC_PACKAGE =
36.6 sig
36.7 - val add_primrec: (Binding.T * typ option * mixfix) list ->
36.8 + val add_primrec: (binding * typ option * mixfix) list ->
36.9 (Attrib.binding * term) list -> local_theory -> thm list * local_theory
36.10 - val add_primrec_global: (Binding.T * typ option * mixfix) list ->
36.11 + val add_primrec_global: (binding * typ option * mixfix) list ->
36.12 (Attrib.binding * term) list -> theory -> thm list * theory
36.13 val add_primrec_overloaded: (string * (string * typ) * bool) list ->
36.14 - (Binding.T * typ option * mixfix) list ->
36.15 + (binding * typ option * mixfix) list ->
36.16 (Attrib.binding * term) list -> theory -> thm list * theory
36.17 end;
36.18
37.1 --- a/src/HOL/Tools/recdef_package.ML Wed Jan 21 15:26:02 2009 +0100
37.2 +++ b/src/HOL/Tools/recdef_package.ML Wed Jan 21 20:05:31 2009 +0100
37.3 @@ -1,5 +1,4 @@
37.4 (* Title: HOL/Tools/recdef_package.ML
37.5 - ID: $Id$
37.6 Author: Markus Wenzel, TU Muenchen
37.7
37.8 Wrapper module for Konrad Slind's TFL package.
37.9 @@ -16,10 +15,10 @@
37.10 val cong_del: attribute
37.11 val wf_add: attribute
37.12 val wf_del: attribute
37.13 - val add_recdef: bool -> xstring -> string -> ((bstring * string) * Attrib.src list) list ->
37.14 + val add_recdef: bool -> xstring -> string -> ((binding * string) * Attrib.src list) list ->
37.15 Attrib.src option -> theory -> theory
37.16 * {simps: thm list, rules: thm list list, induct: thm, tcs: term list}
37.17 - val add_recdef_i: bool -> xstring -> term -> ((bstring * term) * attribute list) list ->
37.18 + val add_recdef_i: bool -> xstring -> term -> ((binding * term) * attribute list) list ->
37.19 theory -> theory * {simps: thm list, rules: thm list list, induct: thm, tcs: term list}
37.20 val defer_recdef: xstring -> string list -> (Facts.ref * Attrib.src list) list
37.21 -> theory -> theory * {induct_rules: thm}
37.22 @@ -214,8 +213,8 @@
37.23 thy
37.24 |> Sign.add_path bname
37.25 |> PureThy.add_thmss
37.26 - ((("simps", List.concat rules), simp_att) :: ((eq_names ~~ rules) ~~ eq_atts))
37.27 - ||>> PureThy.add_thms [(("induct", induct), [])];
37.28 + (((Binding.name "simps", List.concat rules), simp_att) :: ((eq_names ~~ rules) ~~ eq_atts))
37.29 + ||>> PureThy.add_thms [((Binding.name "induct", induct), [])];
37.30 val result = {simps = simps', rules = rules', induct = induct', tcs = tcs};
37.31 val thy =
37.32 thy
37.33 @@ -243,7 +242,7 @@
37.34 val ([induct_rules'], thy3) =
37.35 thy2
37.36 |> Sign.add_path bname
37.37 - |> PureThy.add_thms [(("induct_rules", induct_rules), [])]
37.38 + |> PureThy.add_thms [((Binding.name "induct_rules", induct_rules), [])]
37.39 ||> Sign.parent_path;
37.40 in (thy3, {induct_rules = induct_rules'}) end;
37.41
37.42 @@ -299,7 +298,7 @@
37.43
37.44 val recdef_decl =
37.45 Scan.optional (P.$$$ "(" -- P.!!! (P.$$$ "permissive" -- P.$$$ ")") >> K false) true --
37.46 - P.name -- P.term -- Scan.repeat1 ((SpecParse.opt_thm_name ":" >> apfst Binding.base_name) -- P.prop)
37.47 + P.name -- P.term -- Scan.repeat1 (SpecParse.opt_thm_name ":" -- P.prop)
37.48 -- Scan.option hints
37.49 >> (fn ((((p, f), R), eqs), src) => #1 o add_recdef p f R (map P.triple_swap eqs) src);
37.50
38.1 --- a/src/HOL/Tools/record_package.ML Wed Jan 21 15:26:02 2009 +0100
38.2 +++ b/src/HOL/Tools/record_package.ML Wed Jan 21 20:05:31 2009 +0100
38.3 @@ -1534,8 +1534,10 @@
38.4 |> extension_typedef name repT (alphas@[zeta])
38.5 ||> Sign.add_consts_i
38.6 (map Syntax.no_syn ((apfst base ext_decl)::dest_decls@upd_decls))
38.7 - ||>> PureThy.add_defs false (map Thm.no_attributes (ext_spec::dest_specs))
38.8 - ||>> PureThy.add_defs false (map Thm.no_attributes upd_specs)
38.9 + ||>> PureThy.add_defs false
38.10 + (map (Thm.no_attributes o apfst Binding.name) (ext_spec :: dest_specs))
38.11 + ||>> PureThy.add_defs false
38.12 + (map (Thm.no_attributes o apfst Binding.name) upd_specs)
38.13 |-> (fn args as ((_, dest_defs), upd_defs) =>
38.14 fold Code.add_default_eqn dest_defs
38.15 #> fold Code.add_default_eqn upd_defs
38.16 @@ -1693,14 +1695,14 @@
38.17 [dest_convs',upd_convs']),
38.18 thm_thy) =
38.19 defs_thy
38.20 - |> (PureThy.add_thms o map Thm.no_attributes)
38.21 + |> (PureThy.add_thms o map (Thm.no_attributes o apfst Binding.name))
38.22 [("ext_inject", inject),
38.23 ("ext_induct", induct),
38.24 ("ext_cases", cases),
38.25 ("ext_surjective", surjective),
38.26 ("ext_split", split_meta)]
38.27 - ||>> (PureThy.add_thmss o map Thm.no_attributes)
38.28 - [("dest_convs",dest_convs_standard),("upd_convs",upd_convs)]
38.29 + ||>> (PureThy.add_thmss o map (Thm.no_attributes o apfst Binding.name))
38.30 + [("dest_convs", dest_convs_standard), ("upd_convs", upd_convs)]
38.31
38.32 in (thm_thy,extT,induct',inject',dest_convs',split_meta',upd_convs')
38.33 end;
38.34 @@ -1938,9 +1940,9 @@
38.35 (map2 (fn (x, T) => fn mx => (x, T, mx)) sel_decls (field_syntax @ [Syntax.NoSyn]))
38.36 |> (Sign.add_consts_i o map Syntax.no_syn)
38.37 (upd_decls @ [make_decl, fields_decl, extend_decl, truncate_decl])
38.38 - |> ((PureThy.add_defs false o map Thm.no_attributes) sel_specs)
38.39 - ||>> ((PureThy.add_defs false o map Thm.no_attributes) upd_specs)
38.40 - ||>> ((PureThy.add_defs false o map Thm.no_attributes)
38.41 + |> ((PureThy.add_defs false o map (Thm.no_attributes o apfst Binding.name)) sel_specs)
38.42 + ||>> ((PureThy.add_defs false o map (Thm.no_attributes o apfst Binding.name)) upd_specs)
38.43 + ||>> ((PureThy.add_defs false o map (Thm.no_attributes o apfst Binding.name))
38.44 [make_spec, fields_spec, extend_spec, truncate_spec])
38.45 |-> (fn defs as ((sel_defs, upd_defs), derived_defs) =>
38.46 fold Code.add_default_eqn sel_defs
38.47 @@ -2164,17 +2166,17 @@
38.48 val ((([sel_convs',upd_convs',sel_defs',upd_defs',[split_meta',split_object',split_ex'],derived_defs'],
38.49 [surjective',equality']),[induct_scheme',induct',cases_scheme',cases']), thms_thy) =
38.50 defs_thy
38.51 - |> (PureThy.add_thmss o map Thm.no_attributes)
38.52 + |> (PureThy.add_thmss o map (Thm.no_attributes o apfst Binding.name))
38.53 [("select_convs", sel_convs_standard),
38.54 ("update_convs", upd_convs),
38.55 ("select_defs", sel_defs),
38.56 ("update_defs", upd_defs),
38.57 ("splits", [split_meta_standard,split_object,split_ex]),
38.58 ("defs", derived_defs)]
38.59 - ||>> (PureThy.add_thms o map Thm.no_attributes)
38.60 + ||>> (PureThy.add_thms o map (Thm.no_attributes o apfst Binding.name))
38.61 [("surjective", surjective),
38.62 ("equality", equality)]
38.63 - ||>> PureThy.add_thms
38.64 + ||>> (PureThy.add_thms o (map o apfst o apfst) Binding.name)
38.65 [(("induct_scheme", induct_scheme), induct_type_global (suffix schemeN name)),
38.66 (("induct", induct), induct_type_global name),
38.67 (("cases_scheme", cases_scheme), cases_type_global (suffix schemeN name)),
38.68 @@ -2186,8 +2188,8 @@
38.69 val final_thy =
38.70 thms_thy
38.71 |> (snd oo PureThy.add_thmss)
38.72 - [(("simps", sel_upd_simps), [Simplifier.simp_add]),
38.73 - (("iffs",iffs), [iff_add])]
38.74 + [((Binding.name "simps", sel_upd_simps), [Simplifier.simp_add]),
38.75 + ((Binding.name "iffs", iffs), [iff_add])]
38.76 |> put_record name (make_record_info args parent fields extension induct_scheme')
38.77 |> put_sel_upd (names @ [full_moreN]) sel_upd_simps
38.78 |> add_record_equalities extension_id equality'
39.1 --- a/src/HOL/Tools/res_axioms.ML Wed Jan 21 15:26:02 2009 +0100
39.2 +++ b/src/HOL/Tools/res_axioms.ML Wed Jan 21 20:05:31 2009 +0100
39.3 @@ -84,7 +84,7 @@
39.4 val (c, thy') =
39.5 Sign.declare_const [Markup.property_internal] ((Binding.name cname, cT), NoSyn) thy
39.6 val cdef = cname ^ "_def"
39.7 - val thy'' = Theory.add_defs_i true false [(cdef, Logic.mk_equals (c, rhs))] thy'
39.8 + val thy'' = Theory.add_defs_i true false [(Binding.name cdef, Logic.mk_equals (c, rhs))] thy'
39.9 val ax = Thm.axiom thy'' (Sign.full_bname thy'' cdef)
39.10 in dec_sko (subst_bound (list_comb (c, args), p)) (ax :: axs, thy'') end
39.11 | dec_sko (Const ("All", _) $ (xtp as Abs (a, T, p))) thx =
40.1 --- a/src/HOL/Tools/specification_package.ML Wed Jan 21 15:26:02 2009 +0100
40.2 +++ b/src/HOL/Tools/specification_package.ML Wed Jan 21 20:05:31 2009 +0100
40.3 @@ -28,7 +28,7 @@
40.4 else thname
40.5 val def_eq = Logic.mk_equals (Const(cname_full,ctype),
40.6 HOLogic.choice_const ctype $ P)
40.7 - val (thms, thy') = PureThy.add_defs covld [((cdefname,def_eq),[])] thy
40.8 + val (thms, thy') = PureThy.add_defs covld [((Binding.name cdefname, def_eq),[])] thy
40.9 val thm' = [thm,hd thms] MRS @{thm exE_some}
40.10 in
40.11 mk_definitional cos (thy',thm')
40.12 @@ -39,7 +39,7 @@
40.13 let
40.14 fun process [] (thy,tm) =
40.15 let
40.16 - val (thms, thy') = PureThy.add_axioms [((axname,HOLogic.mk_Trueprop tm),[])] thy
40.17 + val (thms, thy') = PureThy.add_axioms [((Binding.name axname, HOLogic.mk_Trueprop tm),[])] thy
40.18 in
40.19 (thy',hd thms)
40.20 end
40.21 @@ -184,7 +184,7 @@
40.22 if name = ""
40.23 then arg |> Library.swap
40.24 else (writeln (" " ^ name ^ ": " ^ (Display.string_of_thm thm));
40.25 - PureThy.store_thm (name, thm) thy)
40.26 + PureThy.store_thm (Binding.name name, thm) thy)
40.27 in
40.28 args |> apsnd (remove_alls frees)
40.29 |> apsnd undo_imps
41.1 --- a/src/HOL/Tools/typedef_package.ML Wed Jan 21 15:26:02 2009 +0100
41.2 +++ b/src/HOL/Tools/typedef_package.ML Wed Jan 21 20:05:31 2009 +0100
41.3 @@ -112,7 +112,8 @@
41.4 if def then
41.5 theory
41.6 |> Sign.add_consts_i [(name, setT', NoSyn)]
41.7 - |> PureThy.add_defs false [Thm.no_attributes ((PrimitiveDefs.mk_defpair (setC, set)))]
41.8 + |> PureThy.add_defs false [Thm.no_attributes (apfst (Binding.name)
41.9 + (PrimitiveDefs.mk_defpair (setC, set)))]
41.10 |-> (fn [th] => pair (SOME th))
41.11 else (NONE, theory);
41.12 fun contract_def NONE th = th
41.13 @@ -130,7 +131,7 @@
41.14 (Abs_name, oldT --> newT, NoSyn)]
41.15 #> add_def
41.16 #-> (fn set_def =>
41.17 - PureThy.add_axioms [((typedef_name, typedef_prop),
41.18 + PureThy.add_axioms [((Binding.name typedef_name, typedef_prop),
41.19 [Thm.rule_attribute (K (fn cond_axm => contract_def set_def inhabited RS cond_axm))])]
41.20 ##>> pair set_def)
41.21 ##> Theory.add_deps "" (dest_Const RepC) typedef_deps
41.22 @@ -143,7 +144,7 @@
41.23 thy1
41.24 |> Sign.add_path name
41.25 |> PureThy.add_thms
41.26 - ([((Rep_name, make @{thm type_definition.Rep}), []),
41.27 + ((map o apfst o apfst) Binding.name [((Rep_name, make @{thm type_definition.Rep}), []),
41.28 ((Rep_name ^ "_inverse", make @{thm type_definition.Rep_inverse}), []),
41.29 ((Abs_name ^ "_inverse", make @{thm type_definition.Abs_inverse}), []),
41.30 ((Rep_name ^ "_inject", make @{thm type_definition.Rep_inject}), []),
42.1 --- a/src/HOL/Typerep.thy Wed Jan 21 15:26:02 2009 +0100
42.2 +++ b/src/HOL/Typerep.thy Wed Jan 21 20:05:31 2009 +0100
42.3 @@ -1,5 +1,4 @@
42.4 -(* Title: HOL/Library/RType.thy
42.5 - ID: $Id$
42.6 +(* Title: HOL/Typerep.thy
42.7 Author: Florian Haftmann, TU Muenchen
42.8 *)
42.9
42.10 @@ -15,9 +14,7 @@
42.11 fixes typerep :: "'a\<Colon>{} itself \<Rightarrow> typerep"
42.12 begin
42.13
42.14 -definition
42.15 - typerep_of :: "'a \<Rightarrow> typerep"
42.16 -where
42.17 +definition typerep_of :: "'a \<Rightarrow> typerep" where
42.18 [simp]: "typerep_of x = typerep TYPE('a)"
42.19
42.20 end
43.1 --- a/src/HOL/Wellfounded.thy Wed Jan 21 15:26:02 2009 +0100
43.2 +++ b/src/HOL/Wellfounded.thy Wed Jan 21 20:05:31 2009 +0100
43.3 @@ -1,5 +1,4 @@
43.4 -(* ID: $Id$
43.5 - Author: Tobias Nipkow
43.6 +(* Author: Tobias Nipkow
43.7 Author: Lawrence C Paulson, Cambridge University Computer Laboratory
43.8 Author: Konrad Slind, Alexander Krauss
43.9 Copyright 1992-2008 University of Cambridge and TU Muenchen
44.1 --- a/src/HOL/ex/LocaleTest2.thy Wed Jan 21 15:26:02 2009 +0100
44.2 +++ b/src/HOL/ex/LocaleTest2.thy Wed Jan 21 20:05:31 2009 +0100
44.3 @@ -625,9 +625,6 @@
44.4 lemma "gcd x y dvd x"
44.5 apply (rule nat_dvd.meet_left) done
44.6
44.7 -print_interps dpo
44.8 -print_interps dlat
44.9 -
44.10
44.11 subsection {* Group example with defined operations @{text inv} and @{text unit} *}
44.12
45.1 --- a/src/HOL/ex/Quickcheck.thy Wed Jan 21 15:26:02 2009 +0100
45.2 +++ b/src/HOL/ex/Quickcheck.thy Wed Jan 21 20:05:31 2009 +0100
45.3 @@ -200,7 +200,7 @@
45.4 in
45.5 lthy
45.6 |> LocalTheory.theory (Code.del_eqns c
45.7 - #> PureThy.add_thm ((fst (dest_Free random') ^ "_code", thm), [Thm.kind_internal])
45.8 + #> PureThy.add_thm ((Binding.name (fst (dest_Free random') ^ "_code"), thm), [Thm.kind_internal])
45.9 #-> Code.add_eqn)
45.10 end;
45.11 in
46.1 --- a/src/HOLCF/Tools/domain/domain_axioms.ML Wed Jan 21 15:26:02 2009 +0100
46.2 +++ b/src/HOLCF/Tools/domain/domain_axioms.ML Wed Jan 21 20:05:31 2009 +0100
46.3 @@ -111,10 +111,10 @@
46.4
46.5 fun infer_props thy = map (apsnd (FixrecPackage.legacy_infer_prop thy));
46.6
46.7 -fun add_axioms_i x = snd o PureThy.add_axioms (map Thm.no_attributes x);
46.8 +fun add_axioms_i x = snd o PureThy.add_axioms (map (Thm.no_attributes o apfst Binding.name) x);
46.9 fun add_axioms_infer axms thy = add_axioms_i (infer_props thy axms) thy;
46.10
46.11 -fun add_defs_i x = snd o (PureThy.add_defs false) (map Thm.no_attributes x);
46.12 +fun add_defs_i x = snd o (PureThy.add_defs false) (map (Thm.no_attributes o apfst Binding.name) x);
46.13 fun add_defs_infer defs thy = add_defs_i (infer_props thy defs) thy;
46.14
46.15 in (* local *)
47.1 --- a/src/HOLCF/Tools/domain/domain_extender.ML Wed Jan 21 15:26:02 2009 +0100
47.2 +++ b/src/HOLCF/Tools/domain/domain_extender.ML Wed Jan 21 20:05:31 2009 +0100
47.3 @@ -134,7 +134,7 @@
47.4 in
47.5 theorems_thy
47.6 |> Sign.add_path (Sign.base_name comp_dnam)
47.7 - |> (snd o (PureThy.add_thmss [(("rews", List.concat rewss @ take_rews), [])]))
47.8 + |> (snd o (PureThy.add_thmss [((Binding.name "rews", List.concat rewss @ take_rews), [])]))
47.9 |> Sign.parent_path
47.10 end;
47.11
48.1 --- a/src/HOLCF/Tools/domain/domain_theorems.ML Wed Jan 21 15:26:02 2009 +0100
48.2 +++ b/src/HOLCF/Tools/domain/domain_theorems.ML Wed Jan 21 20:05:31 2009 +0100
48.3 @@ -607,7 +607,7 @@
48.4 in
48.5 thy
48.6 |> Sign.add_path (Sign.base_name dname)
48.7 - |> (snd o (PureThy.add_thmss (map Thm.no_attributes [
48.8 + |> (snd o (PureThy.add_thmss (map (Thm.no_attributes o apfst Binding.name) [
48.9 ("iso_rews" , iso_rews ),
48.10 ("exhaust" , [exhaust] ),
48.11 ("casedist" , [casedist]),
48.12 @@ -623,7 +623,7 @@
48.13 ("injects" , injects ),
48.14 ("copy_rews", copy_rews)])))
48.15 |> (snd o PureThy.add_thmss
48.16 - [(("match_rews", mat_rews), [Simplifier.simp_add])])
48.17 + [((Binding.name "match_rews", mat_rews), [Simplifier.simp_add])])
48.18 |> Sign.parent_path
48.19 |> pair (iso_rews @ when_rews @ con_rews @ sel_rews @ dis_rews @
48.20 pat_rews @ dist_les @ dist_eqs @ copy_rews)
48.21 @@ -1000,7 +1000,7 @@
48.22 end; (* local *)
48.23
48.24 in thy |> Sign.add_path comp_dnam
48.25 - |> (snd o (PureThy.add_thmss (map Thm.no_attributes [
48.26 + |> (snd o (PureThy.add_thmss (map (Thm.no_attributes o apfst Binding.name) [
48.27 ("take_rews" , take_rews ),
48.28 ("take_lemmas", take_lemmas),
48.29 ("finites" , finites ),
49.1 --- a/src/HOLCF/Tools/fixrec_package.ML Wed Jan 21 15:26:02 2009 +0100
49.2 +++ b/src/HOLCF/Tools/fixrec_package.ML Wed Jan 21 20:05:31 2009 +0100
49.3 @@ -9,9 +9,9 @@
49.4 val legacy_infer_term: theory -> term -> term
49.5 val legacy_infer_prop: theory -> term -> term
49.6 val add_fixrec: bool -> (Attrib.binding * string) list list -> theory -> theory
49.7 - val add_fixrec_i: bool -> ((Binding.T * attribute list) * term) list list -> theory -> theory
49.8 + val add_fixrec_i: bool -> ((binding * attribute list) * term) list list -> theory -> theory
49.9 val add_fixpat: Attrib.binding * string list -> theory -> theory
49.10 - val add_fixpat_i: (Binding.T * attribute list) * term list -> theory -> theory
49.11 + val add_fixpat_i: (binding * attribute list) * term list -> theory -> theory
49.12 end;
49.13
49.14 structure FixrecPackage: FIXREC_PACKAGE =
49.15 @@ -96,7 +96,7 @@
49.16
49.17 val fixdefs = map (apsnd (legacy_infer_prop thy)) pre_fixdefs;
49.18 val (fixdef_thms, thy') =
49.19 - PureThy.add_defs false (map Thm.no_attributes fixdefs) thy;
49.20 + PureThy.add_defs false (map (Thm.no_attributes o apfst Binding.name) fixdefs) thy;
49.21 val ctuple_fixdef_thm = foldr1 (fn (x,y) => @{thm cpair_equalI} OF [x,y]) fixdef_thms;
49.22
49.23 val ctuple_unfold = legacy_infer_term thy' (mk_trp (mk_ctuple lhss === mk_ctuple rhss));
49.24 @@ -114,7 +114,7 @@
49.25 in (n^"_unfold", thmL) :: unfolds ns thmR end;
49.26 val unfold_thms = unfolds names ctuple_unfold_thm;
49.27 val thms = ctuple_induct_thm :: unfold_thms;
49.28 - val (_, thy'') = PureThy.add_thms (map Thm.no_attributes thms) thy';
49.29 + val (_, thy'') = PureThy.add_thms (map (Thm.no_attributes o apfst Binding.name) thms) thy';
49.30 in
49.31 (thy'', names, fixdef_thms, map snd unfold_thms)
49.32 end;
49.33 @@ -241,14 +241,14 @@
49.34 in
49.35 if strict then let (* only prove simp rules if strict = true *)
49.36 val eqn_blocks = unconcat lengths ((names ~~ eqn_ts') ~~ atts);
49.37 - val simps = List.concat (map (make_simps thy') (unfold_thms ~~ eqn_blocks));
49.38 - val (simp_thms, thy'') = PureThy.add_thms simps thy';
49.39 + val simps = maps (make_simps thy') (unfold_thms ~~ eqn_blocks);
49.40 + val (simp_thms, thy'') = PureThy.add_thms ((map o apfst o apfst) Binding.name simps) thy';
49.41
49.42 val simp_names = map (fn name => name^"_simps") cnames;
49.43 val simp_attribute = rpair [Simplifier.simp_add];
49.44 val simps' = map simp_attribute (simp_names ~~ unconcat lengths simp_thms);
49.45 in
49.46 - (snd o PureThy.add_thmss simps') thy''
49.47 + (snd o PureThy.add_thmss ((map o apfst o apfst) Binding.name simps')) thy''
49.48 end
49.49 else thy'
49.50 end;
49.51 @@ -278,7 +278,7 @@
49.52 val ts = map (prep_term thy) strings;
49.53 val simps = map (fix_pat thy) ts;
49.54 in
49.55 - (snd o PureThy.add_thmss [((Binding.base_name name, simps), atts)]) thy
49.56 + (snd o PureThy.add_thmss [((name, simps), atts)]) thy
49.57 end;
49.58
49.59 val add_fixpat = gen_add_fixpat Syntax.read_term_global Attrib.attribute;
50.1 --- a/src/HOLCF/Tools/pcpodef_package.ML Wed Jan 21 15:26:02 2009 +0100
50.2 +++ b/src/HOLCF/Tools/pcpodef_package.ML Wed Jan 21 20:05:31 2009 +0100
50.3 @@ -97,12 +97,12 @@
50.4 theory'
50.5 |> Sign.add_path name
50.6 |> PureThy.add_thms
50.7 - ([(("adm_" ^ name, admissible'), []),
50.8 - (("cont_" ^ Rep_name, @{thm typedef_cont_Rep} OF cpo_thms'), []),
50.9 - (("cont_" ^ Abs_name, @{thm typedef_cont_Abs} OF cpo_thms'), []),
50.10 - (("lub_" ^ name, @{thm typedef_lub} OF cpo_thms'), []),
50.11 - (("thelub_" ^ name, @{thm typedef_thelub} OF cpo_thms'), []),
50.12 - (("compact_" ^ name, @{thm typedef_compact} OF cpo_thms'), [])])
50.13 + ([((Binding.name ("adm_" ^ name), admissible'), []),
50.14 + ((Binding.name ("cont_" ^ Rep_name), @{thm typedef_cont_Rep} OF cpo_thms'), []),
50.15 + ((Binding.name ("cont_" ^ Abs_name), @{thm typedef_cont_Abs} OF cpo_thms'), []),
50.16 + ((Binding.name ("lub_" ^ name), @{thm typedef_lub} OF cpo_thms'), []),
50.17 + ((Binding.name ("thelub_" ^ name), @{thm typedef_thelub} OF cpo_thms'), []),
50.18 + ((Binding.name ("compact_" ^ name), @{thm typedef_compact} OF cpo_thms'), [])])
50.19 |> snd
50.20 |> Sign.parent_path
50.21 end;
50.22 @@ -119,12 +119,12 @@
50.23 theory'
50.24 |> Sign.add_path name
50.25 |> PureThy.add_thms
50.26 - ([((Rep_name ^ "_strict", @{thm typedef_Rep_strict} OF pcpo_thms'), []),
50.27 - ((Abs_name ^ "_strict", @{thm typedef_Abs_strict} OF pcpo_thms'), []),
50.28 - ((Rep_name ^ "_strict_iff", @{thm typedef_Rep_strict_iff} OF pcpo_thms'), []),
50.29 - ((Abs_name ^ "_strict_iff", @{thm typedef_Abs_strict_iff} OF pcpo_thms'), []),
50.30 - ((Rep_name ^ "_defined", @{thm typedef_Rep_defined} OF pcpo_thms'), []),
50.31 - ((Abs_name ^ "_defined", @{thm typedef_Abs_defined} OF pcpo_thms'), [])
50.32 + ([((Binding.name (Rep_name ^ "_strict"), @{thm typedef_Rep_strict} OF pcpo_thms'), []),
50.33 + ((Binding.name (Abs_name ^ "_strict"), @{thm typedef_Abs_strict} OF pcpo_thms'), []),
50.34 + ((Binding.name (Rep_name ^ "_strict_iff"), @{thm typedef_Rep_strict_iff} OF pcpo_thms'), []),
50.35 + ((Binding.name (Abs_name ^ "_strict_iff"), @{thm typedef_Abs_strict_iff} OF pcpo_thms'), []),
50.36 + ((Binding.name (Rep_name ^ "_defined"), @{thm typedef_Rep_defined} OF pcpo_thms'), []),
50.37 + ((Binding.name (Abs_name ^ "_defined"), @{thm typedef_Abs_defined} OF pcpo_thms'), [])
50.38 ])
50.39 |> snd
50.40 |> Sign.parent_path
51.1 --- a/src/Pure/General/binding.ML Wed Jan 21 15:26:02 2009 +0100
51.2 +++ b/src/Pure/General/binding.ML Wed Jan 21 20:05:31 2009 +0100
51.3 @@ -6,6 +6,7 @@
51.4
51.5 signature BASIC_BINDING =
51.6 sig
51.7 + type binding
51.8 val long_names: bool ref
51.9 val short_names: bool ref
51.10 val unique_names: bool ref
51.11 @@ -92,6 +93,8 @@
51.12 else space_implode "." (map mk_prefix prefix) ^ ":" ^ name
51.13 end;
51.14
51.15 +type binding = T;
51.16 +
51.17 end;
51.18
51.19 structure Basic_Binding : BASIC_BINDING = Binding;
52.1 --- a/src/Pure/General/name_space.ML Wed Jan 21 15:26:02 2009 +0100
52.2 +++ b/src/Pure/General/name_space.ML Wed Jan 21 20:05:31 2009 +0100
52.3 @@ -3,9 +3,10 @@
52.4
52.5 Generic name spaces with declared and hidden entries. Unknown names
52.6 are considered global; no support for absolute addressing.
52.7 +Cf. Pure/General/binding.ML
52.8 *)
52.9
52.10 -type bstring = string; (*names to be bound*)
52.11 +type bstring = string; (*simple names to be bound -- legacy*)
52.12 type xstring = string; (*external names*)
52.13
52.14 signature NAME_SPACE =
52.15 @@ -31,8 +32,8 @@
52.16 val merge: T * T -> T
52.17 type naming
52.18 val default_naming: naming
52.19 - val declare: naming -> Binding.T -> T -> string * T
52.20 - val full_name: naming -> Binding.T -> string
52.21 + val declare: naming -> binding -> T -> string * T
52.22 + val full_name: naming -> binding -> string
52.23 val external_names: naming -> string -> string list
52.24 val path_of: naming -> string
52.25 val add_path: string -> naming -> naming
52.26 @@ -41,7 +42,7 @@
52.27 val sticky_prefix: string -> naming -> naming
52.28 type 'a table = T * 'a Symtab.table
52.29 val empty_table: 'a table
52.30 - val bind: naming -> Binding.T * 'a
52.31 + val bind: naming -> binding * 'a
52.32 -> 'a table -> string * 'a table (*exception Symtab.DUP*)
52.33 val merge_tables: ('a * 'a -> bool) -> 'a table * 'a table -> 'a table
52.34 val join_tables: (string -> 'a * 'a -> 'a)
53.1 --- a/src/Pure/IsaMakefile Wed Jan 21 15:26:02 2009 +0100
53.2 +++ b/src/Pure/IsaMakefile Wed Jan 21 20:05:31 2009 +0100
53.3 @@ -41,7 +41,7 @@
53.4 Isar/expression.ML Isar/find_theorems.ML Isar/isar.ML \
53.5 Isar/isar_document.ML Isar/isar_cmd.ML Isar/isar_syn.ML \
53.6 Isar/local_defs.ML Isar/local_syntax.ML Isar/local_theory.ML \
53.7 - Isar/locale.ML Isar/method.ML Isar/net_rules.ML Isar/old_locale.ML \
53.8 + Isar/locale.ML Isar/method.ML Isar/net_rules.ML \
53.9 Isar/object_logic.ML Isar/obtain.ML Isar/outer_keyword.ML \
53.10 Isar/outer_lex.ML Isar/outer_parse.ML Isar/outer_syntax.ML \
53.11 Isar/overloading.ML Isar/proof.ML Isar/proof_context.ML \
53.12 @@ -75,7 +75,7 @@
53.13 Syntax/syn_trans.ML Syntax/syntax.ML Syntax/type_ext.ML Thy/html.ML \
53.14 Thy/latex.ML Thy/present.ML Thy/term_style.ML Thy/thm_deps.ML \
53.15 Thy/thy_header.ML Thy/thy_info.ML Thy/thy_load.ML Thy/thy_output.ML \
53.16 - Thy/thy_syntax.ML Tools/ROOT.ML Tools/invoke.ML \
53.17 + Thy/thy_syntax.ML Tools/ROOT.ML \
53.18 Tools/isabelle_process.ML Tools/named_thms.ML Tools/xml_syntax.ML \
53.19 assumption.ML axclass.ML codegen.ML config.ML conjunction.ML \
53.20 consts.ML context.ML context_position.ML conv.ML defs.ML display.ML \
54.1 --- a/src/Pure/Isar/ROOT.ML Wed Jan 21 15:26:02 2009 +0100
54.2 +++ b/src/Pure/Isar/ROOT.ML Wed Jan 21 20:05:31 2009 +0100
54.3 @@ -53,7 +53,6 @@
54.4 (*local theories and targets*)
54.5 use "local_theory.ML";
54.6 use "overloading.ML";
54.7 -use "old_locale.ML";
54.8 use "locale.ML";
54.9 use "class_target.ML";
54.10 use "theory_target.ML";
55.1 --- a/src/Pure/Isar/args.ML Wed Jan 21 15:26:02 2009 +0100
55.2 +++ b/src/Pure/Isar/args.ML Wed Jan 21 20:05:31 2009 +0100
55.3 @@ -35,7 +35,7 @@
55.4 val name_source: T list -> string * T list
55.5 val name_source_position: T list -> (SymbolPos.text * Position.T) * T list
55.6 val name: T list -> string * T list
55.7 - val binding: T list -> Binding.T * T list
55.8 + val binding: T list -> binding * T list
55.9 val alt_name: T list -> string * T list
55.10 val symbol: T list -> string * T list
55.11 val liberal_name: T list -> string * T list
55.12 @@ -66,8 +66,8 @@
55.13 val parse1: (string -> bool) -> OuterLex.token list -> T list * OuterLex.token list
55.14 val attribs: (string -> string) -> T list -> src list * T list
55.15 val opt_attribs: (string -> string) -> T list -> src list * T list
55.16 - val thm_name: (string -> string) -> string -> T list -> (Binding.T * src list) * T list
55.17 - val opt_thm_name: (string -> string) -> string -> T list -> (Binding.T * src list) * T list
55.18 + val thm_name: (string -> string) -> string -> T list -> (binding * src list) * T list
55.19 + val opt_thm_name: (string -> string) -> string -> T list -> (binding * src list) * T list
55.20 val syntax: string -> ('b * T list -> 'a * ('b * T list)) -> src -> 'b -> 'a * 'b
55.21 val context_syntax: string -> (Context.generic * T list -> 'a * (Context.generic * T list)) ->
55.22 src -> Proof.context -> 'a * Proof.context
56.1 --- a/src/Pure/Isar/attrib.ML Wed Jan 21 15:26:02 2009 +0100
56.2 +++ b/src/Pure/Isar/attrib.ML Wed Jan 21 20:05:31 2009 +0100
56.3 @@ -7,7 +7,7 @@
56.4 signature ATTRIB =
56.5 sig
56.6 type src = Args.src
56.7 - type binding = Binding.T * src list
56.8 + type binding = binding * src list
56.9 val empty_binding: binding
56.10 val print_attributes: theory -> unit
56.11 val intern: theory -> xstring -> string
56.12 @@ -54,7 +54,7 @@
56.13
56.14 type src = Args.src;
56.15
56.16 -type binding = Binding.T * src list;
56.17 +type binding = binding * src list;
56.18 val empty_binding: binding = (Binding.empty, []);
56.19
56.20
57.1 --- a/src/Pure/Isar/calculation.ML Wed Jan 21 15:26:02 2009 +0100
57.2 +++ b/src/Pure/Isar/calculation.ML Wed Jan 21 20:05:31 2009 +0100
57.3 @@ -98,8 +98,8 @@
57.4 ("sym", sym_att, "declaration of symmetry rule"),
57.5 ("symmetric", Attrib.no_args symmetric, "resolution with symmetry rule")] #>
57.6 PureThy.add_thms
57.7 - [(("", transitive_thm), [trans_add]),
57.8 - (("", symmetric_thm), [sym_add])] #> snd));
57.9 + [((Binding.empty, transitive_thm), [trans_add]),
57.10 + ((Binding.empty, symmetric_thm), [sym_add])] #> snd));
57.11
57.12
57.13
58.1 --- a/src/Pure/Isar/class.ML Wed Jan 21 15:26:02 2009 +0100
58.2 +++ b/src/Pure/Isar/class.ML Wed Jan 21 20:05:31 2009 +0100
58.3 @@ -1,7 +1,7 @@
58.4 (* Title: Pure/Isar/ML
58.5 Author: Florian Haftmann, TU Muenchen
58.6
58.7 -Type classes derived from primitive axclasses and locales - interfaces
58.8 +Type classes derived from primitive axclasses and locales - interfaces.
58.9 *)
58.10
58.11 signature CLASS =
58.12 @@ -34,7 +34,7 @@
58.13
58.14 (* instantiation of canonical interpretation *)
58.15 (*FIXME inst_morph should be calculated manually and not instantiate constraint*)
58.16 - val aT = TFree ("'a", base_sort);
58.17 + val aT = TFree (Name.aT, base_sort);
58.18 val (([props], [(_, inst_morph)], export_morph), _) = empty_ctxt
58.19 |> Expression.cert_goal_expression ([(class, (("", false),
58.20 Expression.Named ((map o apsnd) Const param_map)))], []);
58.21 @@ -89,7 +89,88 @@
58.22
58.23 in (base_morph, morph, export_morph, axiom, assm_intro, of_class) end;
58.24
58.25 -fun prep_class_spec prep_class process_decl thy raw_supclasses raw_elems =
58.26 +fun add_typ_check level name f = Context.proof_map (Syntax.add_typ_check level name (fn xs => fn ctxt =>
58.27 + let val xs' = f xs in if eq_list (op =) (xs, xs') then NONE else SOME (xs', ctxt) end));
58.28 +
58.29 +fun singleton_infer_param change_sort = (map o map_atyps) (fn T as TVar (vi as (_, i), sort) =>
58.30 + if TypeInfer.is_param vi then TypeInfer.param i (Name.aT, change_sort sort)
58.31 + else error ("Illegal schematic type variable in class specification: " ^ Term.string_of_vname vi)
58.32 + (*FIXME does not occur*)
58.33 + | T as TFree (v, sort) =>
58.34 + if v = Name.aT then T
58.35 + else error ("No type variable other than " ^ Name.aT ^ " allowed in class specification"));
58.36 +
58.37 +val singleton_fixate = (map o map_atyps) (fn TVar (vi, sort)
58.38 + => TFree (Name.aT, sort) | T => T);
58.39 +
58.40 +fun add_tfrees_of_element (Element.Fixes fxs) = fold (fn (_, SOME T, _) => Term.add_tfreesT T
58.41 + | _ => I) fxs
58.42 + | add_tfrees_of_element (Element.Constrains cnstrs) = fold (Term.add_tfreesT o snd) cnstrs
58.43 + | add_tfrees_of_element (Element.Assumes assms) = fold (fold (fn (t, ts) =>
58.44 + Term.add_tfrees t #> fold Term.add_tfrees ts) o snd) assms
58.45 + | add_tfrees_of_element _ = I;
58.46 +
58.47 +fun fork_syn (Element.Fixes xs) =
58.48 + fold_map (fn (c, ty, syn) => cons (Binding.base_name c, syn) #> pair (c, ty, NoSyn)) xs
58.49 + #>> Element.Fixes
58.50 + | fork_syn x = pair x;
58.51 +
58.52 +fun prep_class_spec prep_class prep_decl thy raw_supclasses raw_elems =
58.53 + let
58.54 + (* prepare import *)
58.55 + val inter_sort = curry (Sorts.inter_sort (Sign.classes_of thy));
58.56 + val (sups, others_basesort) = map (prep_class thy) raw_supclasses
58.57 + |> Sign.minimize_sort thy
58.58 + |> List.partition (is_class thy);
58.59 +
58.60 + val supparams = (map o apsnd) (snd o snd) (these_params thy sups);
58.61 + val supparam_names = map fst supparams;
58.62 + val _ = if has_duplicates (op =) supparam_names
58.63 + then error ("Duplicate parameter(s) in superclasses: "
58.64 + ^ (commas o map quote o duplicates (op =)) supparam_names)
58.65 + else ();
58.66 + val supexpr = (map (fn sup => (sup, (("", false), Expression.Positional [])))
58.67 + sups, []);
58.68 + val given_basesort = fold inter_sort (map (base_sort thy) sups) others_basesort;
58.69 +
58.70 + (* infer types and base sort *)
58.71 + val base_constraints = (map o apsnd)
58.72 + (map_type_tfree (K (TVar ((Name.aT, 0), given_basesort))) o fst o snd)
58.73 + (these_operations thy sups);
58.74 + val ((_, _, inferred_elems), _) = ProofContext.init thy
58.75 + |> fold (ProofContext.add_const_constraint o apsnd SOME) base_constraints
58.76 + |> add_typ_check ~1 "singleton_infer_param" (singleton_infer_param (inter_sort given_basesort))
58.77 + |> add_typ_check ~2 "singleton_fixate" singleton_fixate
58.78 + |> prep_decl supexpr raw_elems;
58.79 + (*FIXME propagation of given base sort into class spec broken*)
58.80 + (*FIXME check for *all* side conditions here, extra check function for elements,
58.81 + less side-condition checks in check phase*)
58.82 + val base_sort = if null inferred_elems then given_basesort else
58.83 + case fold add_tfrees_of_element inferred_elems []
58.84 + of [] => error "No type variable in class specification"
58.85 + | [(_, sort)] => sort
58.86 + | _ => error "Multiple type variables in class specification"
58.87 + val sup_sort = inter_sort base_sort sups
58.88 +
58.89 + (* process elements as class specification *)
58.90 + val begin_ctxt = begin sups base_sort
58.91 + #> fold (Variable.declare_constraints o Free) ((map o apsnd o map_atyps)
58.92 + (K (TFree (Name.aT, base_sort))) supparams)
58.93 + (*FIXME should constraints be issued in begin?*)
58.94 + val ((_, _, syntax_elems), _) = ProofContext.init thy
58.95 + |> begin_ctxt
58.96 + |> Expression.cert_declaration supexpr inferred_elems;
58.97 + val (elems, global_syntax) = fold_map fork_syn syntax_elems [];
58.98 + val constrain = Element.Constrains ((map o apsnd o map_atyps)
58.99 + (K (TFree (Name.aT, base_sort))) supparams);
58.100 + (*FIXME 2009 perhaps better: control type variable by explicit
58.101 + parameter instantiation of import expression*)
58.102 + in (((sups, supparam_names), (sup_sort, base_sort, supexpr)), (constrain :: elems, global_syntax)) end;
58.103 +
58.104 +val cert_class_spec = prep_class_spec (K I) Expression.cert_declaration;
58.105 +val read_class_spec = prep_class_spec Sign.intern_class Expression.cert_read_declaration;
58.106 +
58.107 +(*fun prep_class_spec prep_class process_decl thy raw_supclasses raw_elems =
58.108 let
58.109 (*FIXME 2009 simplify*)
58.110 val supclasses = map (prep_class thy) raw_supclasses;
58.111 @@ -126,7 +207,7 @@
58.112 in (((sups, supparam_names), (supsort, base_sort, supexpr)), (constrain :: elems, global_syntax)) end;
58.113
58.114 val cert_class_spec = prep_class_spec (K I) Expression.cert_declaration;
58.115 -val read_class_spec = prep_class_spec Sign.intern_class Expression.cert_read_declaration;
58.116 +val read_class_spec = prep_class_spec Sign.intern_class Expression.cert_read_declaration;*)
58.117
58.118 fun add_consts bname class base_sort sups supparams global_syntax thy =
58.119 let
58.120 @@ -235,19 +316,13 @@
58.121 #> ProofContext.theory_of #> TheoryTarget.init (SOME sub);
58.122 in do_proof after_qed some_prop goal_ctxt end;
58.123
58.124 -fun user_proof after_qed NONE =
58.125 - Proof.theorem_i NONE (K (after_qed NONE)) [[]]
58.126 - #> Element.refine_witness #> Seq.hd
58.127 - | user_proof after_qed (SOME prop) =
58.128 - Proof.theorem_i NONE (after_qed o SOME o Element.make_witness prop
58.129 - o Thm.close_derivation o the_single o the_single)
58.130 - [[(Element.mark_witness prop, [])]]
58.131 - #> Element.refine_witness #> Seq.hd;
58.132 +fun user_proof after_qed some_prop =
58.133 + Element.witness_proof (after_qed o try the_single o the_single)
58.134 + [the_list some_prop];
58.135
58.136 -fun tactic_proof tac after_qed NONE ctxt =
58.137 - after_qed NONE ctxt
58.138 - | tactic_proof tac after_qed (SOME prop) ctxt =
58.139 - after_qed (SOME (Element.prove_witness ctxt prop tac)) ctxt;
58.140 +fun tactic_proof tac after_qed some_prop ctxt =
58.141 + after_qed (Option.map
58.142 + (fn prop => Element.prove_witness ctxt prop tac) some_prop) ctxt;
58.143
58.144 in
58.145
59.1 --- a/src/Pure/Isar/class_target.ML Wed Jan 21 15:26:02 2009 +0100
59.2 +++ b/src/Pure/Isar/class_target.ML Wed Jan 21 20:05:31 2009 +0100
59.3 @@ -18,6 +18,7 @@
59.4 val rules: theory -> class -> thm option * thm
59.5 val these_params: theory -> sort -> (string * (class * (string * typ))) list
59.6 val these_defs: theory -> sort -> thm list
59.7 + val these_operations: theory -> sort -> (string * (class * (typ * term))) list
59.8 val print_classes: theory -> unit
59.9
59.10 val begin: class list -> sort -> Proof.context -> Proof.context
59.11 @@ -253,7 +254,6 @@
59.12 in fold amend (heritage thy [class]) thy end;
59.13
59.14 fun register_operation class (c, (t, some_def)) thy =
59.15 - (*FIXME 2009 does this still also work for abbrevs?*)
59.16 let
59.17 val base_sort = base_sort thy class;
59.18 val prep_typ = map_type_tfree
59.19 @@ -297,11 +297,14 @@
59.20
59.21 (* class context syntax *)
59.22
59.23 -fun synchronize_class_syntax sups base_sort ctxt =
59.24 +fun these_unchecks thy =
59.25 + map (fn (c, (_, (ty, t))) => (t, Const (c, ty))) o these_operations thy;
59.26 +
59.27 +fun synchronize_class_syntax sort base_sort ctxt =
59.28 let
59.29 val thy = ProofContext.theory_of ctxt;
59.30 val algebra = Sign.classes_of thy;
59.31 - val operations = these_operations thy sups;
59.32 + val operations = these_operations thy sort;
59.33 fun subst_class_typ sort = map_type_tfree (K (TVar ((Name.aT, 0), sort)));
59.34 val primary_constraints =
59.35 (map o apsnd) (subst_class_typ base_sort o fst o snd) operations;
59.36 @@ -322,7 +325,7 @@
59.37 | NONE => NONE)
59.38 | NONE => NONE)
59.39 fun subst (c, ty) = Option.map snd (AList.lookup (op =) operations c);
59.40 - val unchecks = map (fn (c, (_, (ty, t))) => (t, Const (c, ty))) operations;
59.41 + val unchecks = these_unchecks thy sort;
59.42 in
59.43 ctxt
59.44 |> fold declare_const primary_constraints
59.45 @@ -337,11 +340,11 @@
59.46 val base_sort = base_sort thy class;
59.47 in synchronize_class_syntax [class] base_sort ctxt end;
59.48
59.49 -fun begin sups base_sort ctxt =
59.50 +fun begin sort base_sort ctxt =
59.51 ctxt
59.52 |> Variable.declare_term
59.53 (Logic.mk_type (TFree (Name.aT, base_sort)))
59.54 - |> synchronize_class_syntax sups base_sort
59.55 + |> synchronize_class_syntax sort base_sort
59.56 |> Overloading.add_improvable_syntax;
59.57
59.58 fun init class thy =
59.59 @@ -356,52 +359,42 @@
59.60
59.61 fun declare class pos ((c, mx), dict) thy =
59.62 let
59.63 - val prfx = class_prefix class;
59.64 - val thy' = thy |> Sign.add_path prfx;
59.65 - (*FIXME 2009 use proper name morphism*)
59.66 - val morph = morphism thy' class;
59.67 - val params = map (apsnd fst o snd) (these_params thy' [class]);
59.68 -
59.69 - val c' = Sign.full_bname thy' c;
59.70 + val morph = morphism thy class;
59.71 + val b = Morphism.binding morph (Binding.name c);
59.72 + val b_def = Morphism.binding morph (Binding.name (c ^ "_dict"));
59.73 + val c' = Sign.full_name thy b;
59.74 val dict' = Morphism.term morph dict;
59.75 val ty' = Term.fastype_of dict';
59.76 - val ty'' = Type.strip_sorts ty';
59.77 - (*FIXME 2009 the tinkering with theorems here is a mess*)
59.78 - val def_eq = Logic.mk_equals (Const (c', ty'), dict');
59.79 - fun get_axiom thy = ((Thm.varifyT o Thm.axiom thy) c', thy);
59.80 + val def_eq = Logic.mk_equals (Const (c', ty'), dict')
59.81 + |> map_types Type.strip_sorts;
59.82 in
59.83 - thy'
59.84 - |> Sign.declare_const pos ((Binding.name c, ty''), mx) |> snd
59.85 - |> Thm.add_def false false (c, def_eq) (*FIXME 2009 name of theorem*)
59.86 - (*FIXME 2009 add_def should accept binding*)
59.87 - |>> Thm.symmetric
59.88 - ||>> get_axiom
59.89 - |-> (fn (def, def') => register_operation class (c', (dict', SOME (Thm.symmetric def')))
59.90 - #> PureThy.store_thm (c ^ "_raw", def') (*FIXME 2009 name of theorem*)
59.91 - (*FIXME 2009 store_thm etc. should accept binding*)
59.92 - #> snd)
59.93 - |> Sign.restore_naming thy
59.94 + thy
59.95 + |> Sign.declare_const pos ((b, Type.strip_sorts ty'), mx)
59.96 + |> snd
59.97 + |> Thm.add_def false false (b_def, def_eq)
59.98 + |>> Thm.varifyT
59.99 + |-> (fn def_thm => PureThy.store_thm (b_def, def_thm)
59.100 + #> snd
59.101 + #> register_operation class (c', (dict', SOME (Thm.symmetric def_thm))))
59.102 |> Sign.add_const_constraint (c', SOME ty')
59.103 end;
59.104
59.105 fun abbrev class prmode pos ((c, mx), rhs) thy =
59.106 let
59.107 - val prfx = class_prefix class;
59.108 - val thy' = thy |> Sign.add_path prfx;
59.109 -
59.110 - val unchecks = map (fn (c, (_, (ty, t))) => (t, Const (c, ty)))
59.111 - (these_operations thy [class]);
59.112 - val c' = Sign.full_bname thy' c;
59.113 + val morph = morphism thy class;
59.114 + val unchecks = these_unchecks thy [class];
59.115 + val b = Morphism.binding morph (Binding.name c);
59.116 + val c' = Sign.full_name thy b;
59.117 val rhs' = Pattern.rewrite_term thy unchecks [] rhs;
59.118 - val rhs'' = map_types Logic.varifyT rhs';
59.119 val ty' = Term.fastype_of rhs';
59.120 + val rhs'' = map_types ((*Type.strip_sorts o *)Logic.varifyT) rhs';
59.121 in
59.122 - thy'
59.123 - |> Sign.add_abbrev (#1 prmode) pos (Binding.name c, map_types Type.strip_sorts rhs'') |> snd
59.124 + thy
59.125 + |> Sign.add_abbrev (#1 prmode) pos (b, rhs'')
59.126 + |> snd
59.127 |> Sign.add_const_constraint (c', SOME ty')
59.128 |> Sign.notation true prmode [(Const (c', ty'), mx)]
59.129 |> not (#1 prmode = PrintMode.input) ? register_operation class (c', (rhs', NONE))
59.130 - |> Sign.restore_naming thy
59.131 end;
59.132
59.133
59.134 @@ -610,8 +603,7 @@
59.135 end;
59.136
59.137 fun default_intro_tac ctxt [] =
59.138 - intro_classes_tac [] ORELSE Old_Locale.intro_locales_tac true ctxt [] ORELSE
59.139 - Locale.intro_locales_tac true ctxt []
59.140 + intro_classes_tac [] ORELSE Locale.intro_locales_tac true ctxt []
59.141 | default_intro_tac _ _ = no_tac;
59.142
59.143 fun default_tac rules ctxt facts =
60.1 --- a/src/Pure/Isar/constdefs.ML Wed Jan 21 15:26:02 2009 +0100
60.2 +++ b/src/Pure/Isar/constdefs.ML Wed Jan 21 20:05:31 2009 +0100
60.3 @@ -8,12 +8,12 @@
60.4
60.5 signature CONSTDEFS =
60.6 sig
60.7 - val add_constdefs: (Binding.T * string option) list *
60.8 - ((Binding.T * string option * mixfix) option *
60.9 + val add_constdefs: (binding * string option) list *
60.10 + ((binding * string option * mixfix) option *
60.11 (Attrib.binding * string)) list -> theory -> theory
60.12 - val add_constdefs_i: (Binding.T * typ option) list *
60.13 - ((Binding.T * typ option * mixfix) option *
60.14 - ((Binding.T * attribute list) * term)) list -> theory -> theory
60.15 + val add_constdefs_i: (binding * typ option) list *
60.16 + ((binding * typ option * mixfix) option *
60.17 + ((binding * attribute list) * term)) list -> theory -> theory
60.18 end;
60.19
60.20 structure Constdefs: CONSTDEFS =
60.21 @@ -52,7 +52,7 @@
60.22 val thy' =
60.23 thy
60.24 |> Sign.add_consts_i [(c, T, mx)]
60.25 - |> PureThy.add_defs false [((name, def), atts)]
60.26 + |> PureThy.add_defs false [((Binding.name name, def), atts)]
60.27 |-> (fn [thm] => Code.add_default_eqn thm);
60.28 in ((c, T), thy') end;
60.29
61.1 --- a/src/Pure/Isar/context_rules.ML Wed Jan 21 15:26:02 2009 +0100
61.2 +++ b/src/Pure/Isar/context_rules.ML Wed Jan 21 20:05:31 2009 +0100
61.3 @@ -199,7 +199,7 @@
61.4 val dest_query = rule_add elim_queryK Tactic.make_elim;
61.5
61.6 val _ = Context.>> (Context.map_theory
61.7 - (snd o PureThy.add_thms [(("", Drule.equal_intr_rule), [intro_query NONE])]));
61.8 + (snd o PureThy.add_thms [((Binding.empty, Drule.equal_intr_rule), [intro_query NONE])]));
61.9
61.10
61.11 (* concrete syntax *)
62.1 --- a/src/Pure/Isar/element.ML Wed Jan 21 15:26:02 2009 +0100
62.2 +++ b/src/Pure/Isar/element.ML Wed Jan 21 20:05:31 2009 +0100
62.3 @@ -9,11 +9,11 @@
62.4 sig
62.5 datatype ('typ, 'term) stmt =
62.6 Shows of (Attrib.binding * ('term * 'term list) list) list |
62.7 - Obtains of (Binding.T * ((Binding.T * 'typ option) list * 'term list)) list
62.8 + Obtains of (binding * ((binding * 'typ option) list * 'term list)) list
62.9 type statement = (string, string) stmt
62.10 type statement_i = (typ, term) stmt
62.11 datatype ('typ, 'term, 'fact) ctxt =
62.12 - Fixes of (Binding.T * 'typ option * mixfix) list |
62.13 + Fixes of (binding * 'typ option * mixfix) list |
62.14 Constrains of (string * 'typ) list |
62.15 Assumes of (Attrib.binding * ('term * 'term list) list) list |
62.16 Defines of (Attrib.binding * ('term * 'term list)) list |
62.17 @@ -23,12 +23,12 @@
62.18 val facts_map: (('typ, 'term, 'fact) ctxt -> ('a, 'b, 'c) ctxt) ->
62.19 (Attrib.binding * ('fact * Attrib.src list) list) list ->
62.20 (Attrib.binding * ('c * Attrib.src list) list) list
62.21 - val map_ctxt': {binding: Binding.T -> Binding.T,
62.22 - var: Binding.T * mixfix -> Binding.T * mixfix,
62.23 + val map_ctxt': {binding: binding -> binding,
62.24 + var: binding * mixfix -> binding * mixfix,
62.25 typ: 'typ -> 'a, term: 'term -> 'b, pat: 'term -> 'b, fact: 'fact -> 'c,
62.26 attrib: Attrib.src -> Attrib.src} -> ('typ, 'term, 'fact) ctxt -> ('a, 'b, 'c) ctxt
62.27 - val map_ctxt: {binding: Binding.T -> Binding.T,
62.28 - var: Binding.T * mixfix -> Binding.T * mixfix,
62.29 + val map_ctxt: {binding: binding -> binding,
62.30 + var: binding * mixfix -> binding * mixfix,
62.31 typ: 'typ -> 'a, term: 'term -> 'b, fact: 'fact -> 'c,
62.32 attrib: Attrib.src -> Attrib.src} -> ('typ, 'term, 'fact) ctxt -> ('a, 'b, 'c) ctxt
62.33 val map_ctxt_attrib: (Attrib.src -> Attrib.src) ->
62.34 @@ -41,25 +41,21 @@
62.35 val pretty_ctxt: Proof.context -> context_i -> Pretty.T list
62.36 val pretty_statement: Proof.context -> string -> thm -> Pretty.T
62.37 type witness
62.38 - val map_witness: (term * thm -> term * thm) -> witness -> witness
62.39 + val prove_witness: Proof.context -> term -> tactic -> witness
62.40 + val witness_proof: (witness list list -> Proof.context -> Proof.context) ->
62.41 + term list list -> Proof.context -> Proof.state
62.42 + val witness_proof_eqs: (witness list list -> thm list -> Proof.context -> Proof.context) ->
62.43 + term list list -> term list -> Proof.context -> Proof.state
62.44 + val witness_local_proof: (witness list list -> Proof.state -> Proof.state) ->
62.45 + string -> term list list -> Proof.context -> bool -> Proof.state -> Proof.state
62.46 val morph_witness: morphism -> witness -> witness
62.47 - val witness_prop: witness -> term
62.48 - val witness_hyps: witness -> term list
62.49 - val assume_witness: theory -> term -> witness
62.50 - val prove_witness: Proof.context -> term -> tactic -> witness
62.51 - val close_witness: witness -> witness
62.52 val conclude_witness: witness -> thm
62.53 - val mark_witness: term -> term
62.54 - val make_witness: term -> thm -> witness
62.55 - val dest_witness: witness -> term * thm
62.56 - val transfer_witness: theory -> witness -> witness
62.57 - val refine_witness: Proof.state -> Proof.state Seq.seq
62.58 val pretty_witness: Proof.context -> witness -> Pretty.T
62.59 val rename: (string * (string * mixfix option)) list -> string -> string
62.60 val rename_var_name: (string * (string * mixfix option)) list ->
62.61 string * mixfix -> string * mixfix
62.62 val rename_var: (string * (string * mixfix option)) list ->
62.63 - Binding.T * mixfix -> Binding.T * mixfix
62.64 + binding * mixfix -> binding * mixfix
62.65 val rename_term: (string * (string * mixfix option)) list -> term -> term
62.66 val rename_thm: (string * (string * mixfix option)) list -> thm -> thm
62.67 val rename_morphism: (string * (string * mixfix option)) list -> morphism
62.68 @@ -93,7 +89,7 @@
62.69
62.70 datatype ('typ, 'term) stmt =
62.71 Shows of (Attrib.binding * ('term * 'term list) list) list |
62.72 - Obtains of (Binding.T * ((Binding.T * 'typ option) list * 'term list)) list;
62.73 + Obtains of (binding * ((binding * 'typ option) list * 'term list)) list;
62.74
62.75 type statement = (string, string) stmt;
62.76 type statement_i = (typ, term) stmt;
62.77 @@ -102,7 +98,7 @@
62.78 (* context *)
62.79
62.80 datatype ('typ, 'term, 'fact) ctxt =
62.81 - Fixes of (Binding.T * 'typ option * mixfix) list |
62.82 + Fixes of (binding * 'typ option * mixfix) list |
62.83 Constrains of (string * 'typ) list |
62.84 Assumes of (Attrib.binding * ('term * 'term list) list) list |
62.85 Defines of (Attrib.binding * ('term * 'term list)) list |
62.86 @@ -300,24 +296,51 @@
62.87
62.88 datatype witness = Witness of term * thm;
62.89
62.90 +val mark_witness = Logic.protect;
62.91 +fun witness_prop (Witness (t, _)) = t;
62.92 +fun witness_hyps (Witness (_, th)) = #hyps (Thm.rep_thm th);
62.93 fun map_witness f (Witness witn) = Witness (f witn);
62.94
62.95 fun morph_witness phi = map_witness (fn (t, th) => (Morphism.term phi t, Morphism.thm phi th));
62.96
62.97 -fun witness_prop (Witness (t, _)) = t;
62.98 -fun witness_hyps (Witness (_, th)) = #hyps (Thm.rep_thm th);
62.99 -
62.100 -fun assume_witness thy t =
62.101 - Witness (t, Goal.protect (Thm.assume (Thm.cterm_of thy t)));
62.102 -
62.103 fun prove_witness ctxt t tac =
62.104 - Witness (t, Thm.close_derivation (Goal.prove ctxt [] [] (Logic.protect t) (fn _ =>
62.105 + Witness (t, Thm.close_derivation (Goal.prove ctxt [] [] (mark_witness t) (fn _ =>
62.106 Tactic.rtac Drule.protectI 1 THEN tac)));
62.107
62.108 -val close_witness = map_witness (fn (t, th) => (t, Thm.close_derivation th));
62.109 +local
62.110
62.111 -fun conclude_witness (Witness (_, th)) =
62.112 - Thm.close_derivation (MetaSimplifier.norm_hhf_protect (Goal.conclude th));
62.113 +val refine_witness =
62.114 + Proof.refine (Method.Basic (K (Method.RAW_METHOD
62.115 + (K (ALLGOALS
62.116 + (CONJUNCTS (ALLGOALS
62.117 + (CONJUNCTS (TRYALL (Tactic.rtac Drule.protectI)))))))), Position.none));
62.118 +
62.119 +fun gen_witness_proof proof after_qed wit_propss eq_props =
62.120 + let
62.121 + val propss = (map o map) (fn prop => (mark_witness prop, [])) wit_propss
62.122 + @ [map (rpair []) eq_props];
62.123 + fun after_qed' thmss =
62.124 + let
62.125 + val (wits, eqs) = split_last ((map o map) Thm.close_derivation thmss);
62.126 + in after_qed ((map2 o map2) (curry Witness) wit_propss wits) eqs end;
62.127 + in proof after_qed' propss #> refine_witness #> Seq.hd end;
62.128 +
62.129 +in
62.130 +
62.131 +fun witness_proof after_qed wit_propss =
62.132 + gen_witness_proof (Proof.theorem_i NONE) (fn wits => fn _ => after_qed wits)
62.133 + wit_propss [];
62.134 +
62.135 +val witness_proof_eqs = gen_witness_proof (Proof.theorem_i NONE);
62.136 +
62.137 +fun witness_local_proof after_qed cmd wit_propss goal_ctxt int =
62.138 + gen_witness_proof (fn after_qed' => fn propss =>
62.139 + Proof.map_context (K goal_ctxt)
62.140 + #> Proof.local_goal (ProofDisplay.print_results int) (K I) ProofContext.bind_propp_i
62.141 + cmd NONE after_qed' (map (pair (Binding.empty, [])) propss))
62.142 + (fn wits => fn _ => after_qed wits) wit_propss [];
62.143 +
62.144 +end; (*local*)
62.145
62.146 fun compose_witness (Witness (_, th)) r =
62.147 let
62.148 @@ -330,18 +353,8 @@
62.149 (Thm.instantiate (Thm.match (Thm.cprop_of th', A)) th'))
62.150 end;
62.151
62.152 -val mark_witness = Logic.protect;
62.153 -
62.154 -fun make_witness t th = Witness (t, th);
62.155 -fun dest_witness (Witness w) = w;
62.156 -
62.157 -fun transfer_witness thy (Witness (t, th)) = Witness (t, Thm.transfer thy th);
62.158 -
62.159 -val refine_witness =
62.160 - Proof.refine (Method.Basic (K (Method.RAW_METHOD
62.161 - (K (ALLGOALS
62.162 - (CONJUNCTS (ALLGOALS
62.163 - (CONJUNCTS (TRYALL (Tactic.rtac Drule.protectI)))))))), Position.none));
62.164 +fun conclude_witness (Witness (_, th)) =
62.165 + Thm.close_derivation (MetaSimplifier.norm_hhf_protect (Goal.conclude th));
62.166
62.167 fun pretty_witness ctxt witn =
62.168 let val prt_term = Pretty.quote o Syntax.pretty_term ctxt in
63.1 --- a/src/Pure/Isar/expression.ML Wed Jan 21 15:26:02 2009 +0100
63.2 +++ b/src/Pure/Isar/expression.ML Wed Jan 21 20:05:31 2009 +0100
63.3 @@ -9,8 +9,8 @@
63.4 (* Locale expressions *)
63.5 datatype 'term map = Positional of 'term option list | Named of (string * 'term) list
63.6 type 'term expr = (string * ((string * bool) * 'term map)) list
63.7 - type expression_i = term expr * (Binding.T * typ option * mixfix) list
63.8 - type expression = string expr * (Binding.T * string option * mixfix) list
63.9 + type expression_i = term expr * (binding * typ option * mixfix) list
63.10 + type expression = string expr * (binding * string option * mixfix) list
63.11
63.12 (* Processing of context statements *)
63.13 val cert_statement: Element.context_i list -> (term * term list) list list ->
63.14 @@ -20,14 +20,14 @@
63.15
63.16 (* Declaring locales *)
63.17 val cert_declaration: expression_i -> Element.context_i list -> Proof.context ->
63.18 - ((Binding.T * typ option * mixfix) list * (string * morphism) list
63.19 + ((binding * typ option * mixfix) list * (string * morphism) list
63.20 * Element.context_i list) * ((string * typ) list * Proof.context)
63.21 val cert_read_declaration: expression_i -> Element.context list -> Proof.context ->
63.22 - ((Binding.T * typ option * mixfix) list * (string * morphism) list
63.23 + ((binding * typ option * mixfix) list * (string * morphism) list
63.24 * Element.context_i list) * ((string * typ) list * Proof.context)
63.25 (*FIXME*)
63.26 val read_declaration: expression -> Element.context list -> Proof.context ->
63.27 - ((Binding.T * typ option * mixfix) list * (string * morphism) list
63.28 + ((binding * typ option * mixfix) list * (string * morphism) list
63.29 * Element.context_i list) * ((string * typ) list * Proof.context)
63.30 val add_locale: bstring -> bstring -> expression_i -> Element.context_i list ->
63.31 theory -> string * local_theory
63.32 @@ -64,8 +64,8 @@
63.33
63.34 type 'term expr = (string * ((string * bool) * 'term map)) list;
63.35
63.36 -type expression = string expr * (Binding.T * string option * mixfix) list;
63.37 -type expression_i = term expr * (Binding.T * typ option * mixfix) list;
63.38 +type expression = string expr * (binding * string option * mixfix) list;
63.39 +type expression_i = term expr * (binding * typ option * mixfix) list;
63.40
63.41
63.42 (** Internalise locale names in expr **)
63.43 @@ -640,7 +640,7 @@
63.44 |> bodyT = propT ? Sign.add_advanced_trfuns ([], [], [aprop_tr' (length args) name], [])
63.45 |> Sign.declare_const [] ((Binding.name bname, predT), NoSyn) |> snd
63.46 |> PureThy.add_defs false
63.47 - [((Thm.def_name bname, Logic.mk_equals (head, body)), [Thm.kind_internal])];
63.48 + [((Binding.name (Thm.def_name bname), Logic.mk_equals (head, body)), [Thm.kind_internal])];
63.49 val defs_ctxt = ProofContext.init defs_thy |> Variable.declare_term head;
63.50
63.51 val cert = Thm.cterm_of defs_thy;
63.52 @@ -786,41 +786,23 @@
63.53
63.54 (*** Interpretation ***)
63.55
63.56 -(** Witnesses and goals **)
63.57 -
63.58 -fun prep_propp propss = propss |> map (map (rpair [] o Element.mark_witness));
63.59 -
63.60 -val prep_result = map2 (fn props => fn thms =>
63.61 - map2 Element.make_witness props (map Thm.close_derivation thms));
63.62 -
63.63 -
63.64 (** Interpretation between locales: declaring sublocale relationships **)
63.65
63.66 local
63.67
63.68 -fun gen_sublocale prep_expr intern
63.69 - raw_target expression thy =
63.70 +fun gen_sublocale prep_expr intern raw_target expression thy =
63.71 let
63.72 val target = intern thy raw_target;
63.73 val target_ctxt = Locale.init target thy;
63.74
63.75 val ((propss, deps, export), goal_ctxt) = prep_expr expression target_ctxt;
63.76
63.77 - fun store_dep (name, morph) thms =
63.78 - Locale.add_dependency target (name, morph $> Element.satisfy_morphism thms $> export);
63.79 -
63.80 - fun after_qed results =
63.81 - ProofContext.theory (
63.82 - (* store dependencies *)
63.83 - fold2 store_dep deps (prep_result propss results) #>
63.84 - (* propagate registrations *)
63.85 - (fn thy => fold_rev Locale.activate_global_facts
63.86 + fun after_qed witss = ProofContext.theory (
63.87 + fold2 (fn (name, morph) => fn wits => Locale.add_dependency target
63.88 + (name, morph $> Element.satisfy_morphism wits $> export)) deps witss #>
63.89 + (fn thy => fold_rev Locale.activate_global_facts
63.90 (Locale.get_registrations thy) thy));
63.91 - in
63.92 - goal_ctxt |>
63.93 - Proof.theorem_i NONE after_qed (prep_propp propss) |>
63.94 - Element.refine_witness |> Seq.hd
63.95 - end;
63.96 + in Element.witness_proof after_qed propss goal_ctxt end;
63.97
63.98 in
63.99
63.100 @@ -845,10 +827,10 @@
63.101 val goal_ctxt = fold Variable.auto_fixes eqns expr_ctxt;
63.102 val export' = Variable.export_morphism goal_ctxt expr_ctxt;
63.103
63.104 - fun store_reg ((name, morph), thms) thy =
63.105 + fun store_reg ((name, morph), wits) thy =
63.106 let
63.107 - val thms' = map (Element.morph_witness export') thms;
63.108 - val morph' = morph $> Element.satisfy_morphism thms';
63.109 + val wits' = map (Element.morph_witness export') wits;
63.110 + val morph' = morph $> Element.satisfy_morphism wits';
63.111 in
63.112 thy
63.113 |> Locale.add_registration (name, (morph', export))
63.114 @@ -859,35 +841,26 @@
63.115 thy
63.116 |> fold (fn (name, morph) =>
63.117 Locale.activate_global_facts (name, morph $> export)) regs
63.118 - | store_eqns_activate regs thms thy =
63.119 + | store_eqns_activate regs eqs thy =
63.120 let
63.121 - val thms' = thms |> map (Element.conclude_witness #>
63.122 - Morphism.thm (export' $> export) #>
63.123 + val eqs' = eqs |> map (Morphism.thm (export' $> export) #>
63.124 LocalDefs.meta_rewrite_rule (ProofContext.init thy) #>
63.125 Drule.abs_def);
63.126 - val eq_morph = Element.eq_morphism thy thms';
63.127 + val eq_morph = Element.eq_morphism thy eqs';
63.128 val eq_attns' = map ((apsnd o map) (Attrib.attribute_i thy)) eq_attns;
63.129 in
63.130 thy
63.131 |> fold (fn (name, morph) =>
63.132 Locale.amend_registration eq_morph (name, morph) #>
63.133 Locale.activate_global_facts (name, morph $> eq_morph $> export)) regs
63.134 - |> PureThy.note_thmss Thm.lemmaK (eq_attns' ~~ map (fn th => [([th], [])]) thms')
63.135 + |> PureThy.note_thmss Thm.lemmaK (eq_attns' ~~ map (fn eq => [([eq], [])]) eqs')
63.136 |> snd
63.137 end;
63.138
63.139 - fun after_qed results =
63.140 - let
63.141 - val (wits_reg, wits_eq) = split_last (prep_result (propss @ [eqns]) results);
63.142 - in ProofContext.theory (fold_map store_reg (regs ~~ wits_reg)
63.143 - #-> (fn regs => store_eqns_activate regs wits_eq))
63.144 - end;
63.145 + fun after_qed wits eqs = ProofContext.theory (fold_map store_reg (regs ~~ wits)
63.146 + #-> (fn regs => store_eqns_activate regs eqs));
63.147
63.148 - in
63.149 - goal_ctxt |>
63.150 - Proof.theorem_i NONE after_qed (prep_propp (propss @ [eqns])) |>
63.151 - Element.refine_witness |> Seq.hd
63.152 - end;
63.153 + in Element.witness_proof_eqs after_qed propss eqns goal_ctxt end;
63.154
63.155 in
63.156
63.157 @@ -910,20 +883,16 @@
63.158
63.159 val ((propss, regs, export), goal_ctxt) = prep_expr expression ctxt;
63.160
63.161 - fun store_reg ((name, morph), thms) =
63.162 + fun store_reg (name, morph) thms =
63.163 let
63.164 val morph' = morph $> Element.satisfy_morphism thms $> export;
63.165 - in
63.166 - Locale.activate_local_facts (name, morph')
63.167 - end;
63.168 + in Locale.activate_local_facts (name, morph') end;
63.169
63.170 - fun after_qed results =
63.171 - Proof.map_context (fold store_reg (regs ~~ prep_result propss results));
63.172 + fun after_qed wits =
63.173 + Proof.map_context (fold2 store_reg regs wits);
63.174 in
63.175 - state |> Proof.map_context (K goal_ctxt) |>
63.176 - Proof.local_goal (ProofDisplay.print_results int) (K I) ProofContext.bind_propp_i
63.177 - "interpret" NONE after_qed (map (pair (Binding.empty, [])) (prep_propp propss)) |>
63.178 - Element.refine_witness |> Seq.hd
63.179 + state
63.180 + |> Element.witness_local_proof after_qed "interpret" propss goal_ctxt int
63.181 end;
63.182
63.183 in
64.1 --- a/src/Pure/Isar/isar_cmd.ML Wed Jan 21 15:26:02 2009 +0100
64.2 +++ b/src/Pure/Isar/isar_cmd.ML Wed Jan 21 20:05:31 2009 +0100
64.3 @@ -13,8 +13,8 @@
64.4 val typed_print_translation: bool * (string * Position.T) -> theory -> theory
64.5 val print_ast_translation: bool * (string * Position.T) -> theory -> theory
64.6 val oracle: bstring -> SymbolPos.text * Position.T -> theory -> theory
64.7 - val add_axioms: ((Binding.T * string) * Attrib.src list) list -> theory -> theory
64.8 - val add_defs: (bool * bool) * ((Binding.T * string) * Attrib.src list) list -> theory -> theory
64.9 + val add_axioms: ((binding * string) * Attrib.src list) list -> theory -> theory
64.10 + val add_defs: (bool * bool) * ((binding * string) * Attrib.src list) list -> theory -> theory
64.11 val declaration: string * Position.T -> local_theory -> local_theory
64.12 val simproc_setup: string -> string list -> string * Position.T -> string list ->
64.13 local_theory -> local_theory
64.14 @@ -53,7 +53,6 @@
64.15 val print_theorems: Toplevel.transition -> Toplevel.transition
64.16 val print_locales: Toplevel.transition -> Toplevel.transition
64.17 val print_locale: bool * xstring -> Toplevel.transition -> Toplevel.transition
64.18 - val print_registrations: bool -> string -> Toplevel.transition -> Toplevel.transition
64.19 val print_attributes: Toplevel.transition -> Toplevel.transition
64.20 val print_simpset: Toplevel.transition -> Toplevel.transition
64.21 val print_rules: Toplevel.transition -> Toplevel.transition
64.22 @@ -359,12 +358,6 @@
64.23 Toplevel.keep (fn state =>
64.24 Locale.print_locale (Toplevel.theory_of state) show_facts name);
64.25
64.26 -fun print_registrations show_wits name = Toplevel.unknown_context o
64.27 - Toplevel.keep (Toplevel.node_case
64.28 - (Context.cases (Old_Locale.print_registrations show_wits name o ProofContext.init)
64.29 - (Old_Locale.print_registrations show_wits name))
64.30 - (Old_Locale.print_registrations show_wits name o Proof.context_of));
64.31 -
64.32 val print_attributes = Toplevel.unknown_theory o
64.33 Toplevel.keep (Attrib.print_attributes o Toplevel.theory_of);
64.34
65.1 --- a/src/Pure/Isar/isar_syn.ML Wed Jan 21 15:26:02 2009 +0100
65.2 +++ b/src/Pure/Isar/isar_syn.ML Wed Jan 21 20:05:31 2009 +0100
65.3 @@ -418,45 +418,6 @@
65.4 >> (fn expr => Toplevel.print o
65.5 Toplevel.proof' (fn int => Expression.interpret_cmd expr int)));
65.6
65.7 -local
65.8 -
65.9 -val opt_prefix = Scan.optional (P.binding --| P.$$$ ":") Binding.empty;
65.10 -
65.11 -in
65.12 -
65.13 -val locale_val =
65.14 - SpecParse.locale_expr --
65.15 - Scan.optional (P.$$$ "+" |-- P.!!! (Scan.repeat1 SpecParse.context_element)) [] ||
65.16 - Scan.repeat1 SpecParse.context_element >> pair Old_Locale.empty;
65.17 -
65.18 -val _ =
65.19 - OuterSyntax.command "class_locale" "define named proof context based on classes" K.thy_decl
65.20 - (P.name -- Scan.optional (P.$$$ "=" |-- P.!!! locale_val) (Old_Locale.empty, []) -- P.opt_begin
65.21 - >> (fn ((name, (expr, elems)), begin) =>
65.22 - (begin ? Toplevel.print) o Toplevel.begin_local_theory begin
65.23 - (Old_Locale.add_locale_cmd name expr elems #-> TheoryTarget.begin)));
65.24 -
65.25 -val _ =
65.26 - OuterSyntax.command "class_interpretation"
65.27 - "prove and register interpretation of locale expression in theory or locale" K.thy_goal
65.28 - (P.xname --| (P.$$$ "\\<subseteq>" || P.$$$ "<") -- P.!!! SpecParse.locale_expr
65.29 - >> (Toplevel.print oo (Toplevel.theory_to_proof o Old_Locale.interpretation_in_locale I)) ||
65.30 - opt_prefix -- SpecParse.locale_expr -- SpecParse.locale_insts
65.31 - >> (fn ((name, expr), insts) => Toplevel.print o
65.32 - Toplevel.theory_to_proof
65.33 - (Old_Locale.interpretation_cmd (Binding.base_name name) expr insts)));
65.34 -
65.35 -val _ =
65.36 - OuterSyntax.command "class_interpret"
65.37 - "prove and register interpretation of locale expression in proof context"
65.38 - (K.tag_proof K.prf_goal)
65.39 - (opt_prefix -- SpecParse.locale_expr -- SpecParse.locale_insts
65.40 - >> (fn ((name, expr), insts) => Toplevel.print o
65.41 - Toplevel.proof'
65.42 - (fn int => Old_Locale.interpret_cmd (Binding.base_name name) expr insts int)));
65.43 -
65.44 -end;
65.45 -
65.46
65.47 (* classes *)
65.48
65.49 @@ -857,12 +818,6 @@
65.50 (opt_bang -- P.xname >> (Toplevel.no_timing oo IsarCmd.print_locale));
65.51
65.52 val _ =
65.53 - OuterSyntax.improper_command "print_interps"
65.54 - "print interpretations of named locale" K.diag
65.55 - (Scan.optional (P.$$$ "!" >> K true) false -- P.xname
65.56 - >> (Toplevel.no_timing oo uncurry IsarCmd.print_registrations));
65.57 -
65.58 -val _ =
65.59 OuterSyntax.improper_command "print_attributes" "print attributes of this theory" K.diag
65.60 (Scan.succeed (Toplevel.no_timing o IsarCmd.print_attributes));
65.61
66.1 --- a/src/Pure/Isar/local_defs.ML Wed Jan 21 15:26:02 2009 +0100
66.2 +++ b/src/Pure/Isar/local_defs.ML Wed Jan 21 20:05:31 2009 +0100
66.3 @@ -11,10 +11,10 @@
66.4 val mk_def: Proof.context -> (string * term) list -> term list
66.5 val expand: cterm list -> thm -> thm
66.6 val def_export: Assumption.export
66.7 - val add_defs: ((Binding.T * mixfix) * ((Binding.T * attribute list) * term)) list ->
66.8 + val add_defs: ((binding * mixfix) * ((binding * attribute list) * term)) list ->
66.9 Proof.context -> (term * (string * thm)) list * Proof.context
66.10 - val add_def: (Binding.T * mixfix) * term -> Proof.context -> (term * thm) * Proof.context
66.11 - val fixed_abbrev: (Binding.T * mixfix) * term -> Proof.context ->
66.12 + val add_def: (binding * mixfix) * term -> Proof.context -> (term * thm) * Proof.context
66.13 + val fixed_abbrev: (binding * mixfix) * term -> Proof.context ->
66.14 (term * term) * Proof.context
66.15 val export: Proof.context -> Proof.context -> thm -> thm list * thm
66.16 val export_cterm: Proof.context -> Proof.context -> cterm -> cterm * thm
67.1 --- a/src/Pure/Isar/local_theory.ML Wed Jan 21 15:26:02 2009 +0100
67.2 +++ b/src/Pure/Isar/local_theory.ML Wed Jan 21 20:05:31 2009 +0100
67.3 @@ -18,16 +18,16 @@
67.4 val raw_theory: (theory -> theory) -> local_theory -> local_theory
67.5 val checkpoint: local_theory -> local_theory
67.6 val full_naming: local_theory -> NameSpace.naming
67.7 - val full_name: local_theory -> Binding.T -> string
67.8 + val full_name: local_theory -> binding -> string
67.9 val theory_result: (theory -> 'a * theory) -> local_theory -> 'a * local_theory
67.10 val theory: (theory -> theory) -> local_theory -> local_theory
67.11 val target_result: (Proof.context -> 'a * Proof.context) -> local_theory -> 'a * local_theory
67.12 val target: (Proof.context -> Proof.context) -> local_theory -> local_theory
67.13 val affirm: local_theory -> local_theory
67.14 val pretty: local_theory -> Pretty.T list
67.15 - val abbrev: Syntax.mode -> (Binding.T * mixfix) * term -> local_theory ->
67.16 + val abbrev: Syntax.mode -> (binding * mixfix) * term -> local_theory ->
67.17 (term * term) * local_theory
67.18 - val define: string -> (Binding.T * mixfix) * (Attrib.binding * term) -> local_theory ->
67.19 + val define: string -> (binding * mixfix) * (Attrib.binding * term) -> local_theory ->
67.20 (term * (string * thm)) * local_theory
67.21 val note: string -> Attrib.binding * thm list -> local_theory -> (string * thm list) * local_theory
67.22 val notes: string -> (Attrib.binding * (thm list * Attrib.src list) list) list ->
67.23 @@ -55,10 +55,10 @@
67.24
67.25 type operations =
67.26 {pretty: local_theory -> Pretty.T list,
67.27 - abbrev: Syntax.mode -> (Binding.T * mixfix) * term -> local_theory ->
67.28 + abbrev: Syntax.mode -> (binding * mixfix) * term -> local_theory ->
67.29 (term * term) * local_theory,
67.30 define: string ->
67.31 - (Binding.T * mixfix) * (Attrib.binding * term) -> local_theory ->
67.32 + (binding * mixfix) * (Attrib.binding * term) -> local_theory ->
67.33 (term * (string * thm)) * local_theory,
67.34 notes: string ->
67.35 (Attrib.binding * (thm list * Attrib.src list) list) list ->
68.1 --- a/src/Pure/Isar/locale.ML Wed Jan 21 15:26:02 2009 +0100
68.2 +++ b/src/Pure/Isar/locale.ML Wed Jan 21 20:05:31 2009 +0100
68.3 @@ -29,23 +29,18 @@
68.4
68.5 signature LOCALE =
68.6 sig
68.7 - type locale
68.8 -
68.9 + (* Locale specification *)
68.10 val register_locale: bstring ->
68.11 - (string * sort) list * (Binding.T * typ option * mixfix) list ->
68.12 + (string * sort) list * (binding * typ option * mixfix) list ->
68.13 term option * term list ->
68.14 thm option * thm option -> thm list ->
68.15 (declaration * stamp) list * (declaration * stamp) list ->
68.16 ((string * (Attrib.binding * (thm list * Attrib.src list) list) list) * stamp) list ->
68.17 ((string * morphism) * stamp) list -> theory -> theory
68.18 -
68.19 - (* Locale name space *)
68.20 val intern: theory -> xstring -> string
68.21 val extern: theory -> string -> xstring
68.22 -
68.23 - (* Specification *)
68.24 val defined: theory -> string -> bool
68.25 - val params_of: theory -> string -> (Binding.T * typ option * mixfix) list
68.26 + val params_of: theory -> string -> (binding * typ option * mixfix) list
68.27 val intros_of: theory -> string -> thm option * thm option
68.28 val axioms_of: theory -> string -> thm list
68.29 val instance_of: theory -> string -> morphism -> term list
68.30 @@ -112,13 +107,25 @@
68.31
68.32 datatype ctxt = datatype Element.ctxt;
68.33
68.34 +fun global_note_qualified kind facts thy = (*FIXME*)
68.35 + thy
68.36 + |> Sign.qualified_names
68.37 + |> PureThy.note_thmss kind facts
68.38 + ||> Sign.restore_naming thy;
68.39 +
68.40 +fun local_note_qualified kind facts ctxt = (*FIXME*)
68.41 + ctxt
68.42 + |> ProofContext.qualified_names
68.43 + |> ProofContext.note_thmss_i kind facts
68.44 + ||> ProofContext.restore_naming ctxt;
68.45 +
68.46
68.47
68.48 (*** Theory data ***)
68.49
68.50 datatype locale = Loc of {
68.51 (** static part **)
68.52 - parameters: (string * sort) list * (Binding.T * typ option * mixfix) list,
68.53 + parameters: (string * sort) list * (binding * typ option * mixfix) list,
68.54 (* type and term parameters *)
68.55 spec: term option * term list,
68.56 (* assumptions (as a single predicate expression) and defines *)
68.57 @@ -330,7 +337,7 @@
68.58 fun init_global_elem (Notes (kind, facts)) thy =
68.59 let
68.60 val facts' = Attrib.map_facts (Attrib.attribute_i thy) facts
68.61 - in Old_Locale.global_note_qualified kind facts' thy |> snd end
68.62 + in global_note_qualified kind facts' thy |> snd end
68.63
68.64 fun init_local_elem (Fixes fixes) ctxt = ctxt |>
68.65 ProofContext.add_fixes_i fixes |> snd
68.66 @@ -352,7 +359,7 @@
68.67 | init_local_elem (Notes (kind, facts)) ctxt =
68.68 let
68.69 val facts' = Attrib.map_facts (Attrib.attribute_i (ProofContext.theory_of ctxt)) facts
68.70 - in Old_Locale.local_note_qualified kind facts' ctxt |> snd end
68.71 + in local_note_qualified kind facts' ctxt |> snd end
68.72
68.73 fun cons_elem false (Notes notes) elems = elems
68.74 | cons_elem _ elem elems = elem :: elems
68.75 @@ -445,7 +452,7 @@
68.76 let
68.77 val args'' = snd args' |> Element.facts_map (Element.morph_ctxt morph) |>
68.78 Attrib.map_facts (Attrib.attribute_i thy)
68.79 - in Old_Locale.global_note_qualified kind args'' #> snd end)
68.80 + in global_note_qualified kind args'' #> snd end)
68.81 (get_registrations thy |> filter (fn (name, _) => name = loc)) thy))
68.82 in ctxt'' end;
68.83
68.84 @@ -496,12 +503,10 @@
68.85 val _ = Context.>> (Context.map_theory
68.86 (Method.add_methods
68.87 [("intro_locales",
68.88 - Method.ctxt_args (fn ctxt => Method.METHOD (intro_locales_tac false ctxt ORELSE'
68.89 - Old_Locale.intro_locales_tac false ctxt)),
68.90 + Method.ctxt_args (fn ctxt => Method.METHOD (intro_locales_tac false ctxt)),
68.91 "back-chain introduction rules of locales without unfolding predicates"),
68.92 ("unfold_locales",
68.93 - Method.ctxt_args (fn ctxt => Method.METHOD (intro_locales_tac true ctxt ORELSE'
68.94 - Old_Locale.intro_locales_tac true ctxt)),
68.95 + Method.ctxt_args (fn ctxt => Method.METHOD (intro_locales_tac true ctxt)),
68.96 "back-chain all introduction rules of locales")]));
68.97
68.98 end;
69.1 --- a/src/Pure/Isar/obtain.ML Wed Jan 21 15:26:02 2009 +0100
69.2 +++ b/src/Pure/Isar/obtain.ML Wed Jan 21 20:05:31 2009 +0100
69.3 @@ -39,16 +39,16 @@
69.4 signature OBTAIN =
69.5 sig
69.6 val thatN: string
69.7 - val obtain: string -> (Binding.T * string option * mixfix) list ->
69.8 + val obtain: string -> (binding * string option * mixfix) list ->
69.9 (Attrib.binding * (string * string list) list) list ->
69.10 bool -> Proof.state -> Proof.state
69.11 - val obtain_i: string -> (Binding.T * typ option * mixfix) list ->
69.12 - ((Binding.T * attribute list) * (term * term list) list) list ->
69.13 + val obtain_i: string -> (binding * typ option * mixfix) list ->
69.14 + ((binding * attribute list) * (term * term list) list) list ->
69.15 bool -> Proof.state -> Proof.state
69.16 val result: (Proof.context -> tactic) -> thm list -> Proof.context ->
69.17 (cterm list * thm list) * Proof.context
69.18 - val guess: (Binding.T * string option * mixfix) list -> bool -> Proof.state -> Proof.state
69.19 - val guess_i: (Binding.T * typ option * mixfix) list -> bool -> Proof.state -> Proof.state
69.20 + val guess: (binding * string option * mixfix) list -> bool -> Proof.state -> Proof.state
69.21 + val guess_i: (binding * typ option * mixfix) list -> bool -> Proof.state -> Proof.state
69.22 end;
69.23
69.24 structure Obtain: OBTAIN =
70.1 --- a/src/Pure/Isar/old_locale.ML Wed Jan 21 15:26:02 2009 +0100
70.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
70.3 @@ -1,2485 +0,0 @@
70.4 -(* Title: Pure/Isar/locale.ML
70.5 - Author: Clemens Ballarin, TU Muenchen
70.6 - Author: Markus Wenzel, LMU/TU Muenchen
70.7 -
70.8 -Locales -- Isar proof contexts as meta-level predicates, with local
70.9 -syntax and implicit structures.
70.10 -
70.11 -Draws basic ideas from Florian Kammueller's original version of
70.12 -locales, but uses the richer infrastructure of Isar instead of the raw
70.13 -meta-logic. Furthermore, structured import of contexts (with merge
70.14 -and rename operations) are provided, as well as type-inference of the
70.15 -signature parts, and predicate definitions of the specification text.
70.16 -
70.17 -Interpretation enables the reuse of theorems of locales in other
70.18 -contexts, namely those defined by theories, structured proofs and
70.19 -locales themselves.
70.20 -
70.21 -See also:
70.22 -
70.23 -[1] Clemens Ballarin. Locales and Locale Expressions in Isabelle/Isar.
70.24 - In Stefano Berardi et al., Types for Proofs and Programs: International
70.25 - Workshop, TYPES 2003, Torino, Italy, LNCS 3085, pages 34-50, 2004.
70.26 -[2] Clemens Ballarin. Interpretation of Locales in Isabelle: Managing
70.27 - Dependencies between Locales. Technical Report TUM-I0607, Technische
70.28 - Universitaet Muenchen, 2006.
70.29 -[3] Clemens Ballarin. Interpretation of Locales in Isabelle: Theories and
70.30 - Proof Contexts. In J.M. Borwein and W.M. Farmer, MKM 2006, LNAI 4108,
70.31 - pages 31-43, 2006.
70.32 -*)
70.33 -
70.34 -(* TODO:
70.35 -- beta-eta normalisation of interpretation parameters
70.36 -- dangling type frees in locales
70.37 -- test subsumption of interpretations when merging theories
70.38 -*)
70.39 -
70.40 -signature OLD_LOCALE =
70.41 -sig
70.42 - datatype expr =
70.43 - Locale of string |
70.44 - Rename of expr * (string * mixfix option) option list |
70.45 - Merge of expr list
70.46 - val empty: expr
70.47 -
70.48 - val intern: theory -> xstring -> string
70.49 - val intern_expr: theory -> expr -> expr
70.50 - val extern: theory -> string -> xstring
70.51 - val init: string -> theory -> Proof.context
70.52 -
70.53 - (* The specification of a locale *)
70.54 - val parameters_of: theory -> string -> ((string * typ) * mixfix) list
70.55 - val parameters_of_expr: theory -> expr -> ((string * typ) * mixfix) list
70.56 - val local_asms_of: theory -> string -> (Attrib.binding * term list) list
70.57 - val global_asms_of: theory -> string -> (Attrib.binding * term list) list
70.58 -
70.59 - (* Theorems *)
70.60 - val intros: theory -> string -> thm list * thm list
70.61 - val dests: theory -> string -> thm list
70.62 - (* Not part of the official interface. DO NOT USE *)
70.63 - val facts_of: theory -> string -> (Attrib.binding * (thm list * Attrib.src list) list) list list
70.64 -
70.65 - (* Not part of the official interface. DO NOT USE *)
70.66 - val declarations_of: theory -> string -> declaration list * declaration list;
70.67 -
70.68 - (* Processing of locale statements *)
70.69 - val read_context_statement: string option -> Element.context list ->
70.70 - (string * string list) list list -> Proof.context ->
70.71 - string option * Proof.context * Proof.context * (term * term list) list list
70.72 - val read_context_statement_cmd: xstring option -> Element.context list ->
70.73 - (string * string list) list list -> Proof.context ->
70.74 - string option * Proof.context * Proof.context * (term * term list) list list
70.75 - val cert_context_statement: string option -> Element.context_i list ->
70.76 - (term * term list) list list -> Proof.context ->
70.77 - string option * Proof.context * Proof.context * (term * term list) list list
70.78 - val read_expr: expr -> Element.context list -> Proof.context ->
70.79 - Element.context_i list * Proof.context
70.80 - val cert_expr: expr -> Element.context_i list -> Proof.context ->
70.81 - Element.context_i list * Proof.context
70.82 -
70.83 - (* Diagnostic functions *)
70.84 - val print_locales: theory -> unit
70.85 - val print_locale: theory -> bool -> expr -> Element.context list -> unit
70.86 - val print_registrations: bool -> string -> Proof.context -> unit
70.87 -
70.88 - val add_locale: string -> bstring -> expr -> Element.context_i list -> theory
70.89 - -> string * Proof.context
70.90 - val add_locale_cmd: bstring -> expr -> Element.context list -> theory
70.91 - -> string * Proof.context
70.92 -
70.93 - (* Tactics *)
70.94 - val intro_locales_tac: bool -> Proof.context -> thm list -> tactic
70.95 -
70.96 - (* Storing results *)
70.97 - val global_note_qualified: string ->
70.98 - ((Binding.T * attribute list) * (thm list * attribute list) list) list ->
70.99 - theory -> (string * thm list) list * theory
70.100 - val local_note_qualified: string ->
70.101 - ((Binding.T * attribute list) * (thm list * attribute list) list) list ->
70.102 - Proof.context -> (string * thm list) list * Proof.context
70.103 - val add_thmss: string -> string -> (Attrib.binding * (thm list * Attrib.src list) list) list ->
70.104 - Proof.context -> Proof.context
70.105 - val add_type_syntax: string -> declaration -> Proof.context -> Proof.context
70.106 - val add_term_syntax: string -> declaration -> Proof.context -> Proof.context
70.107 - val add_declaration: string -> declaration -> Proof.context -> Proof.context
70.108 -
70.109 - (* Interpretation *)
70.110 - val get_interpret_morph: theory -> (Binding.T -> Binding.T) -> string * string ->
70.111 - (Morphism.morphism * ((typ Vartab.table * typ list) * (term Vartab.table * term list))) ->
70.112 - string -> term list -> Morphism.morphism
70.113 - val interpretation: (Proof.context -> Proof.context) ->
70.114 - (Binding.T -> Binding.T) -> expr ->
70.115 - term option list * (Attrib.binding * term) list ->
70.116 - theory ->
70.117 - (Morphism.morphism * ((typ Vartab.table * typ list) * (term Vartab.table * term list))) * Proof.state
70.118 - val interpretation_cmd: string -> expr -> string option list * (Attrib.binding * string) list ->
70.119 - theory -> Proof.state
70.120 - val interpretation_in_locale: (Proof.context -> Proof.context) ->
70.121 - xstring * expr -> theory -> Proof.state
70.122 - val interpret: (Proof.state -> Proof.state) ->
70.123 - (Binding.T -> Binding.T) -> expr ->
70.124 - term option list * (Attrib.binding * term) list ->
70.125 - bool -> Proof.state ->
70.126 - (Morphism.morphism * ((typ Vartab.table * typ list) * (term Vartab.table * term list))) * Proof.state
70.127 - val interpret_cmd: string -> expr -> string option list * (Attrib.binding * string) list ->
70.128 - bool -> Proof.state -> Proof.state
70.129 -end;
70.130 -
70.131 -structure Old_Locale: OLD_LOCALE =
70.132 -struct
70.133 -
70.134 -(* legacy operations *)
70.135 -
70.136 -fun merge_lists _ xs [] = xs
70.137 - | merge_lists _ [] ys = ys
70.138 - | merge_lists eq xs ys = xs @ filter_out (member eq xs) ys;
70.139 -
70.140 -fun merge_alists eq xs = merge_lists (eq_fst eq) xs;
70.141 -
70.142 -
70.143 -(* auxiliary: noting name bindings with qualified base names *)
70.144 -
70.145 -fun global_note_qualified kind facts thy =
70.146 - thy
70.147 - |> Sign.qualified_names
70.148 - |> PureThy.note_thmss kind facts
70.149 - ||> Sign.restore_naming thy;
70.150 -
70.151 -fun local_note_qualified kind facts ctxt =
70.152 - ctxt
70.153 - |> ProofContext.qualified_names
70.154 - |> ProofContext.note_thmss_i kind facts
70.155 - ||> ProofContext.restore_naming ctxt;
70.156 -
70.157 -
70.158 -(** locale elements and expressions **)
70.159 -
70.160 -datatype ctxt = datatype Element.ctxt;
70.161 -
70.162 -datatype expr =
70.163 - Locale of string |
70.164 - Rename of expr * (string * mixfix option) option list |
70.165 - Merge of expr list;
70.166 -
70.167 -val empty = Merge [];
70.168 -
70.169 -datatype 'a element =
70.170 - Elem of 'a | Expr of expr;
70.171 -
70.172 -fun map_elem f (Elem e) = Elem (f e)
70.173 - | map_elem _ (Expr e) = Expr e;
70.174 -
70.175 -type decl = declaration * stamp;
70.176 -
70.177 -type locale =
70.178 - {axiom: Element.witness list,
70.179 - (* For locales that define predicates this is [A [A]], where A is the locale
70.180 - specification. Otherwise [].
70.181 - Only required to generate the right witnesses for locales with predicates. *)
70.182 - elems: (Element.context_i * stamp) list,
70.183 - (* Static content, neither Fixes nor Constrains elements *)
70.184 - params: ((string * typ) * mixfix) list, (*all term params*)
70.185 - decls: decl list * decl list, (*type/term_syntax declarations*)
70.186 - regs: ((string * string list) * Element.witness list) list,
70.187 - (* Registrations: indentifiers and witnesses of locales interpreted in the locale. *)
70.188 - intros: thm list * thm list,
70.189 - (* Introduction rules: of delta predicate and locale predicate. *)
70.190 - dests: thm list}
70.191 - (* Destruction rules: projections from locale predicate to predicates of fragments. *)
70.192 -
70.193 -(* CB: an internal (Int) locale element was either imported or included,
70.194 - an external (Ext) element appears directly in the locale text. *)
70.195 -
70.196 -datatype ('a, 'b) int_ext = Int of 'a | Ext of 'b;
70.197 -
70.198 -
70.199 -
70.200 -(** substitutions on Vars -- clone from element.ML **)
70.201 -
70.202 -(* instantiate types *)
70.203 -
70.204 -fun var_instT_type env =
70.205 - if Vartab.is_empty env then I
70.206 - else Term.map_type_tvar (fn (x, S) => the_default (TVar (x, S)) (Vartab.lookup env x));
70.207 -
70.208 -fun var_instT_term env =
70.209 - if Vartab.is_empty env then I
70.210 - else Term.map_types (var_instT_type env);
70.211 -
70.212 -fun var_inst_term (envT, env) =
70.213 - if Vartab.is_empty env then var_instT_term envT
70.214 - else
70.215 - let
70.216 - val instT = var_instT_type envT;
70.217 - fun inst (Const (x, T)) = Const (x, instT T)
70.218 - | inst (Free (x, T)) = Free(x, instT T)
70.219 - | inst (Var (xi, T)) =
70.220 - (case Vartab.lookup env xi of
70.221 - NONE => Var (xi, instT T)
70.222 - | SOME t => t)
70.223 - | inst (b as Bound _) = b
70.224 - | inst (Abs (x, T, t)) = Abs (x, instT T, inst t)
70.225 - | inst (t $ u) = inst t $ inst u;
70.226 - in Envir.beta_norm o inst end;
70.227 -
70.228 -
70.229 -(** management of registrations in theories and proof contexts **)
70.230 -
70.231 -type registration =
70.232 - {prfx: (Binding.T -> Binding.T) * (string * string),
70.233 - (* first component: interpretation name morphism;
70.234 - second component: parameter prefix *)
70.235 - exp: Morphism.morphism,
70.236 - (* maps content to its originating context *)
70.237 - imp: (typ Vartab.table * typ list) * (term Vartab.table * term list),
70.238 - (* inverse of exp *)
70.239 - wits: Element.witness list,
70.240 - (* witnesses of the registration *)
70.241 - eqns: thm Termtab.table,
70.242 - (* theorems (equations) interpreting derived concepts and indexed by lhs *)
70.243 - morph: unit
70.244 - (* interpreting morphism *)
70.245 - }
70.246 -
70.247 -structure Registrations :
70.248 - sig
70.249 - type T
70.250 - val empty: T
70.251 - val join: T * T -> T
70.252 - val dest: theory -> T ->
70.253 - (term list *
70.254 - (((Binding.T -> Binding.T) * (string * string)) *
70.255 - (Morphism.morphism * ((typ Vartab.table * typ list) * (term Vartab.table * term list))) *
70.256 - Element.witness list *
70.257 - thm Termtab.table)) list
70.258 - val test: theory -> T * term list -> bool
70.259 - val lookup: theory ->
70.260 - T * (term list * ((typ Vartab.table * typ list) * (term Vartab.table * term list))) ->
70.261 - (((Binding.T -> Binding.T) * (string * string)) * Element.witness list * thm Termtab.table) option
70.262 - val insert: theory -> term list -> ((Binding.T -> Binding.T) * (string * string)) ->
70.263 - (Morphism.morphism * ((typ Vartab.table * typ list) * (term Vartab.table * term list))) ->
70.264 - T ->
70.265 - T * (term list * (((Binding.T -> Binding.T) * (string * string)) * Element.witness list)) list
70.266 - val add_witness: term list -> Element.witness -> T -> T
70.267 - val add_equation: term list -> thm -> T -> T
70.268 -(*
70.269 - val update_morph: term list -> Morphism.morphism -> T -> T
70.270 - val get_morph: theory -> T ->
70.271 - term list * ((typ Vartab.table * typ list) * (term Vartab.table * term list)) ->
70.272 - Morphism.morphism
70.273 -*)
70.274 - end =
70.275 -struct
70.276 - (* A registration is indexed by parameter instantiation.
70.277 - NB: index is exported whereas content is internalised. *)
70.278 - type T = registration Termtab.table;
70.279 -
70.280 - fun mk_reg prfx exp imp wits eqns morph =
70.281 - {prfx = prfx, exp = exp, imp = imp, wits = wits, eqns = eqns, morph = morph};
70.282 -
70.283 - fun map_reg f reg =
70.284 - let
70.285 - val {prfx, exp, imp, wits, eqns, morph} = reg;
70.286 - val (prfx', exp', imp', wits', eqns', morph') = f (prfx, exp, imp, wits, eqns, morph);
70.287 - in mk_reg prfx' exp' imp' wits' eqns' morph' end;
70.288 -
70.289 - val empty = Termtab.empty;
70.290 -
70.291 - (* term list represented as single term, for simultaneous matching *)
70.292 - fun termify ts =
70.293 - Term.list_comb (Const ("", map fastype_of ts ---> propT), ts);
70.294 - fun untermify t =
70.295 - let fun ut (Const _) ts = ts
70.296 - | ut (s $ t) ts = ut s (t::ts)
70.297 - in ut t [] end;
70.298 -
70.299 - (* joining of registrations:
70.300 - - prefix and morphisms of right theory;
70.301 - - witnesses are equal, no attempt to subsumption testing;
70.302 - - union of equalities, if conflicting (i.e. two eqns with equal lhs)
70.303 - eqn of right theory takes precedence *)
70.304 - fun join (r1, r2) = Termtab.join (fn _ => fn ({eqns = e1, ...}, {prfx = n, exp, imp, wits = w, eqns = e2, morph = m}) =>
70.305 - mk_reg n exp imp w (Termtab.join (fn _ => fn (_, e) => e) (e1, e2)) m) (r1, r2);
70.306 -
70.307 - fun dest_transfer thy regs =
70.308 - Termtab.dest regs |> map (apsnd (map_reg (fn (n, e, i, ws, es, m) =>
70.309 - (n, e, i, map (Element.transfer_witness thy) ws, Termtab.map (transfer thy) es, m))));
70.310 -
70.311 - fun dest thy regs = dest_transfer thy regs |> map (apfst untermify) |>
70.312 - map (apsnd (fn {prfx, exp, imp, wits, eqns, ...} => (prfx, (exp, imp), wits, eqns)));
70.313 -
70.314 - (* registrations that subsume t *)
70.315 - fun subsumers thy t regs =
70.316 - filter (fn (t', _) => Pattern.matches thy (t', t)) (dest_transfer thy regs);
70.317 -
70.318 - (* test if registration that subsumes the query is present *)
70.319 - fun test thy (regs, ts) =
70.320 - not (null (subsumers thy (termify ts) regs));
70.321 -
70.322 - (* look up registration, pick one that subsumes the query *)
70.323 - fun lookup thy (regs, (ts, ((impT, _), (imp, _)))) =
70.324 - let
70.325 - val t = termify ts;
70.326 - val subs = subsumers thy t regs;
70.327 - in
70.328 - (case subs of
70.329 - [] => NONE
70.330 - | ((t', {prfx, exp = exp', imp = ((impT', domT'), (imp', dom')), wits, eqns, morph}) :: _) =>
70.331 - let
70.332 - val (tinst, inst) = Pattern.match thy (t', t) (Vartab.empty, Vartab.empty);
70.333 - val tinst' = domT' |> map (fn (T as TFree (x, _)) =>
70.334 - (x, T |> Morphism.typ exp' |> Envir.typ_subst_TVars tinst
70.335 - |> var_instT_type impT)) |> Symtab.make;
70.336 - val inst' = dom' |> map (fn (t as Free (x, _)) =>
70.337 - (x, t |> Morphism.term exp' |> Envir.subst_vars (tinst, inst)
70.338 - |> var_inst_term (impT, imp))) |> Symtab.make;
70.339 - val inst'_morph = Element.inst_morphism thy (tinst', inst');
70.340 - in SOME (prfx,
70.341 - map (Element.morph_witness inst'_morph) wits,
70.342 - Termtab.map (Morphism.thm inst'_morph) eqns)
70.343 - end)
70.344 - end;
70.345 -
70.346 - (* add registration if not subsumed by ones already present,
70.347 - additionally returns registrations that are strictly subsumed *)
70.348 - fun insert thy ts prfx (exp, imp) regs =
70.349 - let
70.350 - val t = termify ts;
70.351 - val subs = subsumers thy t regs ;
70.352 - in (case subs of
70.353 - [] => let
70.354 - val sups =
70.355 - filter (fn (t', _) => Pattern.matches thy (t, t')) (dest_transfer thy regs);
70.356 - val sups' = map (apfst untermify) sups |> map (fn (ts, {prfx, wits, ...}) => (ts, (prfx, wits)))
70.357 - in (Termtab.update (t, mk_reg prfx exp imp [] Termtab.empty ()) regs, sups') end
70.358 - | _ => (regs, []))
70.359 - end;
70.360 -
70.361 - fun gen_add f ts regs =
70.362 - let
70.363 - val t = termify ts;
70.364 - in
70.365 - Termtab.update (t, map_reg f (the (Termtab.lookup regs t))) regs
70.366 - end;
70.367 -
70.368 - (* add witness theorem to registration,
70.369 - only if instantiation is exact, otherwise exception Option raised *)
70.370 - fun add_witness ts wit regs =
70.371 - gen_add (fn (x, e, i, wits, eqns, m) => (x, e, i, Element.close_witness wit :: wits, eqns, m))
70.372 - ts regs;
70.373 -
70.374 - (* add equation to registration, replaces previous equation with same lhs;
70.375 - only if instantiation is exact, otherwise exception Option raised;
70.376 - exception TERM raised if not a meta equality *)
70.377 - fun add_equation ts thm regs =
70.378 - gen_add (fn (x, e, i, thms, eqns, m) =>
70.379 - (x, e, i, thms, Termtab.update (thm |> prop_of |> Logic.dest_equals |> fst, Thm.close_derivation thm) eqns, m))
70.380 - ts regs;
70.381 -
70.382 -end;
70.383 -
70.384 -
70.385 -(** theory data : locales **)
70.386 -
70.387 -structure LocalesData = TheoryDataFun
70.388 -(
70.389 - type T = NameSpace.T * locale Symtab.table;
70.390 - (* 1st entry: locale namespace,
70.391 - 2nd entry: locales of the theory *)
70.392 -
70.393 - val empty = NameSpace.empty_table;
70.394 - val copy = I;
70.395 - val extend = I;
70.396 -
70.397 - fun join_locales _
70.398 - ({axiom, elems, params, decls = (decls1, decls2), regs, intros, dests}: locale,
70.399 - {elems = elems', decls = (decls1', decls2'), regs = regs', ...}: locale) =
70.400 - {axiom = axiom,
70.401 - elems = merge_lists (eq_snd (op =)) elems elems',
70.402 - params = params,
70.403 - decls =
70.404 - (Library.merge (eq_snd (op =)) (decls1, decls1'),
70.405 - Library.merge (eq_snd (op =)) (decls2, decls2')),
70.406 - regs = merge_alists (op =) regs regs',
70.407 - intros = intros,
70.408 - dests = dests};
70.409 - fun merge _ = NameSpace.join_tables join_locales;
70.410 -);
70.411 -
70.412 -
70.413 -
70.414 -(** context data : registrations **)
70.415 -
70.416 -structure RegistrationsData = GenericDataFun
70.417 -(
70.418 - type T = Registrations.T Symtab.table; (*registrations, indexed by locale name*)
70.419 - val empty = Symtab.empty;
70.420 - val extend = I;
70.421 - fun merge _ = Symtab.join (K Registrations.join);
70.422 -);
70.423 -
70.424 -
70.425 -(** access locales **)
70.426 -
70.427 -val intern = NameSpace.intern o #1 o LocalesData.get;
70.428 -val extern = NameSpace.extern o #1 o LocalesData.get;
70.429 -
70.430 -fun get_locale thy name = Symtab.lookup (#2 (LocalesData.get thy)) name;
70.431 -
70.432 -fun the_locale thy name = case get_locale thy name
70.433 - of SOME loc => loc
70.434 - | NONE => error ("Unknown locale " ^ quote name);
70.435 -
70.436 -fun register_locale bname loc thy =
70.437 - thy |> LocalesData.map (NameSpace.bind (Sign.naming_of thy)
70.438 - (Binding.name bname, loc) #> snd);
70.439 -
70.440 -fun change_locale name f thy =
70.441 - let
70.442 - val {axiom, elems, params, decls, regs, intros, dests} =
70.443 - the_locale thy name;
70.444 - val (axiom', elems', params', decls', regs', intros', dests') =
70.445 - f (axiom, elems, params, decls, regs, intros, dests);
70.446 - in
70.447 - thy
70.448 - |> (LocalesData.map o apsnd) (Symtab.update (name, {axiom = axiom',
70.449 - elems = elems', params = params',
70.450 - decls = decls', regs = regs', intros = intros', dests = dests'}))
70.451 - end;
70.452 -
70.453 -fun print_locales thy =
70.454 - let val (space, locs) = LocalesData.get thy in
70.455 - Pretty.strs ("locales:" :: map #1 (NameSpace.extern_table (space, locs)))
70.456 - |> Pretty.writeln
70.457 - end;
70.458 -
70.459 -
70.460 -(* access registrations *)
70.461 -
70.462 -(* retrieve registration from theory or context *)
70.463 -
70.464 -fun get_registrations ctxt name =
70.465 - case Symtab.lookup (RegistrationsData.get ctxt) name of
70.466 - NONE => []
70.467 - | SOME reg => Registrations.dest (Context.theory_of ctxt) reg;
70.468 -
70.469 -fun get_global_registrations thy = get_registrations (Context.Theory thy);
70.470 -fun get_local_registrations ctxt = get_registrations (Context.Proof ctxt);
70.471 -
70.472 -
70.473 -fun get_registration ctxt imprt (name, ps) =
70.474 - case Symtab.lookup (RegistrationsData.get ctxt) name of
70.475 - NONE => NONE
70.476 - | SOME reg => Registrations.lookup (Context.theory_of ctxt) (reg, (ps, imprt));
70.477 -
70.478 -fun get_global_registration thy = get_registration (Context.Theory thy);
70.479 -fun get_local_registration ctxt = get_registration (Context.Proof ctxt);
70.480 -
70.481 -
70.482 -fun test_registration ctxt (name, ps) =
70.483 - case Symtab.lookup (RegistrationsData.get ctxt) name of
70.484 - NONE => false
70.485 - | SOME reg => Registrations.test (Context.theory_of ctxt) (reg, ps);
70.486 -
70.487 -fun test_global_registration thy = test_registration (Context.Theory thy);
70.488 -fun test_local_registration ctxt = test_registration (Context.Proof ctxt);
70.489 -
70.490 -
70.491 -(* add registration to theory or context, ignored if subsumed *)
70.492 -
70.493 -fun put_registration (name, ps) prfx morphs ctxt =
70.494 - RegistrationsData.map (fn regs =>
70.495 - let
70.496 - val thy = Context.theory_of ctxt;
70.497 - val reg = the_default Registrations.empty (Symtab.lookup regs name);
70.498 - val (reg', sups) = Registrations.insert thy ps prfx morphs reg;
70.499 - val _ = if not (null sups) then warning
70.500 - ("Subsumed interpretation(s) of locale " ^
70.501 - quote (extern thy name) ^
70.502 - "\nwith the following prefix(es):" ^
70.503 - commas_quote (map (fn (_, ((_, (_, s)), _)) => s) sups))
70.504 - else ();
70.505 - in Symtab.update (name, reg') regs end) ctxt;
70.506 -
70.507 -fun put_global_registration id prfx morphs =
70.508 - Context.theory_map (put_registration id prfx morphs);
70.509 -fun put_local_registration id prfx morphs =
70.510 - Context.proof_map (put_registration id prfx morphs);
70.511 -
70.512 -fun put_registration_in_locale name id =
70.513 - change_locale name (fn (axiom, elems, params, decls, regs, intros, dests) =>
70.514 - (axiom, elems, params, decls, regs @ [(id, [])], intros, dests));
70.515 -
70.516 -
70.517 -(* add witness theorem to registration, ignored if registration not present *)
70.518 -
70.519 -fun add_witness (name, ps) thm =
70.520 - RegistrationsData.map (Symtab.map_entry name (Registrations.add_witness ps thm));
70.521 -
70.522 -fun add_global_witness id thm = Context.theory_map (add_witness id thm);
70.523 -fun add_local_witness id thm = Context.proof_map (add_witness id thm);
70.524 -
70.525 -
70.526 -fun add_witness_in_locale name id thm =
70.527 - change_locale name (fn (axiom, elems, params, decls, regs, intros, dests) =>
70.528 - let
70.529 - fun add (id', thms) =
70.530 - if id = id' then (id', thm :: thms) else (id', thms);
70.531 - in (axiom, elems, params, decls, map add regs, intros, dests) end);
70.532 -
70.533 -
70.534 -(* add equation to registration, ignored if registration not present *)
70.535 -
70.536 -fun add_equation (name, ps) thm =
70.537 - RegistrationsData.map (Symtab.map_entry name (Registrations.add_equation ps thm));
70.538 -
70.539 -fun add_global_equation id thm = Context.theory_map (add_equation id thm);
70.540 -fun add_local_equation id thm = Context.proof_map (add_equation id thm);
70.541 -
70.542 -(*
70.543 -(* update morphism of registration, ignored if registration not present *)
70.544 -
70.545 -fun update_morph (name, ps) morph =
70.546 - RegistrationsData.map (Symtab.map_entry name (Registrations.update_morph ps morph));
70.547 -
70.548 -fun update_global_morph id morph = Context.theory_map (update_morph id morph);
70.549 -fun update_local_morph id morph = Context.proof_map (update_morph id morph);
70.550 -*)
70.551 -
70.552 -
70.553 -(* printing of registrations *)
70.554 -
70.555 -fun print_registrations show_wits loc ctxt =
70.556 - let
70.557 - val thy = ProofContext.theory_of ctxt;
70.558 - val prt_term = Pretty.quote o Syntax.pretty_term ctxt;
70.559 - fun prt_term' t = if !show_types
70.560 - then Pretty.block [prt_term t, Pretty.brk 1, Pretty.str "::",
70.561 - Pretty.brk 1, (Pretty.quote o Syntax.pretty_typ ctxt) (type_of t)]
70.562 - else prt_term t;
70.563 - val prt_thm = prt_term o prop_of;
70.564 - fun prt_inst ts =
70.565 - Pretty.enclose "(" ")" (Pretty.breaks (map prt_term' ts));
70.566 - fun prt_prfx ((false, prfx), param_prfx) = [Pretty.str prfx, Pretty.brk 1, Pretty.str "(optional)", Pretty.brk 1, Pretty.str param_prfx]
70.567 - | prt_prfx ((true, prfx), param_prfx) = [Pretty.str prfx, Pretty.brk 1, Pretty.str param_prfx];
70.568 - fun prt_eqns [] = Pretty.str "no equations."
70.569 - | prt_eqns eqns = Pretty.block (Pretty.str "equations:" :: Pretty.brk 1 ::
70.570 - Pretty.breaks (map prt_thm eqns));
70.571 - fun prt_core ts eqns =
70.572 - [prt_inst ts, Pretty.fbrk, prt_eqns (Termtab.dest eqns |> map snd)];
70.573 - fun prt_witns [] = Pretty.str "no witnesses."
70.574 - | prt_witns witns = Pretty.block (Pretty.str "witnesses:" :: Pretty.brk 1 ::
70.575 - Pretty.breaks (map (Element.pretty_witness ctxt) witns))
70.576 - fun prt_reg (ts, (_, _, witns, eqns)) =
70.577 - if show_wits
70.578 - then Pretty.block (prt_core ts eqns @ [Pretty.fbrk, prt_witns witns])
70.579 - else Pretty.block (prt_core ts eqns)
70.580 -
70.581 - val loc_int = intern thy loc;
70.582 - val regs = RegistrationsData.get (Context.Proof ctxt);
70.583 - val loc_regs = Symtab.lookup regs loc_int;
70.584 - in
70.585 - (case loc_regs of
70.586 - NONE => Pretty.str ("no interpretations")
70.587 - | SOME r => let
70.588 - val r' = Registrations.dest thy r;
70.589 - val r'' = Library.sort_wrt (fn (_, ((_, (_, prfx)), _, _, _)) => prfx) r';
70.590 - in Pretty.big_list ("interpretations:") (map prt_reg r'') end)
70.591 - |> Pretty.writeln
70.592 - end;
70.593 -
70.594 -
70.595 -(* diagnostics *)
70.596 -
70.597 -fun err_in_locale ctxt msg ids =
70.598 - let
70.599 - val thy = ProofContext.theory_of ctxt;
70.600 - fun prt_id (name, parms) =
70.601 - [Pretty.block (Pretty.breaks (map Pretty.str (extern thy name :: parms)))];
70.602 - val prt_ids = flat (separate [Pretty.str " +", Pretty.brk 1] (map prt_id ids));
70.603 - val err_msg =
70.604 - if forall (fn (s, _) => s = "") ids then msg
70.605 - else msg ^ "\n" ^ Pretty.string_of (Pretty.block
70.606 - (Pretty.str "The error(s) above occurred in locale:" :: Pretty.brk 1 :: prt_ids));
70.607 - in error err_msg end;
70.608 -
70.609 -fun err_in_locale' ctxt msg ids' = err_in_locale ctxt msg (map fst ids');
70.610 -
70.611 -
70.612 -fun pretty_ren NONE = Pretty.str "_"
70.613 - | pretty_ren (SOME (x, NONE)) = Pretty.str x
70.614 - | pretty_ren (SOME (x, SOME syn)) =
70.615 - Pretty.block [Pretty.str x, Pretty.brk 1, Syntax.pretty_mixfix syn];
70.616 -
70.617 -fun pretty_expr thy (Locale name) = Pretty.str (extern thy name)
70.618 - | pretty_expr thy (Rename (expr, xs)) =
70.619 - Pretty.block [pretty_expr thy expr, Pretty.brk 1, Pretty.block (map pretty_ren xs |> Pretty.breaks)]
70.620 - | pretty_expr thy (Merge es) =
70.621 - Pretty.separate "+" (map (pretty_expr thy) es) |> Pretty.block;
70.622 -
70.623 -fun err_in_expr _ msg (Merge []) = error msg
70.624 - | err_in_expr ctxt msg expr =
70.625 - error (msg ^ "\n" ^ Pretty.string_of (Pretty.block
70.626 - [Pretty.str "The error(s) above occured in locale expression:", Pretty.brk 1,
70.627 - pretty_expr (ProofContext.theory_of ctxt) expr]));
70.628 -
70.629 -
70.630 -(** structured contexts: rename + merge + implicit type instantiation **)
70.631 -
70.632 -(* parameter types *)
70.633 -
70.634 -fun frozen_tvars ctxt Ts =
70.635 - #1 (Variable.importT_inst (map Logic.mk_type Ts) ctxt)
70.636 - |> map (fn ((xi, S), T) => (xi, (S, T)));
70.637 -
70.638 -fun unify_frozen ctxt maxidx Ts Us =
70.639 - let
70.640 - fun paramify NONE i = (NONE, i)
70.641 - | paramify (SOME T) i = apfst SOME (TypeInfer.paramify_dummies T i);
70.642 -
70.643 - val (Ts', maxidx') = fold_map paramify Ts maxidx;
70.644 - val (Us', maxidx'') = fold_map paramify Us maxidx';
70.645 - val thy = ProofContext.theory_of ctxt;
70.646 -
70.647 - fun unify (SOME T, SOME U) env = (Sign.typ_unify thy (U, T) env
70.648 - handle Type.TUNIFY => raise TYPE ("unify_frozen: failed to unify types", [U, T], []))
70.649 - | unify _ env = env;
70.650 - val (unifier, _) = fold unify (Ts' ~~ Us') (Vartab.empty, maxidx'');
70.651 - val Vs = map (Option.map (Envir.norm_type unifier)) Us';
70.652 - val unifier' = fold Vartab.update_new (frozen_tvars ctxt (map_filter I Vs)) unifier;
70.653 - in map (Option.map (Envir.norm_type unifier')) Vs end;
70.654 -
70.655 -fun params_of elemss =
70.656 - distinct (eq_fst (op = : string * string -> bool)) (maps (snd o fst) elemss);
70.657 -
70.658 -fun params_of' elemss =
70.659 - distinct (eq_fst (op = : string * string -> bool)) (maps (snd o fst o fst) elemss);
70.660 -
70.661 -fun param_prefix locale_name params = (NameSpace.base locale_name ^ "_locale", space_implode "_" params);
70.662 -
70.663 -
70.664 -(* CB: param_types has the following type:
70.665 - ('a * 'b option) list -> ('a * 'b) list *)
70.666 -fun param_types ps = map_filter (fn (_, NONE) => NONE | (x, SOME T) => SOME (x, T)) ps;
70.667 -
70.668 -
70.669 -fun merge_syntax ctxt ids ss = Symtab.merge (op = : mixfix * mixfix -> bool) ss
70.670 - handle Symtab.DUP x => err_in_locale ctxt
70.671 - ("Conflicting syntax for parameter: " ^ quote x) (map fst ids);
70.672 -
70.673 -
70.674 -(* Distinction of assumed vs. derived identifiers.
70.675 - The former may have axioms relating assumptions of the context to
70.676 - assumptions of the specification fragment (for locales with
70.677 - predicates). The latter have witnesses relating assumptions of the
70.678 - specification fragment to assumptions of other (assumed) specification
70.679 - fragments. *)
70.680 -
70.681 -datatype 'a mode = Assumed of 'a | Derived of 'a;
70.682 -
70.683 -fun map_mode f (Assumed x) = Assumed (f x)
70.684 - | map_mode f (Derived x) = Derived (f x);
70.685 -
70.686 -
70.687 -(* flatten expressions *)
70.688 -
70.689 -local
70.690 -
70.691 -fun unify_parms ctxt fixed_parms raw_parmss =
70.692 - let
70.693 - val thy = ProofContext.theory_of ctxt;
70.694 - val maxidx = length raw_parmss;
70.695 - val idx_parmss = (0 upto maxidx - 1) ~~ raw_parmss;
70.696 -
70.697 - fun varify i = Term.map_type_tfree (fn (a, S) => TVar ((a, i), S));
70.698 - fun varify_parms (i, ps) = map (apsnd (varify i)) (param_types ps);
70.699 - val parms = fixed_parms @ maps varify_parms idx_parmss;
70.700 -
70.701 - fun unify T U envir = Sign.typ_unify thy (U, T) envir
70.702 - handle Type.TUNIFY =>
70.703 - let
70.704 - val T' = Envir.norm_type (fst envir) T;
70.705 - val U' = Envir.norm_type (fst envir) U;
70.706 - val prt = Syntax.string_of_typ ctxt;
70.707 - in
70.708 - raise TYPE ("unify_parms: failed to unify types " ^
70.709 - prt U' ^ " and " ^ prt T', [U', T'], [])
70.710 - end;
70.711 - fun unify_list (T :: Us) = fold (unify T) Us
70.712 - | unify_list [] = I;
70.713 - val (unifier, _) = fold unify_list (map #2 (Symtab.dest (Symtab.make_list parms)))
70.714 - (Vartab.empty, maxidx);
70.715 -
70.716 - val parms' = map (apsnd (Envir.norm_type unifier)) (distinct (eq_fst (op =)) parms);
70.717 - val unifier' = fold Vartab.update_new (frozen_tvars ctxt (map #2 parms')) unifier;
70.718 -
70.719 - fun inst_parms (i, ps) =
70.720 - List.foldr OldTerm.add_typ_tfrees [] (map_filter snd ps)
70.721 - |> map_filter (fn (a, S) =>
70.722 - let val T = Envir.norm_type unifier' (TVar ((a, i), S))
70.723 - in if T = TFree (a, S) then NONE else SOME (a, T) end)
70.724 - |> Symtab.make;
70.725 - in map inst_parms idx_parmss end;
70.726 -
70.727 -in
70.728 -
70.729 -fun unify_elemss _ _ [] = []
70.730 - | unify_elemss _ [] [elems] = [elems]
70.731 - | unify_elemss ctxt fixed_parms elemss =
70.732 - let
70.733 - val thy = ProofContext.theory_of ctxt;
70.734 - val phis = unify_parms ctxt fixed_parms (map (snd o fst o fst) elemss)
70.735 - |> map (Element.instT_morphism thy);
70.736 - fun inst ((((name, ps), mode), elems), phi) =
70.737 - (((name, map (apsnd (Option.map (Morphism.typ phi))) ps),
70.738 - map_mode (map (Element.morph_witness phi)) mode),
70.739 - map (Element.morph_ctxt phi) elems);
70.740 - in map inst (elemss ~~ phis) end;
70.741 -
70.742 -
70.743 -fun renaming xs parms = zip_options parms xs
70.744 - handle Library.UnequalLengths =>
70.745 - error ("Too many arguments in renaming: " ^
70.746 - commas (map (fn NONE => "_" | SOME x => quote (fst x)) xs));
70.747 -
70.748 -
70.749 -(* params_of_expr:
70.750 - Compute parameters (with types and syntax) of locale expression.
70.751 -*)
70.752 -
70.753 -fun params_of_expr ctxt fixed_params expr (prev_parms, prev_types, prev_syn) =
70.754 - let
70.755 - val thy = ProofContext.theory_of ctxt;
70.756 -
70.757 - fun merge_tenvs fixed tenv1 tenv2 =
70.758 - let
70.759 - val [env1, env2] = unify_parms ctxt fixed
70.760 - [tenv1 |> Symtab.dest |> map (apsnd SOME),
70.761 - tenv2 |> Symtab.dest |> map (apsnd SOME)]
70.762 - in
70.763 - Symtab.merge (op =) (Symtab.map (Element.instT_type env1) tenv1,
70.764 - Symtab.map (Element.instT_type env2) tenv2)
70.765 - end;
70.766 -
70.767 - fun merge_syn expr syn1 syn2 =
70.768 - Symtab.merge (op = : mixfix * mixfix -> bool) (syn1, syn2)
70.769 - handle Symtab.DUP x => err_in_expr ctxt
70.770 - ("Conflicting syntax for parameter: " ^ quote x) expr;
70.771 -
70.772 - fun params_of (expr as Locale name) =
70.773 - let
70.774 - val {params, ...} = the_locale thy name;
70.775 - in (map (fst o fst) params, params |> map fst |> Symtab.make,
70.776 - params |> map (apfst fst) |> Symtab.make) end
70.777 - | params_of (expr as Rename (e, xs)) =
70.778 - let
70.779 - val (parms', types', syn') = params_of e;
70.780 - val ren = renaming xs parms';
70.781 - (* renaming may reduce number of parameters *)
70.782 - val new_parms = map (Element.rename ren) parms' |> distinct (op =);
70.783 - val ren_syn = syn' |> Symtab.dest |> map (Element.rename_var_name ren);
70.784 - val new_syn = fold (Symtab.insert (op =)) ren_syn Symtab.empty
70.785 - handle Symtab.DUP x =>
70.786 - err_in_expr ctxt ("Conflicting syntax for parameter: " ^ quote x) expr;
70.787 - val syn_types = map (apsnd (fn mx =>
70.788 - SOME (Type.freeze_type (#1 (TypeInfer.paramify_dummies (Syntax.mixfixT mx) 0)))))
70.789 - (Symtab.dest new_syn);
70.790 - val ren_types = types' |> Symtab.dest |> map (apfst (Element.rename ren));
70.791 - val (env :: _) = unify_parms ctxt []
70.792 - ((ren_types |> map (apsnd SOME)) :: map single syn_types);
70.793 - val new_types = fold (Symtab.insert (op =))
70.794 - (map (apsnd (Element.instT_type env)) ren_types) Symtab.empty;
70.795 - in (new_parms, new_types, new_syn) end
70.796 - | params_of (Merge es) =
70.797 - fold (fn e => fn (parms, types, syn) =>
70.798 - let
70.799 - val (parms', types', syn') = params_of e
70.800 - in
70.801 - (merge_lists (op =) parms parms', merge_tenvs [] types types',
70.802 - merge_syn e syn syn')
70.803 - end)
70.804 - es ([], Symtab.empty, Symtab.empty)
70.805 -
70.806 - val (parms, types, syn) = params_of expr;
70.807 - in
70.808 - (merge_lists (op =) prev_parms parms, merge_tenvs fixed_params prev_types types,
70.809 - merge_syn expr prev_syn syn)
70.810 - end;
70.811 -
70.812 -fun make_params_ids params = [(("", params), ([], Assumed []))];
70.813 -fun make_raw_params_elemss (params, tenv, syn) =
70.814 - [((("", map (fn p => (p, Symtab.lookup tenv p)) params), Assumed []),
70.815 - Int [Fixes (map (fn p =>
70.816 - (Binding.name p, Symtab.lookup tenv p, Symtab.lookup syn p |> the)) params)])];
70.817 -
70.818 -
70.819 -(* flatten_expr:
70.820 - Extend list of identifiers by those new in locale expression expr.
70.821 - Compute corresponding list of lists of locale elements (one entry per
70.822 - identifier).
70.823 -
70.824 - Identifiers represent locale fragments and are in an extended form:
70.825 - ((name, ps), (ax_ps, axs))
70.826 - (name, ps) is the locale name with all its parameters.
70.827 - (ax_ps, axs) is the locale axioms with its parameters;
70.828 - axs are always taken from the top level of the locale hierarchy,
70.829 - hence axioms may contain additional parameters from later fragments:
70.830 - ps subset of ax_ps. axs is either singleton or empty.
70.831 -
70.832 - Elements are enriched by identifier-like information:
70.833 - (((name, ax_ps), axs), elems)
70.834 - The parameters in ax_ps are the axiom parameters, but enriched by type
70.835 - info: now each entry is a pair of string and typ option. Axioms are
70.836 - type-instantiated.
70.837 -
70.838 -*)
70.839 -
70.840 -fun flatten_expr ctxt ((prev_idents, prev_syntax), expr) =
70.841 - let
70.842 - val thy = ProofContext.theory_of ctxt;
70.843 -
70.844 - fun rename_parms top ren ((name, ps), (parms, mode)) =
70.845 - ((name, map (Element.rename ren) ps),
70.846 - if top
70.847 - then (map (Element.rename ren) parms,
70.848 - map_mode (map (Element.morph_witness (Element.rename_morphism ren))) mode)
70.849 - else (parms, mode));
70.850 -
70.851 - (* add (name, pTs) and its registrations, recursively; adjust hyps of witnesses *)
70.852 -
70.853 - fun add_with_regs ((name, pTs), mode) (wits, ids, visited) =
70.854 - if member (fn (a, (b, _)) => a = b) visited (name, map #1 pTs)
70.855 - then (wits, ids, visited)
70.856 - else
70.857 - let
70.858 - val {params, regs, ...} = the_locale thy name;
70.859 - val pTs' = map #1 params;
70.860 - val ren = map #1 pTs' ~~ map (fn (x, _) => (x, NONE)) pTs;
70.861 - (* dummy syntax, since required by rename *)
70.862 - val pTs'' = map (fn ((p, _), (_, T)) => (p, T)) (pTs ~~ pTs');
70.863 - val [env] = unify_parms ctxt pTs [map (apsnd SOME) pTs''];
70.864 - (* propagate parameter types, to keep them consistent *)
70.865 - val regs' = map (fn ((name, ps), wits) =>
70.866 - ((name, map (Element.rename ren) ps),
70.867 - map (Element.transfer_witness thy) wits)) regs;
70.868 - val new_regs = regs';
70.869 - val new_ids = map fst new_regs;
70.870 - val new_idTs =
70.871 - map (apsnd (map (fn p => (p, (the o AList.lookup (op =) pTs) p)))) new_ids;
70.872 -
70.873 - val new_wits = new_regs |> map (#2 #> map
70.874 - (Element.morph_witness
70.875 - (Element.instT_morphism thy env $>
70.876 - Element.rename_morphism ren $>
70.877 - Element.satisfy_morphism wits)
70.878 - #> Element.close_witness));
70.879 - val new_ids' = map (fn (id, wits) =>
70.880 - (id, ([], Derived wits))) (new_ids ~~ new_wits);
70.881 - val new_idTs' = map (fn ((n, pTs), (_, ([], mode))) =>
70.882 - ((n, pTs), mode)) (new_idTs ~~ new_ids');
70.883 - val new_id = ((name, map #1 pTs), ([], mode));
70.884 - val (wits', ids', visited') = fold add_with_regs new_idTs'
70.885 - (wits @ flat new_wits, ids, visited @ [new_id]);
70.886 - in
70.887 - (wits', ids' @ [new_id], visited')
70.888 - end;
70.889 -
70.890 - (* distribute top-level axioms over assumed ids *)
70.891 -
70.892 - fun axiomify all_ps ((name, parms), (_, Assumed _)) axioms =
70.893 - let
70.894 - val {elems, ...} = the_locale thy name;
70.895 - val ts = maps
70.896 - (fn (Assumes asms, _) => maps (map #1 o #2) asms
70.897 - | _ => [])
70.898 - elems;
70.899 - val (axs1, axs2) = chop (length ts) axioms;
70.900 - in (((name, parms), (all_ps, Assumed axs1)), axs2) end
70.901 - | axiomify all_ps (id, (_, Derived ths)) axioms =
70.902 - ((id, (all_ps, Derived ths)), axioms);
70.903 -
70.904 - (* identifiers of an expression *)
70.905 -
70.906 - fun identify top (Locale name) =
70.907 - (* CB: ids_ax is a list of tuples of the form ((name, ps), axs),
70.908 - where name is a locale name, ps a list of parameter names and axs
70.909 - a list of axioms relating to the identifier, axs is empty unless
70.910 - identify at top level (top = true);
70.911 - parms is accumulated list of parameters *)
70.912 - let
70.913 - val {axiom, params, ...} = the_locale thy name;
70.914 - val ps = map (#1 o #1) params;
70.915 - val (_, ids'', _) = add_with_regs ((name, map #1 params), Assumed []) ([], [], []);
70.916 - val ids_ax = if top then fst (fold_map (axiomify ps) ids'' axiom) else ids'';
70.917 - in (ids_ax, ps) end
70.918 - | identify top (Rename (e, xs)) =
70.919 - let
70.920 - val (ids', parms') = identify top e;
70.921 - val ren = renaming xs parms'
70.922 - handle ERROR msg => err_in_locale' ctxt msg ids';
70.923 -
70.924 - val ids'' = distinct (eq_fst (op =)) (map (rename_parms top ren) ids');
70.925 - val parms'' = distinct (op =) (maps (#2 o #1) ids'');
70.926 - in (ids'', parms'') end
70.927 - | identify top (Merge es) =
70.928 - fold (fn e => fn (ids, parms) =>
70.929 - let
70.930 - val (ids', parms') = identify top e
70.931 - in
70.932 - (merge_alists (op =) ids ids', merge_lists (op =) parms parms')
70.933 - end)
70.934 - es ([], []);
70.935 -
70.936 - fun inst_wit all_params (t, th) = let
70.937 - val {hyps, prop, ...} = Thm.rep_thm th;
70.938 - val ps = map (apsnd SOME) (fold Term.add_frees (prop :: hyps) []);
70.939 - val [env] = unify_parms ctxt all_params [ps];
70.940 - val t' = Element.instT_term env t;
70.941 - val th' = Element.instT_thm thy env th;
70.942 - in (t', th') end;
70.943 -
70.944 - fun eval all_params tenv syn ((name, params), (locale_params, mode)) =
70.945 - let
70.946 - val {params = ps_mx, elems = elems_stamped, ...} = the_locale thy name;
70.947 - val elems = map fst elems_stamped;
70.948 - val ps = map fst ps_mx;
70.949 - fun lookup_syn x = (case Symtab.lookup syn x of SOME Structure => NONE | opt => opt);
70.950 - val locale_params' = map (fn p => (p, Symtab.lookup tenv p |> the)) locale_params;
70.951 - val mode' = map_mode (map (Element.map_witness (inst_wit all_params))) mode;
70.952 - val ren = map fst ps ~~ map (fn p => (p, lookup_syn p)) params;
70.953 - val [env] = unify_parms ctxt all_params [map (apfst (Element.rename ren) o apsnd SOME) ps];
70.954 - val (lprfx, pprfx) = param_prefix name params;
70.955 - val add_prefices = pprfx <> "" ? Binding.add_prefix false pprfx
70.956 - #> Binding.add_prefix false lprfx;
70.957 - val elem_morphism =
70.958 - Element.rename_morphism ren $>
70.959 - Morphism.binding_morphism add_prefices $>
70.960 - Element.instT_morphism thy env;
70.961 - val elems' = map (Element.morph_ctxt elem_morphism) elems;
70.962 - in (((name, map (apsnd SOME) locale_params'), mode'), elems') end;
70.963 -
70.964 - (* parameters, their types and syntax *)
70.965 - val (all_params', tenv, syn) = params_of_expr ctxt [] expr ([], Symtab.empty, Symtab.empty);
70.966 - val all_params = map (fn p => (p, Symtab.lookup tenv p |> the)) all_params';
70.967 - (* compute identifiers and syntax, merge with previous ones *)
70.968 - val (ids, _) = identify true expr;
70.969 - val idents = subtract (eq_fst (op =)) prev_idents ids;
70.970 - val syntax = merge_syntax ctxt ids (syn, prev_syntax);
70.971 - (* type-instantiate elements *)
70.972 - val final_elemss = map (eval all_params tenv syntax) idents;
70.973 - in ((prev_idents @ idents, syntax), final_elemss) end;
70.974 -
70.975 -end;
70.976 -
70.977 -
70.978 -(* activate elements *)
70.979 -
70.980 -local
70.981 -
70.982 -fun axioms_export axs _ As =
70.983 - (Element.satisfy_thm axs #> Drule.implies_intr_list (Library.drop (length axs, As)), fn t => t);
70.984 -
70.985 -
70.986 -(* NB: derived ids contain only facts at this stage *)
70.987 -
70.988 -fun activate_elem _ _ (Fixes fixes) (ctxt, mode) =
70.989 - ([], (ctxt |> ProofContext.add_fixes_i fixes |> snd, mode))
70.990 - | activate_elem _ _ (Constrains _) (ctxt, mode) =
70.991 - ([], (ctxt, mode))
70.992 - | activate_elem ax_in_ctxt _ (Assumes asms) (ctxt, Assumed axs) =
70.993 - let
70.994 - val asms' = Attrib.map_specs (Attrib.attribute_i (ProofContext.theory_of ctxt)) asms;
70.995 - val ts = maps (map #1 o #2) asms';
70.996 - val (ps, qs) = chop (length ts) axs;
70.997 - val (_, ctxt') =
70.998 - ctxt |> fold Variable.auto_fixes ts
70.999 - |> ProofContext.add_assms_i (axioms_export (if ax_in_ctxt then ps else [])) asms';
70.1000 - in ([], (ctxt', Assumed qs)) end
70.1001 - | activate_elem _ _ (Assumes asms) (ctxt, Derived ths) =
70.1002 - ([], (ctxt, Derived ths))
70.1003 - | activate_elem _ _ (Defines defs) (ctxt, Assumed axs) =
70.1004 - let
70.1005 - val defs' = Attrib.map_specs (Attrib.attribute_i (ProofContext.theory_of ctxt)) defs;
70.1006 - val asms = defs' |> map (fn ((name, atts), (t, ps)) =>
70.1007 - let val ((c, _), t') = LocalDefs.cert_def ctxt t
70.1008 - in (t', ((Binding.map_base (Thm.def_name_optional c) name, atts), [(t', ps)])) end);
70.1009 - val (_, ctxt') =
70.1010 - ctxt |> fold (Variable.auto_fixes o #1) asms
70.1011 - |> ProofContext.add_assms_i LocalDefs.def_export (map #2 asms);
70.1012 - in ([], (ctxt', Assumed axs)) end
70.1013 - | activate_elem _ _ (Defines defs) (ctxt, Derived ths) =
70.1014 - ([], (ctxt, Derived ths))
70.1015 - | activate_elem _ is_ext (Notes (kind, facts)) (ctxt, mode) =
70.1016 - let
70.1017 - val facts' = Attrib.map_facts (Attrib.attribute_i (ProofContext.theory_of ctxt)) facts;
70.1018 - val (res, ctxt') = ctxt |> local_note_qualified kind facts';
70.1019 - in (if is_ext then (map (#1 o #1) facts' ~~ map #2 res) else [], (ctxt', mode)) end;
70.1020 -
70.1021 -fun activate_elems ax_in_ctxt (((name, ps), mode), elems) ctxt =
70.1022 - let
70.1023 - val thy = ProofContext.theory_of ctxt;
70.1024 - val (res, (ctxt', _)) = fold_map (activate_elem ax_in_ctxt (name = ""))
70.1025 - elems (ProofContext.qualified_names ctxt, mode)
70.1026 - handle ERROR msg => err_in_locale ctxt msg [(name, map fst ps)];
70.1027 - val ctxt'' = if name = "" then ctxt'
70.1028 - else let
70.1029 - val ps' = map (fn (n, SOME T) => Free (n, T)) ps;
70.1030 - in if test_local_registration ctxt' (name, ps') then ctxt'
70.1031 - else let
70.1032 - val ctxt'' = put_local_registration (name, ps') (I, (NameSpace.base name, ""))
70.1033 - (Morphism.identity, ((Vartab.empty, []), (Vartab.empty, []) )) ctxt'
70.1034 - in case mode of
70.1035 - Assumed axs =>
70.1036 - fold (add_local_witness (name, ps') o
70.1037 - Element.assume_witness thy o Element.witness_prop) axs ctxt''
70.1038 - | Derived ths =>
70.1039 - fold (add_local_witness (name, ps')) ths ctxt''
70.1040 - end
70.1041 - end
70.1042 - in (ProofContext.restore_naming ctxt ctxt'', res) end;
70.1043 -
70.1044 -fun activate_elemss ax_in_ctxt prep_facts =
70.1045 - fold_map (fn (((name, ps), mode), raw_elems) => fn ctxt =>
70.1046 - let
70.1047 - val elems = map (prep_facts ctxt) raw_elems;
70.1048 - val (ctxt', res) = apsnd flat
70.1049 - (activate_elems ax_in_ctxt (((name, ps), mode), elems) ctxt);
70.1050 - val elems' = elems |> map (Element.map_ctxt_attrib Args.closure);
70.1051 - in (((((name, ps), mode), elems'), res), ctxt') end);
70.1052 -
70.1053 -in
70.1054 -
70.1055 -(* CB: activate_facts prep_facts elemss ctxt,
70.1056 - where elemss is a list of pairs consisting of identifiers and
70.1057 - context elements, extends ctxt by the context elements yielding
70.1058 - ctxt' and returns ((elemss', facts), ctxt').
70.1059 - Identifiers in the argument are of the form ((name, ps), axs) and
70.1060 - assumptions use the axioms in the identifiers to set up exporters
70.1061 - in ctxt'. elemss' does not contain identifiers and is obtained
70.1062 - from elemss and the intermediate context with prep_facts.
70.1063 - If read_facts or cert_facts is used for prep_facts, these also remove
70.1064 - the internal/external markers from elemss. *)
70.1065 -
70.1066 -fun activate_facts ax_in_ctxt prep_facts args =
70.1067 - activate_elemss ax_in_ctxt prep_facts args
70.1068 - #>> (apsnd flat o split_list);
70.1069 -
70.1070 -end;
70.1071 -
70.1072 -
70.1073 -
70.1074 -(** prepare locale elements **)
70.1075 -
70.1076 -(* expressions *)
70.1077 -
70.1078 -fun intern_expr thy (Locale xname) = Locale (intern thy xname)
70.1079 - | intern_expr thy (Merge exprs) = Merge (map (intern_expr thy) exprs)
70.1080 - | intern_expr thy (Rename (expr, xs)) = Rename (intern_expr thy expr, xs);
70.1081 -
70.1082 -
70.1083 -(* propositions and bindings *)
70.1084 -
70.1085 -(* flatten (ctxt, prep_expr) ((ids, syn), expr)
70.1086 - normalises expr (which is either a locale
70.1087 - expression or a single context element) wrt.
70.1088 - to the list ids of already accumulated identifiers.
70.1089 - It returns ((ids', syn'), elemss) where ids' is an extension of ids
70.1090 - with identifiers generated for expr, and elemss is the list of
70.1091 - context elements generated from expr.
70.1092 - syn and syn' are symtabs mapping parameter names to their syntax. syn'
70.1093 - is an extension of syn.
70.1094 - For details, see flatten_expr.
70.1095 -
70.1096 - Additionally, for a locale expression, the elems are grouped into a single
70.1097 - Int; individual context elements are marked Ext. In this case, the
70.1098 - identifier-like information of the element is as follows:
70.1099 - - for Fixes: (("", ps), []) where the ps have type info NONE
70.1100 - - for other elements: (("", []), []).
70.1101 - The implementation of activate_facts relies on identifier names being
70.1102 - empty strings for external elements.
70.1103 -*)
70.1104 -
70.1105 -fun flatten (ctxt, _) ((ids, syn), Elem (Fixes fixes)) = let
70.1106 - val ids' = ids @ [(("", map (Binding.base_name o #1) fixes), ([], Assumed []))]
70.1107 - in
70.1108 - ((ids',
70.1109 - merge_syntax ctxt ids'
70.1110 - (syn, Symtab.make (map (fn fx => (Binding.base_name (#1 fx), #3 fx)) fixes))
70.1111 - handle Symtab.DUP x => err_in_locale ctxt
70.1112 - ("Conflicting syntax for parameter: " ^ quote x)
70.1113 - (map #1 ids')),
70.1114 - [((("", map (rpair NONE o Binding.base_name o #1) fixes), Assumed []), Ext (Fixes fixes))])
70.1115 - end
70.1116 - | flatten _ ((ids, syn), Elem elem) =
70.1117 - ((ids @ [(("", []), ([], Assumed []))], syn), [((("", []), Assumed []), Ext elem)])
70.1118 - | flatten (ctxt, prep_expr) ((ids, syn), Expr expr) =
70.1119 - apsnd (map (apsnd Int)) (flatten_expr ctxt ((ids, syn), prep_expr expr));
70.1120 -
70.1121 -local
70.1122 -
70.1123 -local
70.1124 -
70.1125 -fun declare_int_elem (Fixes fixes) ctxt =
70.1126 - ([], ctxt |> ProofContext.add_fixes_i (map (fn (x, T, mx) =>
70.1127 - (x, Option.map (Term.map_type_tfree (TypeInfer.param 0)) T, mx)) fixes) |> snd)
70.1128 - | declare_int_elem _ ctxt = ([], ctxt);
70.1129 -
70.1130 -fun declare_ext_elem prep_vars (Fixes fixes) ctxt =
70.1131 - let val (vars, _) = prep_vars fixes ctxt
70.1132 - in ([], ctxt |> ProofContext.add_fixes_i vars |> snd) end
70.1133 - | declare_ext_elem prep_vars (Constrains csts) ctxt =
70.1134 - let val (_, ctxt') = prep_vars (map (fn (x, T) => (Binding.name x, SOME T, NoSyn)) csts) ctxt
70.1135 - in ([], ctxt') end
70.1136 - | declare_ext_elem _ (Assumes asms) ctxt = (map #2 asms, ctxt)
70.1137 - | declare_ext_elem _ (Defines defs) ctxt = (map (fn (_, (t, ps)) => [(t, ps)]) defs, ctxt)
70.1138 - | declare_ext_elem _ (Notes _) ctxt = ([], ctxt);
70.1139 -
70.1140 -fun declare_elems prep_vars (((name, ps), Assumed _), elems) ctxt = ((case elems
70.1141 - of Int es => fold_map declare_int_elem es ctxt
70.1142 - | Ext e => declare_ext_elem prep_vars e ctxt |>> single)
70.1143 - handle ERROR msg => err_in_locale ctxt msg [(name, map fst ps)])
70.1144 - | declare_elems _ ((_, Derived _), elems) ctxt = ([], ctxt);
70.1145 -
70.1146 -in
70.1147 -
70.1148 -fun declare_elemss prep_vars fixed_params raw_elemss ctxt =
70.1149 - let
70.1150 - (* CB: fix of type bug of goal in target with context elements.
70.1151 - Parameters new in context elements must receive types that are
70.1152 - distinct from types of parameters in target (fixed_params). *)
70.1153 - val ctxt_with_fixed =
70.1154 - fold Variable.declare_term (map Free fixed_params) ctxt;
70.1155 - val int_elemss =
70.1156 - raw_elemss
70.1157 - |> map_filter (fn (id, Int es) => SOME (id, es) | _ => NONE)
70.1158 - |> unify_elemss ctxt_with_fixed fixed_params;
70.1159 - val (raw_elemss', _) =
70.1160 - fold_map (curry (fn ((id, Int _), (_, es) :: elemss) => ((id, Int es), elemss) | x => x))
70.1161 - raw_elemss int_elemss;
70.1162 - in fold_map (declare_elems prep_vars) raw_elemss' ctxt end;
70.1163 -
70.1164 -end;
70.1165 -
70.1166 -local
70.1167 -
70.1168 -val norm_term = Envir.beta_norm oo Term.subst_atomic;
70.1169 -
70.1170 -fun abstract_thm thy eq =
70.1171 - Thm.assume (Thm.cterm_of thy eq) |> Drule.gen_all |> Drule.abs_def;
70.1172 -
70.1173 -fun bind_def ctxt (name, ps) eq (xs, env, ths) =
70.1174 - let
70.1175 - val ((y, T), b) = LocalDefs.abs_def eq;
70.1176 - val b' = norm_term env b;
70.1177 - val th = abstract_thm (ProofContext.theory_of ctxt) eq;
70.1178 - fun err msg = err_in_locale ctxt (msg ^ ": " ^ quote y) [(name, map fst ps)];
70.1179 - in
70.1180 - exists (fn (x, _) => x = y) xs andalso
70.1181 - err "Attempt to define previously specified variable";
70.1182 - exists (fn (Free (y', _), _) => y = y' | _ => false) env andalso
70.1183 - err "Attempt to redefine variable";
70.1184 - (Term.add_frees b' xs, (Free (y, T), b') :: env, th :: ths)
70.1185 - end;
70.1186 -
70.1187 -
70.1188 -(* CB: for finish_elems (Int and Ext),
70.1189 - extracts specification, only of assumed elements *)
70.1190 -
70.1191 -fun eval_text _ _ _ (Fixes _) text = text
70.1192 - | eval_text _ _ _ (Constrains _) text = text
70.1193 - | eval_text _ (_, Assumed _) is_ext (Assumes asms)
70.1194 - (((exts, exts'), (ints, ints')), (xs, env, defs)) =
70.1195 - let
70.1196 - val ts = maps (map #1 o #2) asms;
70.1197 - val ts' = map (norm_term env) ts;
70.1198 - val spec' =
70.1199 - if is_ext then ((exts @ ts, exts' @ ts'), (ints, ints'))
70.1200 - else ((exts, exts'), (ints @ ts, ints' @ ts'));
70.1201 - in (spec', (fold Term.add_frees ts' xs, env, defs)) end
70.1202 - | eval_text _ (_, Derived _) _ (Assumes _) text = text
70.1203 - | eval_text ctxt (id, Assumed _) _ (Defines defs) (spec, binds) =
70.1204 - (spec, fold (bind_def ctxt id o #1 o #2) defs binds)
70.1205 - | eval_text _ (_, Derived _) _ (Defines _) text = text
70.1206 - | eval_text _ _ _ (Notes _) text = text;
70.1207 -
70.1208 -
70.1209 -(* for finish_elems (Int),
70.1210 - remove redundant elements of derived identifiers,
70.1211 - turn assumptions and definitions into facts,
70.1212 - satisfy hypotheses of facts *)
70.1213 -
70.1214 -fun finish_derived _ _ (Assumed _) (Fixes fixes) = SOME (Fixes fixes)
70.1215 - | finish_derived _ _ (Assumed _) (Constrains csts) = SOME (Constrains csts)
70.1216 - | finish_derived _ _ (Assumed _) (Assumes asms) = SOME (Assumes asms)
70.1217 - | finish_derived _ _ (Assumed _) (Defines defs) = SOME (Defines defs)
70.1218 -
70.1219 - | finish_derived _ _ (Derived _) (Fixes _) = NONE
70.1220 - | finish_derived _ _ (Derived _) (Constrains _) = NONE
70.1221 - | finish_derived sign satisfy (Derived _) (Assumes asms) = asms
70.1222 - |> map (apsnd (map (fn (a, _) => ([Thm.assume (cterm_of sign a)], []))))
70.1223 - |> pair Thm.assumptionK |> Notes
70.1224 - |> Element.morph_ctxt satisfy |> SOME
70.1225 - | finish_derived sign satisfy (Derived _) (Defines defs) = defs
70.1226 - |> map (apsnd (fn (d, _) => [([Thm.assume (cterm_of sign d)], [])]))
70.1227 - |> pair Thm.definitionK |> Notes
70.1228 - |> Element.morph_ctxt satisfy |> SOME
70.1229 -
70.1230 - | finish_derived _ satisfy _ (Notes facts) = Notes facts
70.1231 - |> Element.morph_ctxt satisfy |> SOME;
70.1232 -
70.1233 -(* CB: for finish_elems (Ext) *)
70.1234 -
70.1235 -fun closeup _ false elem = elem
70.1236 - | closeup ctxt true elem =
70.1237 - let
70.1238 - fun close_frees t =
70.1239 - let
70.1240 - val rev_frees =
70.1241 - Term.fold_aterms (fn Free (x, T) =>
70.1242 - if Variable.is_fixed ctxt x then I else insert (op =) (x, T) | _ => I) t [];
70.1243 - in Term.list_all_free (rev rev_frees, t) end;
70.1244 -
70.1245 - fun no_binds [] = []
70.1246 - | no_binds _ = error "Illegal term bindings in locale element";
70.1247 - in
70.1248 - (case elem of
70.1249 - Assumes asms => Assumes (asms |> map (fn (a, propps) =>
70.1250 - (a, map (fn (t, ps) => (close_frees t, no_binds ps)) propps)))
70.1251 - | Defines defs => Defines (defs |> map (fn (a, (t, ps)) =>
70.1252 - (a, (close_frees (#2 (LocalDefs.cert_def ctxt t)), no_binds ps))))
70.1253 - | e => e)
70.1254 - end;
70.1255 -
70.1256 -
70.1257 -fun finish_ext_elem parms _ (Fixes fixes, _) = Fixes (map (fn (b, _, mx) =>
70.1258 - let val x = Binding.base_name b
70.1259 - in (b, AList.lookup (op =) parms x, mx) end) fixes)
70.1260 - | finish_ext_elem parms _ (Constrains _, _) = Constrains []
70.1261 - | finish_ext_elem _ close (Assumes asms, propp) =
70.1262 - close (Assumes (map #1 asms ~~ propp))
70.1263 - | finish_ext_elem _ close (Defines defs, propp) =
70.1264 - close (Defines (map #1 defs ~~ map (fn [(t, ps)] => (t, ps)) propp))
70.1265 - | finish_ext_elem _ _ (Notes facts, _) = Notes facts;
70.1266 -
70.1267 -
70.1268 -(* CB: finish_parms introduces type info from parms to identifiers *)
70.1269 -(* CB: only needed for types that have been NONE so far???
70.1270 - If so, which are these??? *)
70.1271 -
70.1272 -fun finish_parms parms (((name, ps), mode), elems) =
70.1273 - (((name, map (fn (x, _) => (x, AList.lookup (op = : string * string -> bool) parms x)) ps), mode), elems);
70.1274 -
70.1275 -fun finish_elems ctxt parms _ ((text, wits), ((id, Int e), _)) =
70.1276 - let
70.1277 - val [(id' as (_, mode), es)] = unify_elemss ctxt parms [(id, e)];
70.1278 - val wits' = case mode of Assumed _ => wits | Derived ths => wits @ ths;
70.1279 - val text' = fold (eval_text ctxt id' false) es text;
70.1280 - val es' = map_filter
70.1281 - (finish_derived (ProofContext.theory_of ctxt) (Element.satisfy_morphism wits') mode) es;
70.1282 - in ((text', wits'), (id', map Int es')) end
70.1283 - | finish_elems ctxt parms do_close ((text, wits), ((id, Ext e), [propp])) =
70.1284 - let
70.1285 - val e' = finish_ext_elem parms (closeup ctxt do_close) (e, propp);
70.1286 - val text' = eval_text ctxt id true e' text;
70.1287 - in ((text', wits), (id, [Ext e'])) end
70.1288 -
70.1289 -in
70.1290 -
70.1291 -(* CB: only called by prep_elemss *)
70.1292 -
70.1293 -fun finish_elemss ctxt parms do_close =
70.1294 - foldl_map (apsnd (finish_parms parms) o finish_elems ctxt parms do_close);
70.1295 -
70.1296 -end;
70.1297 -
70.1298 -
70.1299 -(* Remove duplicate Defines elements: temporary workaround to fix Afp/Category. *)
70.1300 -
70.1301 -fun defs_ord (defs1, defs2) =
70.1302 - list_ord (fn ((_, (d1, _)), (_, (d2, _))) =>
70.1303 - TermOrd.fast_term_ord (d1, d2)) (defs1, defs2);
70.1304 -structure Defstab =
70.1305 - TableFun(type key = (Attrib.binding * (term * term list)) list val ord = defs_ord);
70.1306 -
70.1307 -fun rem_dup_defs es ds =
70.1308 - fold_map (fn e as (Defines defs) => (fn ds =>
70.1309 - if Defstab.defined ds defs
70.1310 - then (Defines [], ds)
70.1311 - else (e, Defstab.update (defs, ()) ds))
70.1312 - | e => (fn ds => (e, ds))) es ds;
70.1313 -fun rem_dup_elemss (Int es) ds = apfst Int (rem_dup_defs es ds)
70.1314 - | rem_dup_elemss (Ext e) ds = (Ext e, ds);
70.1315 -fun rem_dup_defines raw_elemss =
70.1316 - fold_map (fn (id as (_, (Assumed _)), es) => (fn ds =>
70.1317 - apfst (pair id) (rem_dup_elemss es ds))
70.1318 - | (id as (_, (Derived _)), es) => (fn ds =>
70.1319 - ((id, es), ds))) raw_elemss Defstab.empty |> #1;
70.1320 -
70.1321 -(* CB: type inference and consistency checks for locales.
70.1322 -
70.1323 - Works by building a context (through declare_elemss), extracting the
70.1324 - required information and adjusting the context elements (finish_elemss).
70.1325 - Can also universally close free vars in assms and defs. This is only
70.1326 - needed for Ext elements and controlled by parameter do_close.
70.1327 -
70.1328 - Only elements of assumed identifiers are considered.
70.1329 -*)
70.1330 -
70.1331 -fun prep_elemss prep_vars prepp do_close context fixed_params raw_elemss raw_concl =
70.1332 - let
70.1333 - (* CB: contexts computed in the course of this function are discarded.
70.1334 - They are used for type inference and consistency checks only. *)
70.1335 - (* CB: fixed_params are the parameters (with types) of the target locale,
70.1336 - empty list if there is no target. *)
70.1337 - (* CB: raw_elemss are list of pairs consisting of identifiers and
70.1338 - context elements, the latter marked as internal or external. *)
70.1339 - val raw_elemss = rem_dup_defines raw_elemss;
70.1340 - val (raw_proppss, raw_ctxt) = declare_elemss prep_vars fixed_params raw_elemss context;
70.1341 - (* CB: raw_ctxt is context with additional fixed variables derived from
70.1342 - the fixes elements in raw_elemss,
70.1343 - raw_proppss contains assumptions and definitions from the
70.1344 - external elements in raw_elemss. *)
70.1345 - fun prep_prop raw_propp (raw_ctxt, raw_concl) =
70.1346 - let
70.1347 - (* CB: add type information from fixed_params to context (declare_term) *)
70.1348 - (* CB: process patterns (conclusion and external elements only) *)
70.1349 - val (ctxt, all_propp) =
70.1350 - prepp (fold Variable.declare_term (map Free fixed_params) raw_ctxt, raw_concl @ raw_propp);
70.1351 - (* CB: add type information from conclusion and external elements to context *)
70.1352 - val ctxt = fold Variable.declare_term (maps (map fst) all_propp) ctxt;
70.1353 - (* CB: resolve schematic variables (patterns) in conclusion and external elements. *)
70.1354 - val all_propp' = map2 (curry (op ~~))
70.1355 - (#1 (#2 (ProofContext.bind_propp_schematic_i (ctxt, all_propp)))) (map (map snd) all_propp);
70.1356 - val (concl, propp) = chop (length raw_concl) all_propp';
70.1357 - in (propp, (ctxt, concl)) end
70.1358 -
70.1359 - val (proppss, (ctxt, concl)) =
70.1360 - (fold_burrow o fold_burrow) prep_prop raw_proppss (raw_ctxt, raw_concl);
70.1361 -
70.1362 - (* CB: obtain all parameters from identifier part of raw_elemss *)
70.1363 - val xs = map #1 (params_of' raw_elemss);
70.1364 - val typing = unify_frozen ctxt 0
70.1365 - (map (Variable.default_type raw_ctxt) xs)
70.1366 - (map (Variable.default_type ctxt) xs);
70.1367 - val parms = param_types (xs ~~ typing);
70.1368 - (* CB: parms are the parameters from raw_elemss, with correct typing. *)
70.1369 -
70.1370 - (* CB: extract information from assumes and defines elements
70.1371 - (fixes, constrains and notes in raw_elemss don't have an effect on
70.1372 - text and elemss), compute final form of context elements. *)
70.1373 - val ((text, _), elemss) = finish_elemss ctxt parms do_close
70.1374 - ((((([], []), ([], [])), ([], [], [])), []), raw_elemss ~~ proppss);
70.1375 - (* CB: text has the following structure:
70.1376 - (((exts, exts'), (ints, ints')), (xs, env, defs))
70.1377 - where
70.1378 - exts: external assumptions (terms in external assumes elements)
70.1379 - exts': dito, normalised wrt. env
70.1380 - ints: internal assumptions (terms in internal assumes elements)
70.1381 - ints': dito, normalised wrt. env
70.1382 - xs: the free variables in exts' and ints' and rhss of definitions,
70.1383 - this includes parameters except defined parameters
70.1384 - env: list of term pairs encoding substitutions, where the first term
70.1385 - is a free variable; substitutions represent defines elements and
70.1386 - the rhs is normalised wrt. the previous env
70.1387 - defs: theorems representing the substitutions from defines elements
70.1388 - (thms are normalised wrt. env).
70.1389 - elemss is an updated version of raw_elemss:
70.1390 - - type info added to Fixes and modified in Constrains
70.1391 - - axiom and definition statement replaced by corresponding one
70.1392 - from proppss in Assumes and Defines
70.1393 - - Facts unchanged
70.1394 - *)
70.1395 - in ((parms, elemss, concl), text) end;
70.1396 -
70.1397 -in
70.1398 -
70.1399 -fun read_elemss x = prep_elemss ProofContext.read_vars ProofContext.read_propp_schematic x;
70.1400 -fun cert_elemss x = prep_elemss ProofContext.cert_vars ProofContext.cert_propp_schematic x;
70.1401 -
70.1402 -end;
70.1403 -
70.1404 -
70.1405 -(* facts and attributes *)
70.1406 -
70.1407 -local
70.1408 -
70.1409 -fun check_name name =
70.1410 - if NameSpace.is_qualified name then error ("Illegal qualified name: " ^ quote name)
70.1411 - else name;
70.1412 -
70.1413 -fun prep_facts _ _ _ ctxt (Int elem) = elem
70.1414 - |> Element.morph_ctxt (Morphism.thm_morphism (Thm.transfer (ProofContext.theory_of ctxt)))
70.1415 - | prep_facts prep_name get intern ctxt (Ext elem) = elem |> Element.map_ctxt
70.1416 - {var = I, typ = I, term = I,
70.1417 - binding = Binding.map_base prep_name,
70.1418 - fact = get ctxt,
70.1419 - attrib = Args.assignable o intern (ProofContext.theory_of ctxt)};
70.1420 -
70.1421 -in
70.1422 -
70.1423 -fun read_facts x = prep_facts check_name ProofContext.get_fact Attrib.intern_src x;
70.1424 -fun cert_facts x = prep_facts I (K I) (K I) x;
70.1425 -
70.1426 -end;
70.1427 -
70.1428 -
70.1429 -(* Get the specification of a locale *)
70.1430 -
70.1431 -(*The global specification is made from the parameters and global
70.1432 - assumptions, the local specification from the parameters and the
70.1433 - local assumptions.*)
70.1434 -
70.1435 -local
70.1436 -
70.1437 -fun gen_asms_of get thy name =
70.1438 - let
70.1439 - val ctxt = ProofContext.init thy;
70.1440 - val (_, raw_elemss) = flatten (ctxt, I) (([], Symtab.empty), Expr (Locale name));
70.1441 - val ((_, elemss, _), _) = read_elemss false ctxt [] raw_elemss [];
70.1442 - in
70.1443 - elemss |> get
70.1444 - |> maps (fn (_, es) => map (fn Int e => e) es)
70.1445 - |> maps (fn Assumes asms => asms | _ => [])
70.1446 - |> map (apsnd (map fst))
70.1447 - end;
70.1448 -
70.1449 -in
70.1450 -
70.1451 -fun parameters_of thy = #params o the_locale thy;
70.1452 -
70.1453 -fun intros thy = #intros o the_locale thy;
70.1454 - (*returns introduction rule for delta predicate and locale predicate
70.1455 - as a pair of singleton lists*)
70.1456 -
70.1457 -fun dests thy = #dests o the_locale thy;
70.1458 -
70.1459 -fun facts_of thy = map_filter (fn (Element.Notes (_, facts), _) => SOME facts
70.1460 - | _ => NONE) o #elems o the_locale thy;
70.1461 -
70.1462 -fun parameters_of_expr thy expr =
70.1463 - let
70.1464 - val ctxt = ProofContext.init thy;
70.1465 - val pts = params_of_expr ctxt [] (intern_expr thy expr)
70.1466 - ([], Symtab.empty, Symtab.empty);
70.1467 - val raw_params_elemss = make_raw_params_elemss pts;
70.1468 - val ((_, syn), raw_elemss) = flatten (ctxt, intern_expr thy)
70.1469 - (([], Symtab.empty), Expr expr);
70.1470 - val ((parms, _, _), _) =
70.1471 - read_elemss false ctxt [] (raw_params_elemss @ raw_elemss) [];
70.1472 - in map (fn p as (n, _) => (p, Symtab.lookup syn n |> the)) parms end;
70.1473 -
70.1474 -fun local_asms_of thy name =
70.1475 - gen_asms_of (single o Library.last_elem) thy name;
70.1476 -
70.1477 -fun global_asms_of thy name =
70.1478 - gen_asms_of I thy name;
70.1479 -
70.1480 -end;
70.1481 -
70.1482 -
70.1483 -(* full context statements: imports + elements + conclusion *)
70.1484 -
70.1485 -local
70.1486 -
70.1487 -fun prep_context_statement prep_expr prep_elemss prep_facts
70.1488 - do_close fixed_params imports elements raw_concl context =
70.1489 - let
70.1490 - val thy = ProofContext.theory_of context;
70.1491 -
70.1492 - val (import_params, import_tenv, import_syn) =
70.1493 - params_of_expr context fixed_params (prep_expr thy imports)
70.1494 - ([], Symtab.empty, Symtab.empty);
70.1495 - val includes = map_filter (fn Expr e => SOME e | Elem _ => NONE) elements;
70.1496 - val (incl_params, incl_tenv, incl_syn) = fold (params_of_expr context fixed_params)
70.1497 - (map (prep_expr thy) includes) (import_params, import_tenv, import_syn);
70.1498 -
70.1499 - val ((import_ids, _), raw_import_elemss) =
70.1500 - flatten (context, prep_expr thy) (([], Symtab.empty), Expr imports);
70.1501 - (* CB: normalise "includes" among elements *)
70.1502 - val ((ids, syn), raw_elemsss) = foldl_map (flatten (context, prep_expr thy))
70.1503 - ((import_ids, incl_syn), elements);
70.1504 -
70.1505 - val raw_elemss = flat raw_elemsss;
70.1506 - (* CB: raw_import_elemss @ raw_elemss is the normalised list of
70.1507 - context elements obtained from import and elements. *)
70.1508 - (* Now additional elements for parameters are inserted. *)
70.1509 - val import_params_ids = make_params_ids import_params;
70.1510 - val incl_params_ids =
70.1511 - make_params_ids (incl_params \\ import_params);
70.1512 - val raw_import_params_elemss =
70.1513 - make_raw_params_elemss (import_params, incl_tenv, incl_syn);
70.1514 - val raw_incl_params_elemss =
70.1515 - make_raw_params_elemss (incl_params \\ import_params, incl_tenv, incl_syn);
70.1516 - val ((parms, all_elemss, concl), (spec, (_, _, defs))) = prep_elemss do_close
70.1517 - context fixed_params
70.1518 - (raw_import_params_elemss @ raw_import_elemss @ raw_incl_params_elemss @ raw_elemss) raw_concl;
70.1519 -
70.1520 - (* replace extended ids (for axioms) by ids *)
70.1521 - val (import_ids', incl_ids) = chop (length import_ids) ids;
70.1522 - val all_ids = import_params_ids @ import_ids' @ incl_params_ids @ incl_ids;
70.1523 - val all_elemss' = map (fn (((_, ps), _), (((n, ps'), mode), elems)) =>
70.1524 - (((n, map (fn p => (p, (the o AList.lookup (op =) ps') p)) ps), mode), elems))
70.1525 - (all_ids ~~ all_elemss);
70.1526 - (* CB: all_elemss and parms contain the correct parameter types *)
70.1527 -
70.1528 - val (ps, qs) = chop (length raw_import_params_elemss + length raw_import_elemss) all_elemss';
70.1529 - val ((import_elemss, _), import_ctxt) =
70.1530 - activate_facts false prep_facts ps context;
70.1531 -
70.1532 - val ((elemss, _), ctxt) =
70.1533 - activate_facts false prep_facts qs (ProofContext.set_stmt true import_ctxt);
70.1534 - in
70.1535 - ((((import_ctxt, import_elemss), (ctxt, elemss, syn)),
70.1536 - (parms, spec, defs)), concl)
70.1537 - end;
70.1538 -
70.1539 -fun prep_statement prep_locale prep_ctxt raw_locale elems concl ctxt =
70.1540 - let
70.1541 - val thy = ProofContext.theory_of ctxt;
70.1542 - val locale = Option.map (prep_locale thy) raw_locale;
70.1543 - val (fixed_params, imports) =
70.1544 - (case locale of
70.1545 - NONE => ([], empty)
70.1546 - | SOME name =>
70.1547 - let val {params = ps, ...} = the_locale thy name
70.1548 - in (map fst ps, Locale name) end);
70.1549 - val ((((locale_ctxt, _), (elems_ctxt, _, _)), _), concl') =
70.1550 - prep_ctxt false fixed_params imports (map Elem elems) concl ctxt;
70.1551 - in (locale, locale_ctxt, elems_ctxt, concl') end;
70.1552 -
70.1553 -fun prep_expr prep imports body ctxt =
70.1554 - let
70.1555 - val (((_, import_elemss), (ctxt', elemss, _)), _) = prep imports body ctxt;
70.1556 - val all_elems = maps snd (import_elemss @ elemss);
70.1557 - in (all_elems, ctxt') end;
70.1558 -
70.1559 -in
70.1560 -
70.1561 -val read_ctxt = prep_context_statement intern_expr read_elemss read_facts;
70.1562 -val cert_ctxt = prep_context_statement (K I) cert_elemss cert_facts;
70.1563 -
70.1564 -fun read_context imports body ctxt = #1 (read_ctxt true [] imports (map Elem body) [] ctxt);
70.1565 -fun cert_context imports body ctxt = #1 (cert_ctxt true [] imports (map Elem body) [] ctxt);
70.1566 -
70.1567 -val read_expr = prep_expr read_context;
70.1568 -val cert_expr = prep_expr cert_context;
70.1569 -
70.1570 -fun read_context_statement loc = prep_statement (K I) read_ctxt loc;
70.1571 -fun read_context_statement_cmd loc = prep_statement intern read_ctxt loc;
70.1572 -fun cert_context_statement loc = prep_statement (K I) cert_ctxt loc;
70.1573 -
70.1574 -end;
70.1575 -
70.1576 -
70.1577 -(* init *)
70.1578 -
70.1579 -fun init loc =
70.1580 - ProofContext.init
70.1581 - #> #2 o cert_context_statement (SOME loc) [] [];
70.1582 -
70.1583 -
70.1584 -(* print locale *)
70.1585 -
70.1586 -fun print_locale thy show_facts imports body =
70.1587 - let val (all_elems, ctxt) = read_expr imports body (ProofContext.init thy) in
70.1588 - Pretty.big_list "locale elements:" (all_elems
70.1589 - |> (if show_facts then I else filter (fn Notes _ => false | _ => true))
70.1590 - |> map (Element.pretty_ctxt ctxt) |> filter_out null
70.1591 - |> map Pretty.chunks)
70.1592 - |> Pretty.writeln
70.1593 - end;
70.1594 -
70.1595 -
70.1596 -
70.1597 -(** store results **)
70.1598 -
70.1599 -(* join equations of an id with already accumulated ones *)
70.1600 -
70.1601 -fun join_eqns get_reg id eqns =
70.1602 - let
70.1603 - val eqns' = case get_reg id
70.1604 - of NONE => eqns
70.1605 - | SOME (_, _, eqns') => Termtab.join (fn _ => fn (_, e) => e) (eqns, eqns')
70.1606 - (* prefer equations from eqns' *)
70.1607 - in ((id, eqns'), eqns') end;
70.1608 -
70.1609 -
70.1610 -(* collect witnesses and equations up to a particular target for a
70.1611 - registration; requires parameters and flattened list of identifiers
70.1612 - instead of recomputing it from the target *)
70.1613 -
70.1614 -fun collect_witnesses ctxt (imprt as ((impT, _), (imp, _))) parms ids ext_ts = let
70.1615 -
70.1616 - val thy = ProofContext.theory_of ctxt;
70.1617 -
70.1618 - val ts = map (var_inst_term (impT, imp)) ext_ts;
70.1619 - val (parms, parmTs) = split_list parms;
70.1620 - val parmvTs = map Logic.varifyT parmTs;
70.1621 - val vtinst = fold (Sign.typ_match thy) (parmvTs ~~ map Term.fastype_of ts) Vartab.empty;
70.1622 - val tinst = Vartab.dest vtinst |> map (fn ((x, 0), (_, T)) => (x, T))
70.1623 - |> Symtab.make;
70.1624 - val inst = Symtab.make (parms ~~ ts);
70.1625 -
70.1626 - (* instantiate parameter names in ids *)
70.1627 - val ext_inst = Symtab.make (parms ~~ ext_ts);
70.1628 - fun ext_inst_names ps = map (the o Symtab.lookup ext_inst) ps;
70.1629 - val inst_ids = map (apfst (apsnd ext_inst_names)) ids;
70.1630 - val assumed_ids = map_filter (fn (id, (_, Assumed _)) => SOME id | _ => NONE) inst_ids;
70.1631 - val wits = maps (#2 o the o get_local_registration ctxt imprt) assumed_ids;
70.1632 - val eqns =
70.1633 - fold_map (join_eqns (get_local_registration ctxt imprt))
70.1634 - (map fst inst_ids) Termtab.empty |> snd |> Termtab.dest |> map snd;
70.1635 - in ((tinst, inst), wits, eqns) end;
70.1636 -
70.1637 -
70.1638 -(* compute and apply morphism *)
70.1639 -
70.1640 -fun name_morph phi_name (lprfx, pprfx) b =
70.1641 - b
70.1642 - |> (if not (Binding.is_empty b) andalso pprfx <> ""
70.1643 - then Binding.add_prefix false pprfx else I)
70.1644 - |> (if not (Binding.is_empty b)
70.1645 - then Binding.add_prefix false lprfx else I)
70.1646 - |> phi_name;
70.1647 -
70.1648 -fun inst_morph thy phi_name param_prfx insts prems eqns export =
70.1649 - let
70.1650 - (* standardise export morphism *)
70.1651 - val exp_fact = Drule.zero_var_indexes_list o map Thm.strip_shyps o Morphism.fact export;
70.1652 - val exp_term = TermSubst.zero_var_indexes o Morphism.term export;
70.1653 - (* FIXME sync with exp_fact *)
70.1654 - val exp_typ = Logic.type_map exp_term;
70.1655 - val export' =
70.1656 - Morphism.morphism {binding = I, var = I, typ = exp_typ, term = exp_term, fact = exp_fact};
70.1657 - in
70.1658 - Morphism.binding_morphism (name_morph phi_name param_prfx) $>
70.1659 - Element.inst_morphism thy insts $>
70.1660 - Element.satisfy_morphism prems $>
70.1661 - Morphism.term_morphism (MetaSimplifier.rewrite_term thy eqns []) $>
70.1662 - Morphism.thm_morphism (MetaSimplifier.rewrite_rule eqns) $>
70.1663 - export'
70.1664 - end;
70.1665 -
70.1666 -fun activate_note thy phi_name param_prfx attrib insts prems eqns exp =
70.1667 - (Element.facts_map o Element.morph_ctxt)
70.1668 - (inst_morph thy phi_name param_prfx insts prems eqns exp)
70.1669 - #> Attrib.map_facts attrib;
70.1670 -
70.1671 -
70.1672 -(* public interface to interpretation morphism *)
70.1673 -
70.1674 -fun get_interpret_morph thy phi_name param_prfx (exp, imp) target ext_ts =
70.1675 - let
70.1676 - val parms = the_locale thy target |> #params |> map fst;
70.1677 - val ids = flatten (ProofContext.init thy, intern_expr thy)
70.1678 - (([], Symtab.empty), Expr (Locale target)) |> fst |> fst;
70.1679 - val (insts, prems, eqns) = collect_witnesses (ProofContext.init thy) imp parms ids ext_ts;
70.1680 - in
70.1681 - inst_morph thy phi_name param_prfx insts prems eqns exp
70.1682 - end;
70.1683 -
70.1684 -(* store instantiations of args for all registered interpretations
70.1685 - of the theory *)
70.1686 -
70.1687 -fun note_thmss_registrations target (kind, args) thy =
70.1688 - let
70.1689 - val parms = the_locale thy target |> #params |> map fst;
70.1690 - val ids = flatten (ProofContext.init thy, intern_expr thy)
70.1691 - (([], Symtab.empty), Expr (Locale target)) |> fst |> fst;
70.1692 -
70.1693 - val regs = get_global_registrations thy target;
70.1694 - (* add args to thy for all registrations *)
70.1695 -
70.1696 - fun activate (ext_ts, ((phi_name, param_prfx), (exp, imp), _, _)) thy =
70.1697 - let
70.1698 - val (insts, prems, eqns) = collect_witnesses (ProofContext.init thy) imp parms ids ext_ts;
70.1699 - val args' = args
70.1700 - |> activate_note thy phi_name param_prfx
70.1701 - (Attrib.attribute_i thy) insts prems eqns exp;
70.1702 - in
70.1703 - thy
70.1704 - |> global_note_qualified kind args'
70.1705 - |> snd
70.1706 - end;
70.1707 - in fold activate regs thy end;
70.1708 -
70.1709 -
70.1710 -(* locale results *)
70.1711 -
70.1712 -fun add_thmss loc kind args ctxt =
70.1713 - let
70.1714 - val (([(_, [Notes args'])], _), ctxt') =
70.1715 - activate_facts true cert_facts
70.1716 - [((("", []), Assumed []), [Ext (Notes (kind, args))])] ctxt;
70.1717 - val ctxt'' = ctxt' |> ProofContext.theory
70.1718 - (change_locale loc
70.1719 - (fn (axiom, elems, params, decls, regs, intros, dests) =>
70.1720 - (axiom, elems @ [(Notes args', stamp ())],
70.1721 - params, decls, regs, intros, dests))
70.1722 - #> note_thmss_registrations loc args');
70.1723 - in ctxt'' end;
70.1724 -
70.1725 -
70.1726 -(* declarations *)
70.1727 -
70.1728 -local
70.1729 -
70.1730 -fun decl_attrib decl phi = Thm.declaration_attribute (K (decl phi));
70.1731 -
70.1732 -fun add_decls add loc decl =
70.1733 - ProofContext.theory (change_locale loc
70.1734 - (fn (axiom, elems, params, decls, regs, intros, dests) =>
70.1735 - (axiom, elems, params, add (decl, stamp ()) decls, regs, intros, dests))) #>
70.1736 - add_thmss loc Thm.internalK
70.1737 - [((Binding.empty, [Attrib.internal (decl_attrib decl)]), [([Drule.dummy_thm], [])])];
70.1738 -
70.1739 -in
70.1740 -
70.1741 -val add_type_syntax = add_decls (apfst o cons);
70.1742 -val add_term_syntax = add_decls (apsnd o cons);
70.1743 -val add_declaration = add_decls (K I);
70.1744 -
70.1745 -fun declarations_of thy loc =
70.1746 - the_locale thy loc |> #decls |> apfst (map fst) |> apsnd (map fst);
70.1747 -
70.1748 -end;
70.1749 -
70.1750 -
70.1751 -
70.1752 -(** define locales **)
70.1753 -
70.1754 -(* predicate text *)
70.1755 -(* CB: generate locale predicates and delta predicates *)
70.1756 -
70.1757 -local
70.1758 -
70.1759 -(* introN: name of theorems for introduction rules of locale and
70.1760 - delta predicates;
70.1761 - axiomsN: name of theorem set with destruct rules for locale predicates,
70.1762 - also name suffix of delta predicates. *)
70.1763 -
70.1764 -val introN = "intro";
70.1765 -val axiomsN = "axioms";
70.1766 -
70.1767 -fun atomize_spec thy ts =
70.1768 - let
70.1769 - val t = Logic.mk_conjunction_balanced ts;
70.1770 - val body = ObjectLogic.atomize_term thy t;
70.1771 - val bodyT = Term.fastype_of body;
70.1772 - in
70.1773 - if bodyT = propT then (t, propT, Thm.reflexive (Thm.cterm_of thy t))
70.1774 - else (body, bodyT, ObjectLogic.atomize (Thm.cterm_of thy t))
70.1775 - end;
70.1776 -
70.1777 -fun aprop_tr' n c = (Syntax.constN ^ c, fn ctxt => fn args =>
70.1778 - if length args = n then
70.1779 - Syntax.const "_aprop" $
70.1780 - Term.list_comb (Syntax.free (Consts.extern (ProofContext.consts_of ctxt) c), args)
70.1781 - else raise Match);
70.1782 -
70.1783 -(* CB: define one predicate including its intro rule and axioms
70.1784 - - bname: predicate name
70.1785 - - parms: locale parameters
70.1786 - - defs: thms representing substitutions from defines elements
70.1787 - - ts: terms representing locale assumptions (not normalised wrt. defs)
70.1788 - - norm_ts: terms representing locale assumptions (normalised wrt. defs)
70.1789 - - thy: the theory
70.1790 -*)
70.1791 -
70.1792 -fun def_pred bname parms defs ts norm_ts thy =
70.1793 - let
70.1794 - val name = Sign.full_bname thy bname;
70.1795 -
70.1796 - val (body, bodyT, body_eq) = atomize_spec thy norm_ts;
70.1797 - val env = Term.add_free_names body [];
70.1798 - val xs = filter (member (op =) env o #1) parms;
70.1799 - val Ts = map #2 xs;
70.1800 - val extraTs =
70.1801 - (Term.add_tfrees body [] \\ fold Term.add_tfreesT Ts [])
70.1802 - |> Library.sort_wrt #1 |> map TFree;
70.1803 - val predT = map Term.itselfT extraTs ---> Ts ---> bodyT;
70.1804 -
70.1805 - val args = map Logic.mk_type extraTs @ map Free xs;
70.1806 - val head = Term.list_comb (Const (name, predT), args);
70.1807 - val statement = ObjectLogic.ensure_propT thy head;
70.1808 -
70.1809 - val ([pred_def], defs_thy) =
70.1810 - thy
70.1811 - |> bodyT = propT ? Sign.add_advanced_trfuns ([], [], [aprop_tr' (length args) name], [])
70.1812 - |> Sign.declare_const [] ((Binding.name bname, predT), NoSyn) |> snd
70.1813 - |> PureThy.add_defs false
70.1814 - [((Thm.def_name bname, Logic.mk_equals (head, body)), [Thm.kind_internal])];
70.1815 - val defs_ctxt = ProofContext.init defs_thy |> Variable.declare_term head;
70.1816 -
70.1817 - val cert = Thm.cterm_of defs_thy;
70.1818 -
70.1819 - val intro = Goal.prove_global defs_thy [] norm_ts statement (fn _ =>
70.1820 - MetaSimplifier.rewrite_goals_tac [pred_def] THEN
70.1821 - Tactic.compose_tac (false, body_eq RS Drule.equal_elim_rule1, 1) 1 THEN
70.1822 - Tactic.compose_tac (false,
70.1823 - Conjunction.intr_balanced (map (Thm.assume o cert) norm_ts), 0) 1);
70.1824 -
70.1825 - val conjuncts =
70.1826 - (Drule.equal_elim_rule2 OF [body_eq,
70.1827 - MetaSimplifier.rewrite_rule [pred_def] (Thm.assume (cert statement))])
70.1828 - |> Conjunction.elim_balanced (length ts);
70.1829 - val axioms = ts ~~ conjuncts |> map (fn (t, ax) =>
70.1830 - Element.prove_witness defs_ctxt t
70.1831 - (MetaSimplifier.rewrite_goals_tac defs THEN
70.1832 - Tactic.compose_tac (false, ax, 0) 1));
70.1833 - in ((statement, intro, axioms), defs_thy) end;
70.1834 -
70.1835 -fun assumes_to_notes (Assumes asms) axms =
70.1836 - fold_map (fn (a, spec) => fn axs =>
70.1837 - let val (ps, qs) = chop (length spec) axs
70.1838 - in ((a, [(ps, [])]), qs) end) asms axms
70.1839 - |> apfst (curry Notes Thm.assumptionK)
70.1840 - | assumes_to_notes e axms = (e, axms);
70.1841 -
70.1842 -(* CB: the following two change only "new" elems, these have identifier ("", _). *)
70.1843 -
70.1844 -(* turn Assumes into Notes elements *)
70.1845 -
70.1846 -fun change_assumes_elemss axioms elemss =
70.1847 - let
70.1848 - val satisfy = Element.morph_ctxt (Element.satisfy_morphism axioms);
70.1849 - fun change (id as ("", _), es) =
70.1850 - fold_map assumes_to_notes (map satisfy es)
70.1851 - #-> (fn es' => pair (id, es'))
70.1852 - | change e = pair e;
70.1853 - in
70.1854 - fst (fold_map change elemss (map Element.conclude_witness axioms))
70.1855 - end;
70.1856 -
70.1857 -(* adjust hyps of Notes elements *)
70.1858 -
70.1859 -fun change_elemss_hyps axioms elemss =
70.1860 - let
70.1861 - val satisfy = Element.morph_ctxt (Element.satisfy_morphism axioms);
70.1862 - fun change (id as ("", _), es) = (id, map (fn e as Notes _ => satisfy e | e => e) es)
70.1863 - | change e = e;
70.1864 - in map change elemss end;
70.1865 -
70.1866 -in
70.1867 -
70.1868 -(* CB: main predicate definition function *)
70.1869 -
70.1870 -fun define_preds pname (parms, ((exts, exts'), (ints, ints')), defs) elemss thy =
70.1871 - let
70.1872 - val ((elemss', more_ts), a_elem, a_intro, thy'') =
70.1873 - if null exts then ((elemss, []), [], [], thy)
70.1874 - else
70.1875 - let
70.1876 - val aname = if null ints then pname else pname ^ "_" ^ axiomsN;
70.1877 - val ((statement, intro, axioms), thy') =
70.1878 - thy
70.1879 - |> def_pred aname parms defs exts exts';
70.1880 - val elemss' = change_assumes_elemss axioms elemss;
70.1881 - val a_elem = [(("", []),
70.1882 - [Assumes [((Binding.name (pname ^ "_" ^ axiomsN), []), [(statement, [])])]])];
70.1883 - val (_, thy'') =
70.1884 - thy'
70.1885 - |> Sign.add_path aname
70.1886 - |> Sign.no_base_names
70.1887 - |> PureThy.note_thmss Thm.internalK [((Binding.name introN, []), [([intro], [])])]
70.1888 - ||> Sign.restore_naming thy';
70.1889 - in ((elemss', [statement]), a_elem, [intro], thy'') end;
70.1890 - val (predicate, stmt', elemss'', b_intro, thy'''') =
70.1891 - if null ints then (([], []), more_ts, elemss' @ a_elem, [], thy'')
70.1892 - else
70.1893 - let
70.1894 - val ((statement, intro, axioms), thy''') =
70.1895 - thy''
70.1896 - |> def_pred pname parms defs (ints @ more_ts) (ints' @ more_ts);
70.1897 - val cstatement = Thm.cterm_of thy''' statement;
70.1898 - val elemss'' = change_elemss_hyps axioms elemss';
70.1899 - val b_elem = [(("", []),
70.1900 - [Assumes [((Binding.name (pname ^ "_" ^ axiomsN), []), [(statement, [])])]])];
70.1901 - val (_, thy'''') =
70.1902 - thy'''
70.1903 - |> Sign.add_path pname
70.1904 - |> Sign.no_base_names
70.1905 - |> PureThy.note_thmss Thm.internalK
70.1906 - [((Binding.name introN, []), [([intro], [])]),
70.1907 - ((Binding.name axiomsN, []),
70.1908 - [(map (Drule.standard o Element.conclude_witness) axioms, [])])]
70.1909 - ||> Sign.restore_naming thy''';
70.1910 - in (([cstatement], axioms), [statement], elemss'' @ b_elem, [intro], thy'''') end;
70.1911 - in (((elemss'', predicate, stmt'), (a_intro, b_intro)), thy'''') end;
70.1912 -
70.1913 -end;
70.1914 -
70.1915 -
70.1916 -(* add_locale(_i) *)
70.1917 -
70.1918 -local
70.1919 -
70.1920 -(* turn Defines into Notes elements, accumulate definition terms *)
70.1921 -
70.1922 -fun defines_to_notes is_ext thy (Defines defs) defns =
70.1923 - let
70.1924 - val defs' = map (fn (_, (def, _)) => (Attrib.empty_binding, (def, []))) defs
70.1925 - val notes = map (fn (a, (def, _)) =>
70.1926 - (a, [([assume (cterm_of thy def)], [])])) defs
70.1927 - in
70.1928 - (if is_ext then SOME (Notes (Thm.definitionK, notes)) else NONE, defns @ [Defines defs'])
70.1929 - end
70.1930 - | defines_to_notes _ _ e defns = (SOME e, defns);
70.1931 -
70.1932 -fun change_defines_elemss thy elemss defns =
70.1933 - let
70.1934 - fun change (id as (n, _), es) defns =
70.1935 - let
70.1936 - val (es', defns') = fold_map (defines_to_notes (n="") thy) es defns
70.1937 - in ((id, map_filter I es'), defns') end
70.1938 - in fold_map change elemss defns end;
70.1939 -
70.1940 -fun gen_add_locale prep_ctxt prep_expr
70.1941 - predicate_name bname raw_imports raw_body thy =
70.1942 - (* predicate_name: "" - locale with predicate named as locale
70.1943 - "name" - locale with predicate named "name" *)
70.1944 - let
70.1945 - val thy_ctxt = ProofContext.init thy;
70.1946 - val name = Sign.full_bname thy bname;
70.1947 - val _ = is_some (get_locale thy name) andalso
70.1948 - error ("Duplicate definition of locale " ^ quote name);
70.1949 -
70.1950 - val (((import_ctxt, import_elemss), (body_ctxt, body_elemss, syn)),
70.1951 - text as (parms, ((_, exts'), _), defs)) =
70.1952 - prep_ctxt raw_imports raw_body thy_ctxt;
70.1953 - val elemss = import_elemss @ body_elemss |>
70.1954 - map_filter (fn ((id, Assumed axs), elems) => SOME (id, elems) | _ => NONE);
70.1955 -
70.1956 - val extraTs = List.foldr OldTerm.add_term_tfrees [] exts' \\
70.1957 - List.foldr OldTerm.add_typ_tfrees [] (map snd parms);
70.1958 - val _ = if null extraTs then ()
70.1959 - else warning ("Additional type variable(s) in locale specification " ^ quote bname);
70.1960 -
70.1961 - val predicate_name' = case predicate_name of "" => bname | _ => predicate_name;
70.1962 - val (elemss', defns) = change_defines_elemss thy elemss [];
70.1963 - val elemss'' = elemss' @ [(("", []), defns)];
70.1964 - val (((elemss''', predicate as (pred_statement, pred_axioms), stmt'), intros), thy') =
70.1965 - define_preds predicate_name' text elemss'' thy;
70.1966 - val regs = pred_axioms
70.1967 - |> fold_map (fn (id, elems) => fn wts => let
70.1968 - val ts = flat (map_filter (fn (Assumes asms) =>
70.1969 - SOME (maps (map #1 o #2) asms) | _ => NONE) elems);
70.1970 - val (wts1, wts2) = chop (length ts) wts;
70.1971 - in ((apsnd (map fst) id, wts1), wts2) end) elemss'''
70.1972 - |> fst
70.1973 - |> map_filter (fn (("", _), _) => NONE | e => SOME e);
70.1974 - fun axiomify axioms elemss =
70.1975 - (axioms, elemss) |> foldl_map (fn (axs, (id, elems)) => let
70.1976 - val ts = flat (map_filter (fn (Assumes asms) =>
70.1977 - SOME (maps (map #1 o #2) asms) | _ => NONE) elems);
70.1978 - val (axs1, axs2) = chop (length ts) axs;
70.1979 - in (axs2, ((id, Assumed axs1), elems)) end)
70.1980 - |> snd;
70.1981 - val ((_, facts), ctxt) = activate_facts true (K I)
70.1982 - (axiomify pred_axioms elemss''') (ProofContext.init thy');
70.1983 - val view_ctxt = Assumption.add_view thy_ctxt pred_statement ctxt;
70.1984 - val export = Thm.close_derivation o Goal.norm_result o
70.1985 - singleton (ProofContext.export view_ctxt thy_ctxt);
70.1986 - val facts' = facts |> map (fn (a, ths) => ((a, []), [(map export ths, [])]));
70.1987 - val elems' = maps #2 (filter (fn ((s, _), _) => s = "") elemss''');
70.1988 - val elems'' = map_filter (fn (Fixes _) => NONE | e => SOME e) elems';
70.1989 - val axs' = map (Element.assume_witness thy') stmt';
70.1990 - val loc_ctxt = thy'
70.1991 - |> Sign.add_path bname
70.1992 - |> Sign.no_base_names
70.1993 - |> PureThy.note_thmss Thm.assumptionK facts' |> snd
70.1994 - |> Sign.restore_naming thy'
70.1995 - |> register_locale bname {axiom = axs',
70.1996 - elems = map (fn e => (e, stamp ())) elems'',
70.1997 - params = params_of elemss''' |> map (fn (x, SOME T) => ((x, T), the (Symtab.lookup syn x))),
70.1998 - decls = ([], []),
70.1999 - regs = regs,
70.2000 - intros = intros,
70.2001 - dests = map Element.conclude_witness pred_axioms}
70.2002 - |> init name;
70.2003 - in (name, loc_ctxt) end;
70.2004 -
70.2005 -in
70.2006 -
70.2007 -val add_locale = gen_add_locale cert_context (K I);
70.2008 -val add_locale_cmd = gen_add_locale read_context intern_expr "";
70.2009 -
70.2010 -end;
70.2011 -
70.2012 -val _ = Context.>> (Context.map_theory
70.2013 - (add_locale "" "var" empty [Fixes [(Binding.name (Name.internal "x"), NONE, NoSyn)]] #>
70.2014 - snd #> ProofContext.theory_of #>
70.2015 - add_locale "" "struct" empty [Fixes [(Binding.name (Name.internal "S"), NONE, Structure)]] #>
70.2016 - snd #> ProofContext.theory_of));
70.2017 -
70.2018 -
70.2019 -
70.2020 -
70.2021 -(** Normalisation of locale statements ---
70.2022 - discharges goals implied by interpretations **)
70.2023 -
70.2024 -local
70.2025 -
70.2026 -fun locale_assm_intros thy =
70.2027 - Symtab.fold (fn (_, {intros = (a, _), ...}) => fn intros => (a @ intros))
70.2028 - (#2 (LocalesData.get thy)) [];
70.2029 -fun locale_base_intros thy =
70.2030 - Symtab.fold (fn (_, {intros = (_, b), ...}) => fn intros => (b @ intros))
70.2031 - (#2 (LocalesData.get thy)) [];
70.2032 -
70.2033 -fun all_witnesses ctxt =
70.2034 - let
70.2035 - val thy = ProofContext.theory_of ctxt;
70.2036 - fun get registrations = Symtab.fold (fn (_, regs) => fn thms =>
70.2037 - (Registrations.dest thy regs |> map (fn (_, (_, (exp, _), wits, _)) =>
70.2038 - map (Element.conclude_witness #> Morphism.thm exp) wits) |> flat) @ thms)
70.2039 - registrations [];
70.2040 - in get (RegistrationsData.get (Context.Proof ctxt)) end;
70.2041 -
70.2042 -in
70.2043 -
70.2044 -fun intro_locales_tac eager ctxt facts st =
70.2045 - let
70.2046 - val wits = all_witnesses ctxt;
70.2047 - val thy = ProofContext.theory_of ctxt;
70.2048 - val intros = locale_base_intros thy @ (if eager then locale_assm_intros thy else []);
70.2049 - in
70.2050 - Method.intros_tac (wits @ intros) facts st
70.2051 - end;
70.2052 -
70.2053 -end;
70.2054 -
70.2055 -
70.2056 -(** Interpretation commands **)
70.2057 -
70.2058 -local
70.2059 -
70.2060 -(* extract proof obligations (assms and defs) from elements *)
70.2061 -
70.2062 -fun extract_asms_elems ((id, Assumed _), elems) = (id, maps Element.prems_of elems)
70.2063 - | extract_asms_elems ((id, Derived _), _) = (id, []);
70.2064 -
70.2065 -
70.2066 -(* activate instantiated facts in theory or context *)
70.2067 -
70.2068 -fun gen_activate_facts_elemss mk_ctxt note attrib put_reg add_wit add_eqn
70.2069 - phi_name all_elemss pss propss eq_attns (exp, imp) thmss thy_ctxt =
70.2070 - let
70.2071 - val ctxt = mk_ctxt thy_ctxt;
70.2072 - fun get_reg thy_ctxt = get_local_registration (mk_ctxt thy_ctxt);
70.2073 - fun test_reg thy_ctxt = test_local_registration (mk_ctxt thy_ctxt);
70.2074 -
70.2075 - val (all_propss, eq_props) = chop (length all_elemss) propss;
70.2076 - val (all_thmss, eq_thms) = chop (length all_elemss) thmss;
70.2077 -
70.2078 - (* Filter out fragments already registered. *)
70.2079 -
70.2080 - val (new_elemss, xs) = split_list (filter_out (fn (((id, _), _), _) =>
70.2081 - test_reg thy_ctxt id) (all_elemss ~~ (pss ~~ (all_propss ~~ all_thmss))));
70.2082 - val (new_pss, ys) = split_list xs;
70.2083 - val (new_propss, new_thmss) = split_list ys;
70.2084 -
70.2085 - val thy_ctxt' = thy_ctxt
70.2086 - (* add registrations *)
70.2087 - |> fold2 (fn ((id as (loc, _), _), _) => fn ps => put_reg id (phi_name, param_prefix loc ps) (exp, imp))
70.2088 - new_elemss new_pss
70.2089 - (* add witnesses of Assumed elements (only those generate proof obligations) *)
70.2090 - |> fold2 (fn (id, _) => fold (add_wit id)) new_propss new_thmss
70.2091 - (* add equations *)
70.2092 - |> fold2 (fn (id, _) => fold (add_eqn id)) eq_props
70.2093 - ((map o map) (Drule.abs_def o LocalDefs.meta_rewrite_rule ctxt o
70.2094 - Element.conclude_witness) eq_thms);
70.2095 -
70.2096 - val prems = flat (map_filter
70.2097 - (fn ((id, Assumed _), _) => Option.map #2 (get_reg thy_ctxt' imp id)
70.2098 - | ((_, Derived _), _) => NONE) all_elemss);
70.2099 -
70.2100 - val thy_ctxt'' = thy_ctxt'
70.2101 - (* add witnesses of Derived elements *)
70.2102 - |> fold (fn (id, thms) => fold
70.2103 - (add_wit id o Element.morph_witness (Element.satisfy_morphism prems)) thms)
70.2104 - (map_filter (fn ((_, Assumed _), _) => NONE
70.2105 - | ((id, Derived thms), _) => SOME (id, thms)) new_elemss)
70.2106 -
70.2107 - fun activate_elem phi_name param_prfx insts prems eqns exp (Notes (kind, facts)) thy_ctxt =
70.2108 - let
70.2109 - val ctxt = mk_ctxt thy_ctxt;
70.2110 - val thy = ProofContext.theory_of ctxt;
70.2111 - val facts' = facts
70.2112 - |> activate_note thy phi_name param_prfx
70.2113 - (attrib thy_ctxt) insts prems eqns exp;
70.2114 - in
70.2115 - thy_ctxt
70.2116 - |> note kind facts'
70.2117 - |> snd
70.2118 - end
70.2119 - | activate_elem _ _ _ _ _ _ _ thy_ctxt = thy_ctxt;
70.2120 -
70.2121 - fun activate_elems (((loc, ext_ts), _), _) ps thy_ctxt =
70.2122 - let
70.2123 - val ctxt = mk_ctxt thy_ctxt;
70.2124 - val thy = ProofContext.theory_of ctxt;
70.2125 - val {params, elems, ...} = the_locale thy loc;
70.2126 - val parms = map fst params;
70.2127 - val param_prfx = param_prefix loc ps;
70.2128 - val ids = flatten (ProofContext.init thy, intern_expr thy)
70.2129 - (([], Symtab.empty), Expr (Locale loc)) |> fst |> fst;
70.2130 - val (insts, prems, eqns) = collect_witnesses ctxt imp parms ids ext_ts;
70.2131 - in
70.2132 - thy_ctxt
70.2133 - |> fold (activate_elem phi_name param_prfx insts prems eqns exp o fst) elems
70.2134 - end;
70.2135 -
70.2136 - in
70.2137 - thy_ctxt''
70.2138 - (* add equations as lemmas to context *)
70.2139 - |> (fold2 o fold2) (fn attn => fn thm => snd o yield_singleton (note Thm.lemmaK)
70.2140 - ((apsnd o map) (attrib thy_ctxt'') attn, [([Element.conclude_witness thm], [])]))
70.2141 - (unflat eq_thms eq_attns) eq_thms
70.2142 - (* add interpreted facts *)
70.2143 - |> fold2 activate_elems new_elemss new_pss
70.2144 - end;
70.2145 -
70.2146 -fun global_activate_facts_elemss x = gen_activate_facts_elemss
70.2147 - ProofContext.init
70.2148 - global_note_qualified
70.2149 - Attrib.attribute_i
70.2150 - put_global_registration
70.2151 - add_global_witness
70.2152 - add_global_equation
70.2153 - x;
70.2154 -
70.2155 -fun local_activate_facts_elemss x = gen_activate_facts_elemss
70.2156 - I
70.2157 - local_note_qualified
70.2158 - (Attrib.attribute_i o ProofContext.theory_of)
70.2159 - put_local_registration
70.2160 - add_local_witness
70.2161 - add_local_equation
70.2162 - x;
70.2163 -
70.2164 -fun prep_instantiations parse_term parse_prop ctxt parms (insts, eqns) =
70.2165 - let
70.2166 - (* parameters *)
70.2167 - val (parm_names, parm_types) = parms |> split_list
70.2168 - ||> map (TypeInfer.paramify_vars o Logic.varifyT);
70.2169 - val type_parms = fold Term.add_tvarsT parm_types [] |> map (Logic.mk_type o TVar);
70.2170 - val type_parm_names = fold Term.add_tfreesT (map snd parms) [] |> map fst;
70.2171 -
70.2172 - (* parameter instantiations *)
70.2173 - val d = length parms - length insts;
70.2174 - val insts =
70.2175 - if d < 0 then error "More arguments than parameters in instantiation."
70.2176 - else insts @ replicate d NONE;
70.2177 - val (given_ps, given_insts) =
70.2178 - ((parm_names ~~ parm_types) ~~ insts) |> map_filter
70.2179 - (fn (_, NONE) => NONE
70.2180 - | ((n, T), SOME inst) => SOME ((n, T), inst))
70.2181 - |> split_list;
70.2182 - val (given_parm_names, given_parm_types) = given_ps |> split_list;
70.2183 -
70.2184 - (* parse insts / eqns *)
70.2185 - val given_insts' = map (parse_term ctxt) given_insts;
70.2186 - val eqns' = map (parse_prop ctxt) eqns;
70.2187 -
70.2188 - (* type inference and contexts *)
70.2189 - val arg = type_parms @ map2 TypeInfer.constrain given_parm_types given_insts' @ eqns';
70.2190 - val res = Syntax.check_terms ctxt arg;
70.2191 - val ctxt' = ctxt |> fold Variable.auto_fixes res;
70.2192 -
70.2193 - (* instantiation *)
70.2194 - val (type_parms'', res') = chop (length type_parms) res;
70.2195 - val (given_insts'', eqns'') = chop (length given_insts) res';
70.2196 - val instT = Symtab.make (type_parm_names ~~ map Logic.dest_type type_parms'');
70.2197 - val inst = Symtab.make (given_parm_names ~~ given_insts'');
70.2198 -
70.2199 - (* export from eigencontext *)
70.2200 - val export = Variable.export_morphism ctxt' ctxt;
70.2201 -
70.2202 - (* import, its inverse *)
70.2203 - val domT = fold Term.add_tfrees res [] |> map TFree;
70.2204 - val importT = domT |> map (fn x => (Morphism.typ export x, x))
70.2205 - |> map_filter (fn (TFree _, _) => NONE (* fixed point of export *)
70.2206 - | (TVar y, x) => SOME (fst y, x)
70.2207 - | _ => error "internal: illegal export in interpretation")
70.2208 - |> Vartab.make;
70.2209 - val dom = fold Term.add_frees res [] |> map Free;
70.2210 - val imprt = dom |> map (fn x => (Morphism.term export x, x))
70.2211 - |> map_filter (fn (Free _, _) => NONE (* fixed point of export *)
70.2212 - | (Var y, x) => SOME (fst y, x)
70.2213 - | _ => error "internal: illegal export in interpretation")
70.2214 - |> Vartab.make;
70.2215 - in (((instT, inst), eqns''), (export, ((importT, domT), (imprt, dom)))) end;
70.2216 -
70.2217 -val read_instantiations = prep_instantiations Syntax.parse_term Syntax.parse_prop;
70.2218 -val check_instantiations = prep_instantiations (K I) (K I);
70.2219 -
70.2220 -fun gen_prep_registration mk_ctxt test_reg activate
70.2221 - prep_attr prep_expr prep_insts
70.2222 - thy_ctxt phi_name raw_expr raw_insts =
70.2223 - let
70.2224 - val ctxt = mk_ctxt thy_ctxt;
70.2225 - val thy = ProofContext.theory_of ctxt;
70.2226 - val ctxt' = ProofContext.init thy;
70.2227 - fun prep_attn attn = (apsnd o map)
70.2228 - (Attrib.crude_closure ctxt o Args.assignable o prep_attr thy) attn;
70.2229 -
70.2230 - val expr = prep_expr thy raw_expr;
70.2231 -
70.2232 - val pts = params_of_expr ctxt' [] expr ([], Symtab.empty, Symtab.empty);
70.2233 - val params_ids = make_params_ids (#1 pts);
70.2234 - val raw_params_elemss = make_raw_params_elemss pts;
70.2235 - val ((ids, _), raw_elemss) = flatten (ctxt', I) (([], Symtab.empty), Expr expr);
70.2236 - val ((parms, all_elemss, _), (_, (_, defs, _))) =
70.2237 - read_elemss false ctxt' [] (raw_params_elemss @ raw_elemss) [];
70.2238 -
70.2239 - (** compute instantiation **)
70.2240 -
70.2241 - (* consistency check: equations need to be stored in a particular locale,
70.2242 - therefore if equations are present locale expression must be a name *)
70.2243 -
70.2244 - val _ = case (expr, snd raw_insts) of
70.2245 - (Locale _, _) => () | (_, []) => ()
70.2246 - | (_, _) => error "Interpretations with `where' only permitted if locale expression is a name.";
70.2247 -
70.2248 - (* read or certify instantiation *)
70.2249 - val (raw_insts', raw_eqns) = raw_insts;
70.2250 - val (raw_eq_attns, raw_eqns') = split_list raw_eqns;
70.2251 - val (((instT, inst1), eqns), morphs) = prep_insts ctxt parms (raw_insts', raw_eqns');
70.2252 - val eq_attns = map prep_attn raw_eq_attns;
70.2253 -
70.2254 - (* defined params without given instantiation *)
70.2255 - val not_given = filter_out (Symtab.defined inst1 o fst) parms;
70.2256 - fun add_def (p, pT) inst =
70.2257 - let
70.2258 - val (t, T) = case find_first (fn (Free (a, _), _) => a = p) defs of
70.2259 - NONE => error ("Instance missing for parameter " ^ quote p)
70.2260 - | SOME (Free (_, T), t) => (t, T);
70.2261 - val d = Element.inst_term (instT, inst) t;
70.2262 - in Symtab.update_new (p, d) inst end;
70.2263 - val inst2 = fold add_def not_given inst1;
70.2264 - val inst_morphism = Element.inst_morphism thy (instT, inst2);
70.2265 - (* Note: insts contain no vars. *)
70.2266 -
70.2267 - (** compute proof obligations **)
70.2268 -
70.2269 - (* restore "small" ids *)
70.2270 - val ids' = map (fn ((n, ps), (_, mode)) =>
70.2271 - ((n, map (fn p => Free (p, (the o AList.lookup (op =) parms) p)) ps), mode))
70.2272 - ids;
70.2273 - val (_, all_elemss') = chop (length raw_params_elemss) all_elemss
70.2274 - (* instantiate ids and elements *)
70.2275 - val inst_elemss = (ids' ~~ all_elemss') |> map (fn (((n, ps), _), ((_, mode), elems)) =>
70.2276 - ((n, map (Morphism.term (inst_morphism $> fst morphs)) ps),
70.2277 - map (fn Int e => Element.morph_ctxt inst_morphism e) elems)
70.2278 - |> apfst (fn id => (id, map_mode (map (Element.morph_witness inst_morphism)) mode)));
70.2279 -
70.2280 - (* equations *)
70.2281 - val eqn_elems = if null eqns then []
70.2282 - else [(Library.last_elem inst_elemss |> fst |> fst, eqns)];
70.2283 -
70.2284 - val propss = map extract_asms_elems inst_elemss @ eqn_elems;
70.2285 -
70.2286 - in
70.2287 - (propss, activate phi_name inst_elemss (map (snd o fst) ids) propss eq_attns morphs, morphs)
70.2288 - end;
70.2289 -
70.2290 -fun gen_prep_global_registration mk_ctxt = gen_prep_registration ProofContext.init
70.2291 - test_global_registration
70.2292 - global_activate_facts_elemss mk_ctxt;
70.2293 -
70.2294 -fun gen_prep_local_registration mk_ctxt = gen_prep_registration I
70.2295 - test_local_registration
70.2296 - local_activate_facts_elemss mk_ctxt;
70.2297 -
70.2298 -val prep_global_registration = gen_prep_global_registration
70.2299 - (K I) (K I) check_instantiations;
70.2300 -val prep_global_registration_cmd = gen_prep_global_registration
70.2301 - Attrib.intern_src intern_expr read_instantiations;
70.2302 -
70.2303 -val prep_local_registration = gen_prep_local_registration
70.2304 - (K I) (K I) check_instantiations;
70.2305 -val prep_local_registration_cmd = gen_prep_local_registration
70.2306 - Attrib.intern_src intern_expr read_instantiations;
70.2307 -
70.2308 -fun prep_registration_in_locale target expr thy =
70.2309 - (* target already in internal form *)
70.2310 - let
70.2311 - val ctxt = ProofContext.init thy;
70.2312 - val ((raw_target_ids, target_syn), _) = flatten (ctxt, I)
70.2313 - (([], Symtab.empty), Expr (Locale target));
70.2314 - val fixed = the_locale thy target |> #params |> map #1;
70.2315 - val ((all_ids, syn), raw_elemss) = flatten (ctxt, intern_expr thy)
70.2316 - ((raw_target_ids, target_syn), Expr expr);
70.2317 - val (target_ids, ids) = chop (length raw_target_ids) all_ids;
70.2318 - val ((parms, elemss, _), _) = read_elemss false ctxt fixed raw_elemss [];
70.2319 -
70.2320 - (** compute proof obligations **)
70.2321 -
70.2322 - (* restore "small" ids, with mode *)
70.2323 - val ids' = map (apsnd snd) ids;
70.2324 - (* remove Int markers *)
70.2325 - val elemss' = map (fn (_, es) =>
70.2326 - map (fn Int e => e) es) elemss
70.2327 - (* extract assumptions and defs *)
70.2328 - val ids_elemss = ids' ~~ elemss';
70.2329 - val propss = map extract_asms_elems ids_elemss;
70.2330 -
70.2331 - (** activation function:
70.2332 - - add registrations to the target locale
70.2333 - - add induced registrations for all global registrations of
70.2334 - the target, unless already present
70.2335 - - add facts of induced registrations to theory **)
70.2336 -
70.2337 - fun activate thmss thy =
70.2338 - let
70.2339 - val satisfy = Element.satisfy_thm (flat thmss);
70.2340 - val ids_elemss_thmss = ids_elemss ~~ thmss;
70.2341 - val regs = get_global_registrations thy target;
70.2342 -
70.2343 - fun activate_id (((id, Assumed _), _), thms) thy =
70.2344 - thy |> put_registration_in_locale target id
70.2345 - |> fold (add_witness_in_locale target id) thms
70.2346 - | activate_id _ thy = thy;
70.2347 -
70.2348 - fun activate_reg (ext_ts, ((phi_name, param_prfx), (exp, imp), _, _)) thy =
70.2349 - let
70.2350 - val (insts, wits, _) = collect_witnesses (ProofContext.init thy) imp fixed target_ids ext_ts;
70.2351 - val inst_parms = map (the o AList.lookup (op =) (map #1 fixed ~~ ext_ts));
70.2352 - val disch = Element.satisfy_thm wits;
70.2353 - val new_elemss = filter (fn (((name, ps), _), _) =>
70.2354 - not (test_global_registration thy (name, inst_parms ps))) (ids_elemss);
70.2355 - fun activate_assumed_id (((_, Derived _), _), _) thy = thy
70.2356 - | activate_assumed_id ((((name, ps), Assumed _), _), thms) thy = let
70.2357 - val ps' = inst_parms ps;
70.2358 - in
70.2359 - if test_global_registration thy (name, ps')
70.2360 - then thy
70.2361 - else thy
70.2362 - |> put_global_registration (name, ps') (phi_name, param_prefix name ps) (exp, imp)
70.2363 - |> fold (fn witn => fn thy => add_global_witness (name, ps')
70.2364 - (Element.morph_witness (Element.inst_morphism thy insts) witn) thy) thms
70.2365 - end;
70.2366 -
70.2367 - fun activate_derived_id ((_, Assumed _), _) thy = thy
70.2368 - | activate_derived_id (((name, ps), Derived ths), _) thy = let
70.2369 - val ps' = inst_parms ps;
70.2370 - in
70.2371 - if test_global_registration thy (name, ps')
70.2372 - then thy
70.2373 - else thy
70.2374 - |> put_global_registration (name, ps') (phi_name, param_prefix name ps) (exp, imp)
70.2375 - |> fold (fn witn => fn thy => add_global_witness (name, ps')
70.2376 - (witn |> Element.map_witness (fn (t, th) => (* FIXME *)
70.2377 - (Element.inst_term insts t,
70.2378 - disch (Element.inst_thm thy insts (satisfy th))))) thy) ths
70.2379 - end;
70.2380 -
70.2381 - fun activate_elem (loc, ps) (Notes (kind, facts)) thy =
70.2382 - let
70.2383 - val att_morphism =
70.2384 - Morphism.binding_morphism (name_morph phi_name param_prfx) $>
70.2385 - Morphism.thm_morphism satisfy $>
70.2386 - Element.inst_morphism thy insts $>
70.2387 - Morphism.thm_morphism disch;
70.2388 - val facts' = facts
70.2389 - |> Attrib.map_facts (Attrib.attribute_i thy o Args.morph_values att_morphism)
70.2390 - |> (map o apsnd o map o apfst o map) (disch o Element.inst_thm thy insts o satisfy)
70.2391 - |> (map o apfst o apfst) (name_morph phi_name param_prfx);
70.2392 - in
70.2393 - thy
70.2394 - |> global_note_qualified kind facts'
70.2395 - |> snd
70.2396 - end
70.2397 - | activate_elem _ _ thy = thy;
70.2398 -
70.2399 - fun activate_elems ((id, _), elems) thy = fold (activate_elem id) elems thy;
70.2400 -
70.2401 - in thy |> fold activate_assumed_id ids_elemss_thmss
70.2402 - |> fold activate_derived_id ids_elemss
70.2403 - |> fold activate_elems new_elemss end;
70.2404 - in
70.2405 - thy |> fold activate_id ids_elemss_thmss
70.2406 - |> fold activate_reg regs
70.2407 - end;
70.2408 -
70.2409 - in (propss, activate) end;
70.2410 -
70.2411 -fun prep_propp propss = propss |> map (fn (_, props) =>
70.2412 - map (rpair [] o Element.mark_witness) props);
70.2413 -
70.2414 -fun prep_result propps thmss =
70.2415 - ListPair.map (fn ((_, props), thms) => map2 Element.make_witness props thms) (propps, thmss);
70.2416 -
70.2417 -fun gen_interpretation prep_registration after_qed prfx raw_expr raw_insts thy =
70.2418 - let
70.2419 - val (propss, activate, morphs) = prep_registration thy prfx raw_expr raw_insts;
70.2420 - fun after_qed' results =
70.2421 - ProofContext.theory (activate (prep_result propss results))
70.2422 - #> after_qed;
70.2423 - in
70.2424 - thy
70.2425 - |> ProofContext.init
70.2426 - |> Proof.theorem_i NONE after_qed' (prep_propp propss)
70.2427 - |> Element.refine_witness
70.2428 - |> Seq.hd
70.2429 - |> pair morphs
70.2430 - end;
70.2431 -
70.2432 -fun gen_interpret prep_registration after_qed name_morph expr insts int state =
70.2433 - let
70.2434 - val _ = Proof.assert_forward_or_chain state;
70.2435 - val ctxt = Proof.context_of state;
70.2436 - val (propss, activate, morphs) = prep_registration ctxt name_morph expr insts;
70.2437 - fun after_qed' results =
70.2438 - Proof.map_context (K (ctxt |> activate (prep_result propss results)))
70.2439 - #> Proof.put_facts NONE
70.2440 - #> after_qed;
70.2441 - in
70.2442 - state
70.2443 - |> Proof.local_goal (ProofDisplay.print_results int) (K I) ProofContext.bind_propp_i
70.2444 - "interpret" NONE after_qed' (map (pair (Binding.empty, [])) (prep_propp propss))
70.2445 - |> Element.refine_witness |> Seq.hd
70.2446 - |> pair morphs
70.2447 - end;
70.2448 -
70.2449 -fun standard_name_morph interp_prfx b =
70.2450 - if Binding.is_empty b then b
70.2451 - else Binding.map_prefix (fn ((lprfx, _) :: pprfx) =>
70.2452 - fold (Binding.add_prefix false o fst) pprfx
70.2453 - #> interp_prfx <> "" ? Binding.add_prefix true interp_prfx
70.2454 - #> Binding.add_prefix false lprfx
70.2455 - ) b;
70.2456 -
70.2457 -in
70.2458 -
70.2459 -val interpretation = gen_interpretation prep_global_registration;
70.2460 -fun interpretation_cmd interp_prfx = snd ooo gen_interpretation prep_global_registration_cmd
70.2461 - I (standard_name_morph interp_prfx);
70.2462 -
70.2463 -fun interpretation_in_locale after_qed (raw_target, expr) thy =
70.2464 - let
70.2465 - val target = intern thy raw_target;
70.2466 - val (propss, activate) = prep_registration_in_locale target expr thy;
70.2467 - val raw_propp = prep_propp propss;
70.2468 -
70.2469 - val (_, _, goal_ctxt, propp) = thy
70.2470 - |> ProofContext.init
70.2471 - |> cert_context_statement (SOME target) [] raw_propp;
70.2472 -
70.2473 - fun after_qed' results =
70.2474 - ProofContext.theory (activate (prep_result propss results))
70.2475 - #> after_qed;
70.2476 - in
70.2477 - goal_ctxt
70.2478 - |> Proof.theorem_i NONE after_qed' propp
70.2479 - |> Element.refine_witness |> Seq.hd
70.2480 - end;
70.2481 -
70.2482 -val interpret = gen_interpret prep_local_registration;
70.2483 -fun interpret_cmd interp_prfx = snd oooo gen_interpret prep_local_registration_cmd
70.2484 - I (standard_name_morph interp_prfx);
70.2485 -
70.2486 -end;
70.2487 -
70.2488 -end;
71.1 --- a/src/Pure/Isar/outer_parse.ML Wed Jan 21 15:26:02 2009 +0100
71.2 +++ b/src/Pure/Isar/outer_parse.ML Wed Jan 21 20:05:31 2009 +0100
71.3 @@ -61,12 +61,12 @@
71.4 val list: 'a parser -> 'a list parser
71.5 val list1: 'a parser -> 'a list parser
71.6 val name: bstring parser
71.7 - val binding: Binding.T parser
71.8 + val binding: binding parser
71.9 val xname: xstring parser
71.10 val text: string parser
71.11 val path: Path.T parser
71.12 val parname: string parser
71.13 - val parbinding: Binding.T parser
71.14 + val parbinding: binding parser
71.15 val sort: string parser
71.16 val arity: (string * string list * string) parser
71.17 val multi_arity: (string list * string list * string) parser
71.18 @@ -81,11 +81,11 @@
71.19 val opt_mixfix': mixfix parser
71.20 val where_: string parser
71.21 val const: (string * string * mixfix) parser
71.22 - val params: (Binding.T * string option) list parser
71.23 - val simple_fixes: (Binding.T * string option) list parser
71.24 - val fixes: (Binding.T * string option * mixfix) list parser
71.25 - val for_fixes: (Binding.T * string option * mixfix) list parser
71.26 - val for_simple_fixes: (Binding.T * string option) list parser
71.27 + val params: (binding * string option) list parser
71.28 + val simple_fixes: (binding * string option) list parser
71.29 + val fixes: (binding * string option * mixfix) list parser
71.30 + val for_fixes: (binding * string option * mixfix) list parser
71.31 + val for_simple_fixes: (binding * string option) list parser
71.32 val ML_source: (SymbolPos.text * Position.T) parser
71.33 val doc_source: (SymbolPos.text * Position.T) parser
71.34 val term_group: string parser
72.1 --- a/src/Pure/Isar/overloading.ML Wed Jan 21 15:26:02 2009 +0100
72.2 +++ b/src/Pure/Isar/overloading.ML Wed Jan 21 20:05:31 2009 +0100
72.3 @@ -134,8 +134,8 @@
72.4
72.5 fun declare c_ty = pair (Const c_ty);
72.6
72.7 -fun define checked name (c, t) =
72.8 - Thm.add_def (not checked) true (name, Logic.mk_equals (Const (c, Term.fastype_of t), t));
72.9 +fun define checked name (c, t) = Thm.add_def (not checked) true (Binding.name name,
72.10 + Logic.mk_equals (Const (c, Term.fastype_of t), t));
72.11
72.12
72.13 (* target *)
73.1 --- a/src/Pure/Isar/proof.ML Wed Jan 21 15:26:02 2009 +0100
73.2 +++ b/src/Pure/Isar/proof.ML Wed Jan 21 20:05:31 2009 +0100
73.3 @@ -43,27 +43,27 @@
73.4 val match_bind_i: (term list * term) list -> state -> state
73.5 val let_bind: (string list * string) list -> state -> state
73.6 val let_bind_i: (term list * term) list -> state -> state
73.7 - val fix: (Binding.T * string option * mixfix) list -> state -> state
73.8 - val fix_i: (Binding.T * typ option * mixfix) list -> state -> state
73.9 + val fix: (binding * string option * mixfix) list -> state -> state
73.10 + val fix_i: (binding * typ option * mixfix) list -> state -> state
73.11 val assm: Assumption.export ->
73.12 (Attrib.binding * (string * string list) list) list -> state -> state
73.13 val assm_i: Assumption.export ->
73.14 - ((Binding.T * attribute list) * (term * term list) list) list -> state -> state
73.15 + ((binding * attribute list) * (term * term list) list) list -> state -> state
73.16 val assume: (Attrib.binding * (string * string list) list) list -> state -> state
73.17 - val assume_i: ((Binding.T * attribute list) * (term * term list) list) list ->
73.18 + val assume_i: ((binding * attribute list) * (term * term list) list) list ->
73.19 state -> state
73.20 val presume: (Attrib.binding * (string * string list) list) list -> state -> state
73.21 - val presume_i: ((Binding.T * attribute list) * (term * term list) list) list ->
73.22 + val presume_i: ((binding * attribute list) * (term * term list) list) list ->
73.23 state -> state
73.24 - val def: (Attrib.binding * ((Binding.T * mixfix) * (string * string list))) list ->
73.25 + val def: (Attrib.binding * ((binding * mixfix) * (string * string list))) list ->
73.26 state -> state
73.27 - val def_i: ((Binding.T * attribute list) *
73.28 - ((Binding.T * mixfix) * (term * term list))) list -> state -> state
73.29 + val def_i: ((binding * attribute list) *
73.30 + ((binding * mixfix) * (term * term list))) list -> state -> state
73.31 val chain: state -> state
73.32 val chain_facts: thm list -> state -> state
73.33 val get_thmss: state -> (Facts.ref * Attrib.src list) list -> thm list
73.34 val note_thmss: (Attrib.binding * (Facts.ref * Attrib.src list) list) list -> state -> state
73.35 - val note_thmss_i: ((Binding.T * attribute list) *
73.36 + val note_thmss_i: ((binding * attribute list) *
73.37 (thm list * attribute list) list) list -> state -> state
73.38 val from_thmss: ((Facts.ref * Attrib.src list) list) list -> state -> state
73.39 val from_thmss_i: ((thm list * attribute list) list) list -> state -> state
73.40 @@ -87,7 +87,7 @@
73.41 (theory -> 'a -> attribute) ->
73.42 (context * 'b list -> context * (term list list * (context -> context))) ->
73.43 string -> Method.text option -> (thm list list -> state -> state) ->
73.44 - ((Binding.T * 'a list) * 'b) list -> state -> state
73.45 + ((binding * 'a list) * 'b) list -> state -> state
73.46 val local_qed: Method.text option * bool -> state -> state
73.47 val theorem: Method.text option -> (thm list list -> context -> context) ->
73.48 (string * string list) list list -> context -> state
73.49 @@ -107,11 +107,11 @@
73.50 val have: Method.text option -> (thm list list -> state -> state) ->
73.51 (Attrib.binding * (string * string list) list) list -> bool -> state -> state
73.52 val have_i: Method.text option -> (thm list list -> state -> state) ->
73.53 - ((Binding.T * attribute list) * (term * term list) list) list -> bool -> state -> state
73.54 + ((binding * attribute list) * (term * term list) list) list -> bool -> state -> state
73.55 val show: Method.text option -> (thm list list -> state -> state) ->
73.56 (Attrib.binding * (string * string list) list) list -> bool -> state -> state
73.57 val show_i: Method.text option -> (thm list list -> state -> state) ->
73.58 - ((Binding.T * attribute list) * (term * term list) list) list -> bool -> state -> state
73.59 + ((binding * attribute list) * (term * term list) list) list -> bool -> state -> state
73.60 val schematic_goal: state -> bool
73.61 val is_relevant: state -> bool
73.62 val local_future_proof: (state -> ('a * state) Future.future) ->
74.1 --- a/src/Pure/Isar/proof_context.ML Wed Jan 21 15:26:02 2009 +0100
74.2 +++ b/src/Pure/Isar/proof_context.ML Wed Jan 21 20:05:31 2009 +0100
74.3 @@ -23,7 +23,7 @@
74.4 val abbrev_mode: Proof.context -> bool
74.5 val set_stmt: bool -> Proof.context -> Proof.context
74.6 val naming_of: Proof.context -> NameSpace.naming
74.7 - val full_name: Proof.context -> Binding.T -> string
74.8 + val full_name: Proof.context -> binding -> string
74.9 val full_bname: Proof.context -> bstring -> string
74.10 val consts_of: Proof.context -> Consts.T
74.11 val const_syntax_name: Proof.context -> string -> string
74.12 @@ -105,27 +105,27 @@
74.13 val restore_naming: Proof.context -> Proof.context -> Proof.context
74.14 val reset_naming: Proof.context -> Proof.context
74.15 val note_thmss: string ->
74.16 - ((Binding.T * attribute list) * (Facts.ref * attribute list) list) list ->
74.17 + ((binding * attribute list) * (Facts.ref * attribute list) list) list ->
74.18 Proof.context -> (string * thm list) list * Proof.context
74.19 val note_thmss_i: string ->
74.20 - ((Binding.T * attribute list) * (thm list * attribute list) list) list ->
74.21 + ((binding * attribute list) * (thm list * attribute list) list) list ->
74.22 Proof.context -> (string * thm list) list * Proof.context
74.23 val put_thms: bool -> string * thm list option -> Proof.context -> Proof.context
74.24 - val read_vars: (Binding.T * string option * mixfix) list -> Proof.context ->
74.25 - (Binding.T * typ option * mixfix) list * Proof.context
74.26 - val cert_vars: (Binding.T * typ option * mixfix) list -> Proof.context ->
74.27 - (Binding.T * typ option * mixfix) list * Proof.context
74.28 - val add_fixes: (Binding.T * string option * mixfix) list ->
74.29 + val read_vars: (binding * string option * mixfix) list -> Proof.context ->
74.30 + (binding * typ option * mixfix) list * Proof.context
74.31 + val cert_vars: (binding * typ option * mixfix) list -> Proof.context ->
74.32 + (binding * typ option * mixfix) list * Proof.context
74.33 + val add_fixes: (binding * string option * mixfix) list ->
74.34 Proof.context -> string list * Proof.context
74.35 - val add_fixes_i: (Binding.T * typ option * mixfix) list ->
74.36 + val add_fixes_i: (binding * typ option * mixfix) list ->
74.37 Proof.context -> string list * Proof.context
74.38 val auto_fixes: Proof.context * (term list list * 'a) -> Proof.context * (term list list * 'a)
74.39 val bind_fixes: string list -> Proof.context -> (term -> term) * Proof.context
74.40 val add_assms: Assumption.export ->
74.41 - ((Binding.T * attribute list) * (string * string list) list) list ->
74.42 + ((binding * attribute list) * (string * string list) list) list ->
74.43 Proof.context -> (string * thm list) list * Proof.context
74.44 val add_assms_i: Assumption.export ->
74.45 - ((Binding.T * attribute list) * (term * term list) list) list ->
74.46 + ((binding * attribute list) * (term * term list) list) list ->
74.47 Proof.context -> (string * thm list) list * Proof.context
74.48 val add_cases: bool -> (string * RuleCases.T option) list -> Proof.context -> Proof.context
74.49 val apply_case: RuleCases.T -> Proof.context -> (string * term list) list * Proof.context
74.50 @@ -135,7 +135,7 @@
74.51 Context.generic -> Context.generic
74.52 val add_const_constraint: string * typ option -> Proof.context -> Proof.context
74.53 val add_abbrev: string -> Properties.T ->
74.54 - Binding.T * term -> Proof.context -> (term * term) * Proof.context
74.55 + binding * term -> Proof.context -> (term * term) * Proof.context
74.56 val revert_abbrev: string -> string -> Proof.context -> Proof.context
74.57 val verbose: bool ref
74.58 val setmp_verbose: ('a -> 'b) -> 'a -> 'b
75.1 --- a/src/Pure/Isar/spec_parse.ML Wed Jan 21 15:26:02 2009 +0100
75.2 +++ b/src/Pure/Isar/spec_parse.ML Wed Jan 21 20:05:31 2009 +0100
75.3 @@ -15,24 +15,23 @@
75.4 val opt_thm_name: string -> Attrib.binding parser
75.5 val spec: (Attrib.binding * string list) parser
75.6 val named_spec: (Attrib.binding * string list) parser
75.7 - val spec_name: ((Binding.T * string) * Attrib.src list) parser
75.8 - val spec_opt_name: ((Binding.T * string) * Attrib.src list) parser
75.9 + val spec_name: ((binding * string) * Attrib.src list) parser
75.10 + val spec_opt_name: ((binding * string) * Attrib.src list) parser
75.11 val xthm: (Facts.ref * Attrib.src list) parser
75.12 val xthms1: (Facts.ref * Attrib.src list) list parser
75.13 val name_facts: (Attrib.binding * (Facts.ref * Attrib.src list) list) list parser
75.14 val locale_mixfix: mixfix parser
75.15 - val locale_fixes: (Binding.T * string option * mixfix) list parser
75.16 + val locale_fixes: (binding * string option * mixfix) list parser
75.17 val locale_insts: (string option list * (Attrib.binding * string) list) parser
75.18 val class_expr: string list parser
75.19 - val locale_expr: Old_Locale.expr parser
75.20 - val locale_expression: Expression.expression parser
75.21 + val locale_expression: Expression.expression parser
75.22 val locale_keyword: string parser
75.23 val context_element: Element.context parser
75.24 val statement: (Attrib.binding * (string * string list) list) list parser
75.25 val general_statement: (Element.context list * Element.statement) parser
75.26 val statement_keyword: string parser
75.27 val specification:
75.28 - (Binding.T * ((Attrib.binding * string list) list * (Binding.T * string option) list)) list parser
75.29 + (binding * ((Attrib.binding * string list) list * (binding * string option) list)) list parser
75.30 end;
75.31
75.32 structure SpecParse: SPEC_PARSE =
75.33 @@ -115,13 +114,6 @@
75.34
75.35 val class_expr = plus1_unless locale_keyword P.xname;
75.36
75.37 -val locale_expr =
75.38 - let
75.39 - fun expr2 x = (P.xname >> Old_Locale.Locale || P.$$$ "(" |-- P.!!! (expr0 --| P.$$$ ")")) x
75.40 - and expr1 x = (expr2 -- Scan.repeat1 (P.maybe rename) >> Old_Locale.Rename || expr2) x
75.41 - and expr0 x = (plus1_unless locale_keyword expr1 >> (fn [e] => e | es => Old_Locale.Merge es)) x;
75.42 - in expr0 end;
75.43 -
75.44 val locale_expression =
75.45 let
75.46 fun expr2 x = P.xname x;
76.1 --- a/src/Pure/Isar/specification.ML Wed Jan 21 15:26:02 2009 +0100
76.2 +++ b/src/Pure/Isar/specification.ML Wed Jan 21 20:05:31 2009 +0100
76.3 @@ -9,33 +9,33 @@
76.4 signature SPECIFICATION =
76.5 sig
76.6 val print_consts: local_theory -> (string * typ -> bool) -> (string * typ) list -> unit
76.7 - val check_specification: (Binding.T * typ option * mixfix) list ->
76.8 + val check_specification: (binding * typ option * mixfix) list ->
76.9 (Attrib.binding * term list) list list -> Proof.context ->
76.10 - (((Binding.T * typ) * mixfix) list * (Attrib.binding * term list) list) * Proof.context
76.11 - val read_specification: (Binding.T * string option * mixfix) list ->
76.12 + (((binding * typ) * mixfix) list * (Attrib.binding * term list) list) * Proof.context
76.13 + val read_specification: (binding * string option * mixfix) list ->
76.14 (Attrib.binding * string list) list list -> Proof.context ->
76.15 - (((Binding.T * typ) * mixfix) list * (Attrib.binding * term list) list) * Proof.context
76.16 - val check_free_specification: (Binding.T * typ option * mixfix) list ->
76.17 + (((binding * typ) * mixfix) list * (Attrib.binding * term list) list) * Proof.context
76.18 + val check_free_specification: (binding * typ option * mixfix) list ->
76.19 (Attrib.binding * term list) list -> Proof.context ->
76.20 - (((Binding.T * typ) * mixfix) list * (Attrib.binding * term list) list) * Proof.context
76.21 - val read_free_specification: (Binding.T * string option * mixfix) list ->
76.22 + (((binding * typ) * mixfix) list * (Attrib.binding * term list) list) * Proof.context
76.23 + val read_free_specification: (binding * string option * mixfix) list ->
76.24 (Attrib.binding * string list) list -> Proof.context ->
76.25 - (((Binding.T * typ) * mixfix) list * (Attrib.binding * term list) list) * Proof.context
76.26 - val axiomatization: (Binding.T * typ option * mixfix) list ->
76.27 + (((binding * typ) * mixfix) list * (Attrib.binding * term list) list) * Proof.context
76.28 + val axiomatization: (binding * typ option * mixfix) list ->
76.29 (Attrib.binding * term list) list -> theory ->
76.30 (term list * (string * thm list) list) * theory
76.31 - val axiomatization_cmd: (Binding.T * string option * mixfix) list ->
76.32 + val axiomatization_cmd: (binding * string option * mixfix) list ->
76.33 (Attrib.binding * string list) list -> theory ->
76.34 (term list * (string * thm list) list) * theory
76.35 val definition:
76.36 - (Binding.T * typ option * mixfix) option * (Attrib.binding * term) ->
76.37 + (binding * typ option * mixfix) option * (Attrib.binding * term) ->
76.38 local_theory -> (term * (string * thm)) * local_theory
76.39 val definition_cmd:
76.40 - (Binding.T * string option * mixfix) option * (Attrib.binding * string) ->
76.41 + (binding * string option * mixfix) option * (Attrib.binding * string) ->
76.42 local_theory -> (term * (string * thm)) * local_theory
76.43 - val abbreviation: Syntax.mode -> (Binding.T * typ option * mixfix) option * term ->
76.44 + val abbreviation: Syntax.mode -> (binding * typ option * mixfix) option * term ->
76.45 local_theory -> local_theory
76.46 - val abbreviation_cmd: Syntax.mode -> (Binding.T * string option * mixfix) option * string ->
76.47 + val abbreviation_cmd: Syntax.mode -> (binding * string option * mixfix) option * string ->
76.48 local_theory -> local_theory
76.49 val notation: bool -> Syntax.mode -> (term * mixfix) list -> local_theory -> local_theory
76.50 val notation_cmd: bool -> Syntax.mode -> (string * mixfix) list -> local_theory -> local_theory
76.51 @@ -149,7 +149,8 @@
76.52
76.53 (*axioms*)
76.54 val (axioms, axioms_thy) = consts_thy |> fold_map (fn ((b, atts), props) =>
76.55 - fold_map Thm.add_axiom (PureThy.name_multi (Binding.base_name b) (map subst props))
76.56 + fold_map Thm.add_axiom
76.57 + ((map o apfst) Binding.name (PureThy.name_multi (Binding.base_name b) (map subst props)))
76.58 #>> (fn ths => ((b, atts), [(map Drule.standard' ths, [])]))) specs;
76.59 val (facts, thy') = axioms_thy |> PureThy.note_thmss Thm.axiomK
76.60 (Attrib.map_facts (Attrib.attribute_i axioms_thy) axioms);
77.1 --- a/src/Pure/Isar/theory_target.ML Wed Jan 21 15:26:02 2009 +0100
77.2 +++ b/src/Pure/Isar/theory_target.ML Wed Jan 21 20:05:31 2009 +0100
77.3 @@ -6,7 +6,7 @@
77.4
77.5 signature THEORY_TARGET =
77.6 sig
77.7 - val peek: local_theory -> {target: string, new_locale: bool, is_locale: bool,
77.8 + val peek: local_theory -> {target: string, is_locale: bool,
77.9 is_class: bool, instantiation: string list * (string * sort) list * sort,
77.10 overloading: (string * (string * typ) * bool) list}
77.11 val init: string option -> theory -> local_theory
77.12 @@ -21,34 +21,17 @@
77.13 structure TheoryTarget: THEORY_TARGET =
77.14 struct
77.15
77.16 -(* new locales *)
77.17 -
77.18 -fun locale_extern new_locale x =
77.19 - if new_locale then Locale.extern x else Old_Locale.extern x;
77.20 -fun locale_add_type_syntax new_locale x =
77.21 - if new_locale then Locale.add_type_syntax x else Old_Locale.add_type_syntax x;
77.22 -fun locale_add_term_syntax new_locale x =
77.23 - if new_locale then Locale.add_term_syntax x else Old_Locale.add_term_syntax x;
77.24 -fun locale_add_declaration new_locale x =
77.25 - if new_locale then Locale.add_declaration x else Old_Locale.add_declaration x;
77.26 -fun locale_add_thmss new_locale x =
77.27 - if new_locale then Locale.add_thmss x else Old_Locale.add_thmss x;
77.28 -fun locale_init new_locale x =
77.29 - if new_locale then Locale.init x else Old_Locale.init x;
77.30 -fun locale_intern new_locale x =
77.31 - if new_locale then Locale.intern x else Old_Locale.intern x;
77.32 -
77.33 (* context data *)
77.34
77.35 -datatype target = Target of {target: string, new_locale: bool, is_locale: bool,
77.36 +datatype target = Target of {target: string, is_locale: bool,
77.37 is_class: bool, instantiation: string list * (string * sort) list * sort,
77.38 overloading: (string * (string * typ) * bool) list};
77.39
77.40 -fun make_target target new_locale is_locale is_class instantiation overloading =
77.41 - Target {target = target, new_locale = new_locale, is_locale = is_locale,
77.42 +fun make_target target is_locale is_class instantiation overloading =
77.43 + Target {target = target, is_locale = is_locale,
77.44 is_class = is_class, instantiation = instantiation, overloading = overloading};
77.45
77.46 -val global_target = make_target "" false false false ([], [], []) [];
77.47 +val global_target = make_target "" false false ([], [], []) [];
77.48
77.49 structure Data = ProofDataFun
77.50 (
77.51 @@ -64,7 +47,7 @@
77.52 fun pretty_thy ctxt target is_locale is_class =
77.53 let
77.54 val thy = ProofContext.theory_of ctxt;
77.55 - val target_name = (if is_class then "class " else "locale ") ^ locale_extern is_class thy target;
77.56 + val target_name = (if is_class then "class " else "locale ") ^ Locale.extern thy target;
77.57 val fixes = map (fn (x, T) => (Binding.name x, SOME T, NoSyn))
77.58 (#1 (ProofContext.inferred_fixes ctxt));
77.59 val assumes = map (fn A => (Attrib.empty_binding, [(Thm.term_of A, [])]))
77.60 @@ -89,7 +72,7 @@
77.61
77.62 (* target declarations *)
77.63
77.64 -fun target_decl add (Target {target, new_locale, ...}) d lthy =
77.65 +fun target_decl add (Target {target, ...}) d lthy =
77.66 let
77.67 val d' = Morphism.transform (LocalTheory.target_morphism lthy) d;
77.68 val d0 = Morphism.form d';
77.69 @@ -100,12 +83,12 @@
77.70 |> LocalTheory.target (Context.proof_map d0)
77.71 else
77.72 lthy
77.73 - |> LocalTheory.target (add new_locale target d')
77.74 + |> LocalTheory.target (add target d')
77.75 end;
77.76
77.77 -val type_syntax = target_decl locale_add_type_syntax;
77.78 -val term_syntax = target_decl locale_add_term_syntax;
77.79 -val declaration = target_decl locale_add_declaration;
77.80 +val type_syntax = target_decl Locale.add_type_syntax;
77.81 +val term_syntax = target_decl Locale.add_term_syntax;
77.82 +val declaration = target_decl Locale.add_declaration;
77.83
77.84 fun class_target (Target {target, ...}) f =
77.85 LocalTheory.raw_theory f #>
77.86 @@ -166,7 +149,7 @@
77.87 |> ProofContext.note_thmss_i kind facts
77.88 ||> ProofContext.restore_naming ctxt;
77.89
77.90 -fun notes (Target {target, is_locale, new_locale, ...}) kind facts lthy =
77.91 +fun notes (Target {target, is_locale, ...}) kind facts lthy =
77.92 let
77.93 val thy = ProofContext.theory_of lthy;
77.94 val facts' = facts
77.95 @@ -185,7 +168,7 @@
77.96 #> PureThy.note_thmss_grouped kind (LocalTheory.group_of lthy) global_facts #> snd
77.97 #> Sign.restore_naming thy)
77.98 |> not is_locale ? LocalTheory.target (note_local kind global_facts #> snd)
77.99 - |> is_locale ? LocalTheory.target (locale_add_thmss new_locale target kind target_facts)
77.100 + |> is_locale ? LocalTheory.target (Locale.add_thmss target kind target_facts)
77.101 |> note_local kind local_facts
77.102 end;
77.103
77.104 @@ -313,7 +296,7 @@
77.105 (fn name => fn (Const (c, _), rhs) => Overloading.define checked name (c, rhs))
77.106 | NONE =>
77.107 if is_none (Class_Target.instantiation_param lthy c)
77.108 - then (fn name => fn eq => Thm.add_def false false (name, Logic.mk_equals eq))
77.109 + then (fn name => fn eq => Thm.add_def false false (Binding.name name, Logic.mk_equals eq))
77.110 else (fn name => fn (Const (c, _), rhs) => AxClass.define_overloaded name (c, rhs)));
77.111 val (global_def, lthy3) = lthy2
77.112 |> LocalTheory.theory_result (define_const (Binding.base_name name') (lhs', rhs'));
77.113 @@ -335,13 +318,13 @@
77.114 fun init_target _ NONE = global_target
77.115 | init_target thy (SOME target) =
77.116 make_target target (Locale.defined thy (Locale.intern thy target))
77.117 - true (Class_Target.is_class thy target) ([], [], []) [];
77.118 + (Class_Target.is_class thy target) ([], [], []) [];
77.119
77.120 -fun init_ctxt (Target {target, new_locale, is_locale, is_class, instantiation, overloading}) =
77.121 +fun init_ctxt (Target {target, is_locale, is_class, instantiation, overloading}) =
77.122 if not (null (#1 instantiation)) then Class_Target.init_instantiation instantiation
77.123 else if not (null overloading) then Overloading.init overloading
77.124 else if not is_locale then ProofContext.init
77.125 - else if not is_class then locale_init new_locale target
77.126 + else if not is_class then Locale.init target
77.127 else Class_Target.init target;
77.128
77.129 fun init_lthy (ta as Target {target, instantiation, overloading, ...}) =
77.130 @@ -375,7 +358,7 @@
77.131 val ctxt = ProofContext.init thy;
77.132 val ops = raw_ops |> map (fn (name, const, checked) =>
77.133 (name, Term.dest_Const (prep_const ctxt const), checked));
77.134 - in thy |> init_lthy_ctxt (make_target "" false false false ([], [], []) ops) end;
77.135 + in thy |> init_lthy_ctxt (make_target "" false false ([], [], []) ops) end;
77.136
77.137 in
77.138
77.139 @@ -383,10 +366,9 @@
77.140 fun begin target ctxt = init_lthy (init_target (ProofContext.theory_of ctxt) (SOME target)) ctxt;
77.141
77.142 fun context "-" thy = init NONE thy
77.143 - | context target thy = init (SOME (locale_intern
77.144 - (Locale.defined thy (Locale.intern thy target)) thy target)) thy;
77.145 + | context target thy = init (SOME (Locale.intern thy target)) thy;
77.146
77.147 -fun instantiation arities = init_lthy_ctxt (make_target "" false false false arities []);
77.148 +fun instantiation arities = init_lthy_ctxt (make_target "" false false arities []);
77.149 fun instantiation_cmd raw_arities thy =
77.150 instantiation (read_multi_arity thy raw_arities) thy;
77.151
78.1 --- a/src/Pure/ML/ml_context.ML Wed Jan 21 15:26:02 2009 +0100
78.2 +++ b/src/Pure/ML/ml_context.ML Wed Jan 21 20:05:31 2009 +0100
78.3 @@ -126,7 +126,8 @@
78.4
78.5 fun ml_store sel (name, ths) =
78.6 let
78.7 - val ths' = Context.>>> (Context.map_theory_result (PureThy.store_thms (name, ths)));
78.8 + val ths' = Context.>>> (Context.map_theory_result
78.9 + (PureThy.store_thms (Binding.name name, ths)));
78.10 val _ =
78.11 if name = "" then ()
78.12 else if not (ML_Syntax.is_identifier name) then
79.1 --- a/src/Pure/Proof/extraction.ML Wed Jan 21 15:26:02 2009 +0100
79.2 +++ b/src/Pure/Proof/extraction.ML Wed Jan 21 20:05:31 2009 +0100
79.3 @@ -733,11 +733,11 @@
79.4 val (def_thms, thy') = if t = nullt then ([], thy) else
79.5 thy
79.6 |> Sign.add_consts_i [(extr_name s vs, fastype_of ft, NoSyn)]
79.7 - |> PureThy.add_defs false [((extr_name s vs ^ "_def",
79.8 + |> PureThy.add_defs false [((Binding.name (extr_name s vs ^ "_def"),
79.9 Logic.mk_equals (head_of (strip_abs_body fu), ft)), [])]
79.10 in
79.11 thy'
79.12 - |> PureThy.store_thm (corr_name s vs,
79.13 + |> PureThy.store_thm (Binding.name (corr_name s vs),
79.14 Thm.varifyT (funpow (length (OldTerm.term_vars corr_prop))
79.15 (Thm.forall_elim_var 0) (forall_intr_frees
79.16 (ProofChecker.thm_of_proof thy'
80.1 --- a/src/Pure/Tools/ROOT.ML Wed Jan 21 15:26:02 2009 +0100
80.2 +++ b/src/Pure/Tools/ROOT.ML Wed Jan 21 20:05:31 2009 +0100
80.3 @@ -9,8 +9,5 @@
80.4 (*basic XML support*)
80.5 use "xml_syntax.ML";
80.6
80.7 -(*derived theory and proof elements*)
80.8 -use "invoke.ML";
80.9 -
80.10 (*quickcheck needed here because of pg preferences*)
80.11 use "../../Tools/quickcheck.ML"
81.1 --- a/src/Pure/Tools/invoke.ML Wed Jan 21 15:26:02 2009 +0100
81.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
81.3 @@ -1,127 +0,0 @@
81.4 -(* Title: Pure/Tools/invoke.ML
81.5 - Author: Makarius
81.6 -
81.7 -Schematic invocation of locale expression in proof context.
81.8 -*)
81.9 -
81.10 -signature INVOKE =
81.11 -sig
81.12 - val invoke: string * Attrib.src list -> Old_Locale.expr -> string option list ->
81.13 - (Binding.T * string option * mixfix) list -> bool -> Proof.state -> Proof.state
81.14 - val invoke_i: string * attribute list -> Old_Locale.expr -> term option list ->
81.15 - (Binding.T * typ option * mixfix) list -> bool -> Proof.state -> Proof.state
81.16 -end;
81.17 -
81.18 -structure Invoke: INVOKE =
81.19 -struct
81.20 -
81.21 -
81.22 -(* invoke *)
81.23 -
81.24 -local
81.25 -
81.26 -fun gen_invoke prep_att prep_expr parse_term add_fixes
81.27 - (prfx, raw_atts) raw_expr raw_insts fixes int state =
81.28 - let
81.29 - val thy = Proof.theory_of state;
81.30 - val _ = Proof.assert_forward_or_chain state;
81.31 - val chain_facts = if can Proof.assert_chain state then Proof.the_facts state else [];
81.32 -
81.33 - val more_atts = map (prep_att thy) raw_atts;
81.34 - val (elems, _) = prep_expr raw_expr [] (ProofContext.init thy);
81.35 -
81.36 - val prems = maps Element.prems_of elems;
81.37 - val params = maps Element.params_of elems;
81.38 - val types = rev (fold Term.add_tfrees prems (fold (Term.add_tfreesT o #2) params []));
81.39 -
81.40 - val prems' = map Logic.varify prems;
81.41 - val params' = map (Logic.varify o Free) params;
81.42 - val types' = map (Logic.varifyT o TFree) types;
81.43 -
81.44 - val state' = state
81.45 - |> Proof.enter_forward
81.46 - |> Proof.begin_block
81.47 - |> Proof.map_context (snd o add_fixes fixes);
81.48 - val ctxt' = Proof.context_of state';
81.49 -
81.50 - val raw_insts' = zip_options params' raw_insts
81.51 - handle Library.UnequalLengths => error "Too many instantiations";
81.52 -
81.53 - fun prep_inst (t, u) =
81.54 - TypeInfer.constrain (TypeInfer.paramify_vars (Term.fastype_of t)) (parse_term ctxt' u);
81.55 - val insts = map #1 raw_insts' ~~
81.56 - Variable.polymorphic ctxt' (Syntax.check_terms ctxt' (map prep_inst raw_insts'));
81.57 - val inst_rules =
81.58 - replicate (length types') Drule.termI @
81.59 - map (fn t =>
81.60 - (case AList.lookup (op =) insts t of
81.61 - SOME u => Drule.mk_term (Thm.cterm_of thy u)
81.62 - | NONE => Drule.termI)) params';
81.63 -
81.64 - val propp =
81.65 - [((Binding.empty, []), map (rpair [] o Logic.mk_term o Logic.mk_type) types'),
81.66 - ((Binding.empty, []), map (rpair [] o Logic.mk_term) params'),
81.67 - ((Binding.empty, []), map (rpair [] o Element.mark_witness) prems')];
81.68 - fun after_qed results =
81.69 - Proof.end_block #>
81.70 - Proof.map_context (fn ctxt =>
81.71 - let
81.72 - val ([res_types, res_params, res_prems], ctxt'') =
81.73 - fold_burrow (apfst snd oo Variable.import_thms false) results ctxt';
81.74 -
81.75 - val types'' = map (Logic.dest_type o Thm.term_of o Drule.dest_term) res_types;
81.76 - val params'' = map (Thm.term_of o Drule.dest_term) res_params;
81.77 - val inst = Element.morph_ctxt (Element.inst_morphism thy
81.78 - (Symtab.make (map #1 types ~~ types''), Symtab.make (map #1 params ~~ params'')));
81.79 - val elems' = map inst elems;
81.80 - val prems'' = map2 Element.make_witness (maps Element.prems_of elems') res_prems;
81.81 - val notes =
81.82 - maps (Element.facts_of thy) elems'
81.83 - |> Element.satisfy_facts prems''
81.84 - |> Element.generalize_facts ctxt'' ctxt
81.85 - |> Attrib.map_facts (Attrib.attribute_i thy)
81.86 - |> map (fn ((a, atts), bs) => ((a, atts @ more_atts), bs));
81.87 - in
81.88 - ctxt
81.89 - |> ProofContext.sticky_prefix prfx
81.90 - |> ProofContext.qualified_names
81.91 - |> (snd o ProofContext.note_thmss_i "" notes)
81.92 - |> ProofContext.restore_naming ctxt
81.93 - end) #>
81.94 - Proof.put_facts NONE;
81.95 - in
81.96 - state'
81.97 - |> Proof.chain_facts chain_facts
81.98 - |> Proof.local_goal (K (K ())) (K I) ProofContext.bind_propp_schematic_i
81.99 - "invoke" NONE after_qed propp
81.100 - |> Element.refine_witness
81.101 - |> Seq.hd
81.102 - |> Proof.refine (Method.Basic (K (Method.METHOD (K (HEADGOAL (RANGE (map rtac inst_rules))))),
81.103 - Position.none))
81.104 - |> Seq.hd
81.105 - end;
81.106 -
81.107 -in
81.108 -
81.109 -fun invoke x =
81.110 - gen_invoke Attrib.attribute Old_Locale.read_expr Syntax.parse_term ProofContext.add_fixes x;
81.111 -fun invoke_i x = gen_invoke (K I) Old_Locale.cert_expr (K I) ProofContext.add_fixes_i x;
81.112 -
81.113 -end;
81.114 -
81.115 -
81.116 -(* concrete syntax *)
81.117 -
81.118 -local structure P = OuterParse and K = OuterKeyword in
81.119 -
81.120 -val _ =
81.121 - OuterSyntax.command "invoke"
81.122 - "schematic invocation of locale expression in proof context"
81.123 - (K.tag_proof K.prf_goal)
81.124 - (SpecParse.opt_thm_name ":" -- SpecParse.locale_expr -- SpecParse.locale_insts -- P.for_fixes
81.125 - >> (fn ((((name, atts), expr), (insts, _)), fixes) =>
81.126 - Toplevel.print o Toplevel.proof' (invoke (Binding.base_name name, atts) expr insts fixes)));
81.127 -
81.128 -end;
81.129 -
81.130 -end;
82.1 --- a/src/Pure/Tools/named_thms.ML Wed Jan 21 15:26:02 2009 +0100
82.2 +++ b/src/Pure/Tools/named_thms.ML Wed Jan 21 20:05:31 2009 +0100
82.3 @@ -1,5 +1,4 @@
82.4 (* Title: Pure/Tools/named_thms.ML
82.5 - ID: $Id$
82.6 Author: Makarius
82.7
82.8 Named collections of theorems in canonical order.
82.9 @@ -36,6 +35,6 @@
82.10
82.11 val setup =
82.12 Attrib.add_attributes [(name, Attrib.add_del_args add del, "declaration of " ^ description)] #>
82.13 - PureThy.add_thms_dynamic (name, Data.get);
82.14 + PureThy.add_thms_dynamic (Binding.name name, Data.get);
82.15
82.16 end;
83.1 --- a/src/Pure/assumption.ML Wed Jan 21 15:26:02 2009 +0100
83.2 +++ b/src/Pure/assumption.ML Wed Jan 21 20:05:31 2009 +0100
83.3 @@ -1,5 +1,4 @@
83.4 (* Title: Pure/assumption.ML
83.5 - ID: $Id$
83.6 Author: Makarius
83.7
83.8 Local assumptions, parameterized by export rules.
83.9 @@ -79,7 +78,7 @@
83.10 (* named prems -- legacy feature *)
83.11
83.12 val _ = Context.>>
83.13 - (Context.map_theory (PureThy.add_thms_dynamic ("prems",
83.14 + (Context.map_theory (PureThy.add_thms_dynamic (Binding.name "prems",
83.15 fn Context.Theory _ => [] | Context.Proof ctxt => prems_of ctxt)));
83.16
83.17
84.1 --- a/src/Pure/axclass.ML Wed Jan 21 15:26:02 2009 +0100
84.2 +++ b/src/Pure/axclass.ML Wed Jan 21 20:05:31 2009 +0100
84.3 @@ -1,5 +1,4 @@
84.4 (* Title: Pure/axclass.ML
84.5 - ID: $Id$
84.6 Author: Markus Wenzel, TU Muenchen
84.7
84.8 Type classes defined as predicates, associated with a record of
84.9 @@ -9,7 +8,7 @@
84.10 signature AX_CLASS =
84.11 sig
84.12 val define_class: bstring * class list -> string list ->
84.13 - ((Binding.T * attribute list) * term list) list -> theory -> class * theory
84.14 + ((binding * attribute list) * term list) list -> theory -> class * theory
84.15 val add_classrel: thm -> theory -> theory
84.16 val add_arity: thm -> theory -> theory
84.17 val prove_classrel: class * class -> tactic -> theory -> theory
84.18 @@ -329,7 +328,8 @@
84.19 quote (Syntax.string_of_classrel ctxt [c1, c2]));
84.20 in
84.21 thy
84.22 - |> PureThy.add_thms [((prefix classrel_prefix (Logic.name_classrel (c1, c2)), th), [])]
84.23 + |> PureThy.add_thms [((Binding.name
84.24 + (prefix classrel_prefix (Logic.name_classrel (c1, c2))), th), [])]
84.25 |-> (fn [th'] => add_classrel th')
84.26 end;
84.27
84.28 @@ -345,7 +345,7 @@
84.29 quote (Syntax.string_of_arity ctxt arity));
84.30 in
84.31 thy
84.32 - |> PureThy.add_thms (map (rpair []) (names ~~ ths))
84.33 + |> PureThy.add_thms (map (rpair []) (map Binding.name names ~~ ths))
84.34 |-> fold add_arity
84.35 end;
84.36
84.37 @@ -372,10 +372,10 @@
84.38 |> Sign.no_base_names
84.39 |> Sign.declare_const [] ((Binding.name c', T'), NoSyn)
84.40 |-> (fn const' as Const (c'', _) => Thm.add_def false true
84.41 - (Thm.def_name c', Logic.mk_equals (Const (c, T'), const'))
84.42 + (Binding.name (Thm.def_name c'), Logic.mk_equals (Const (c, T'), const'))
84.43 #>> Thm.varifyT
84.44 #-> (fn thm => add_inst_param (c, tyco) (c'', thm)
84.45 - #> PureThy.add_thm ((c', thm), [Thm.kind_internal])
84.46 + #> PureThy.add_thm ((Binding.name c', thm), [Thm.kind_internal])
84.47 #> snd
84.48 #> Sign.restore_naming thy
84.49 #> pair (Const (c, T))))
84.50 @@ -391,7 +391,7 @@
84.51 (NameSpace.base c ^ "_" ^ NameSpace.base tyco) name;
84.52 in
84.53 thy
84.54 - |> Thm.add_def false false (name', prop)
84.55 + |> Thm.add_def false false (Binding.name name', prop)
84.56 |>> (fn thm => Drule.transitive_thm OF [eq, thm])
84.57 end;
84.58
84.59 @@ -469,7 +469,7 @@
84.60 val ([def], def_thy) =
84.61 thy
84.62 |> Sign.primitive_class (bclass, super)
84.63 - |> PureThy.add_defs false [((Thm.def_name bconst, class_eq), [])];
84.64 + |> PureThy.add_defs false [((Binding.name (Thm.def_name bconst), class_eq), [])];
84.65 val (raw_intro, (raw_classrel, raw_axioms)) =
84.66 split_defined (length conjs) def ||> chop (length super);
84.67
84.68 @@ -515,7 +515,11 @@
84.69 val args = prep thy raw_args;
84.70 val specs = mk args;
84.71 val names = name args;
84.72 - in thy |> PureThy.add_axioms (map (rpair []) (names ~~ specs)) |-> fold add end;
84.73 + in
84.74 + thy
84.75 + |> PureThy.add_axioms (map (rpair []) (map Binding.name names ~~ specs))
84.76 + |-> fold add
84.77 + end;
84.78
84.79 fun ax_classrel prep =
84.80 axiomatize (map o prep) (map Logic.mk_classrel)
85.1 --- a/src/Pure/consts.ML Wed Jan 21 15:26:02 2009 +0100
85.2 +++ b/src/Pure/consts.ML Wed Jan 21 20:05:31 2009 +0100
85.3 @@ -30,10 +30,10 @@
85.4 val certify: Pretty.pp -> Type.tsig -> bool -> T -> term -> term (*exception TYPE*)
85.5 val typargs: T -> string * typ -> typ list
85.6 val instance: T -> string * typ list -> typ
85.7 - val declare: bool -> NameSpace.naming -> Properties.T -> (Binding.T * typ) -> T -> T
85.8 + val declare: bool -> NameSpace.naming -> Properties.T -> (binding * typ) -> T -> T
85.9 val constrain: string * typ option -> T -> T
85.10 val abbreviate: Pretty.pp -> Type.tsig -> NameSpace.naming -> string -> Properties.T ->
85.11 - Binding.T * term -> T -> (term * term) * T
85.12 + binding * term -> T -> (term * term) * T
85.13 val revert_abbrev: string -> string -> T -> T
85.14 val hide: bool -> string -> T -> T
85.15 val empty: T
86.1 --- a/src/Pure/drule.ML Wed Jan 21 15:26:02 2009 +0100
86.2 +++ b/src/Pure/drule.ML Wed Jan 21 20:05:31 2009 +0100
86.3 @@ -460,10 +460,10 @@
86.4 val read_prop = certify o SimpleSyntax.read_prop;
86.5
86.6 fun store_thm name th =
86.7 - Context.>>> (Context.map_theory_result (PureThy.store_thm (name, th)));
86.8 + Context.>>> (Context.map_theory_result (PureThy.store_thm (Binding.name name, th)));
86.9
86.10 fun store_thm_open name th =
86.11 - Context.>>> (Context.map_theory_result (PureThy.store_thm_open (name, th)));
86.12 + Context.>>> (Context.map_theory_result (PureThy.store_thm_open (Binding.name name, th)));
86.13
86.14 fun store_standard_thm name th = store_thm name (standard th);
86.15 fun store_standard_thm_open name thm = store_thm_open name (standard' thm);
87.1 --- a/src/Pure/facts.ML Wed Jan 21 15:26:02 2009 +0100
87.2 +++ b/src/Pure/facts.ML Wed Jan 21 20:05:31 2009 +0100
87.3 @@ -30,9 +30,9 @@
87.4 val props: T -> thm list
87.5 val could_unify: T -> term -> thm list
87.6 val merge: T * T -> T
87.7 - val add_global: NameSpace.naming -> Binding.T * thm list -> T -> string * T
87.8 - val add_local: bool -> NameSpace.naming -> Binding.T * thm list -> T -> string * T
87.9 - val add_dynamic: NameSpace.naming -> Binding.T * (Context.generic -> thm list) -> T -> string * T
87.10 + val add_global: NameSpace.naming -> binding * thm list -> T -> string * T
87.11 + val add_local: bool -> NameSpace.naming -> binding * thm list -> T -> string * T
87.12 + val add_dynamic: NameSpace.naming -> binding * (Context.generic -> thm list) -> T -> string * T
87.13 val del: string -> T -> T
87.14 val hide: bool -> string -> T -> T
87.15 end;
88.1 --- a/src/Pure/more_thm.ML Wed Jan 21 15:26:02 2009 +0100
88.2 +++ b/src/Pure/more_thm.ML Wed Jan 21 20:05:31 2009 +0100
88.3 @@ -38,8 +38,8 @@
88.4 val forall_elim_vars: int -> thm -> thm
88.5 val unvarify: thm -> thm
88.6 val close_derivation: thm -> thm
88.7 - val add_axiom: bstring * term -> theory -> thm * theory
88.8 - val add_def: bool -> bool -> bstring * term -> theory -> thm * theory
88.9 + val add_axiom: binding * term -> theory -> thm * theory
88.10 + val add_def: bool -> bool -> binding * term -> theory -> thm * theory
88.11 val rule_attribute: (Context.generic -> thm -> thm) -> attribute
88.12 val declaration_attribute: (thm -> Context.generic -> Context.generic) -> attribute
88.13 val theory_attributes: attribute list -> theory * thm -> theory * thm
88.14 @@ -276,14 +276,15 @@
88.15
88.16 (** specification primitives **)
88.17
88.18 -fun add_axiom (name, prop) thy =
88.19 +fun add_axiom (b, prop) thy =
88.20 let
88.21 - val name' = if name = "" then "axiom_" ^ serial_string () else name;
88.22 - val thy' = thy |> Theory.add_axioms_i [(name', prop)];
88.23 - val axm = unvarify (Thm.axiom thy' (Sign.full_bname thy' name'));
88.24 + val b' = if Binding.is_empty b
88.25 + then Binding.name ("axiom_" ^ serial_string ()) else b;
88.26 + val thy' = thy |> Theory.add_axioms_i [(b', prop)];
88.27 + val axm = unvarify (Thm.axiom thy' (Sign.full_name thy' b'));
88.28 in (axm, thy') end;
88.29
88.30 -fun add_def unchecked overloaded (name, prop) thy =
88.31 +fun add_def unchecked overloaded (b, prop) thy =
88.32 let
88.33 val tfrees = rev (map TFree (Term.add_tfrees prop []));
88.34 val tfrees' = map (fn a => TFree (a, [])) (Name.invents Name.context Name.aT (length tfrees));
88.35 @@ -291,8 +292,8 @@
88.36 val recover_sorts = map (pairself (Thm.ctyp_of thy o Logic.varifyT)) (tfrees' ~~ tfrees);
88.37
88.38 val prop' = Term.map_types (Term.map_atyps (perhaps (AList.lookup (op =) strip_sorts))) prop;
88.39 - val thy' = Theory.add_defs_i unchecked overloaded [(name, prop')] thy;
88.40 - val axm' = Thm.axiom thy' (Sign.full_bname thy' name);
88.41 + val thy' = Theory.add_defs_i unchecked overloaded [(b, prop')] thy;
88.42 + val axm' = Thm.axiom thy' (Sign.full_name thy' b);
88.43 val thm = unvarify (Thm.instantiate (recover_sorts, []) axm');
88.44 in (thm, thy') end;
88.45
89.1 --- a/src/Pure/morphism.ML Wed Jan 21 15:26:02 2009 +0100
89.2 +++ b/src/Pure/morphism.ML Wed Jan 21 20:05:31 2009 +0100
89.3 @@ -16,21 +16,21 @@
89.4 signature MORPHISM =
89.5 sig
89.6 include BASIC_MORPHISM
89.7 - val var: morphism -> Binding.T * mixfix -> Binding.T * mixfix
89.8 - val binding: morphism -> Binding.T -> Binding.T
89.9 + val var: morphism -> binding * mixfix -> binding * mixfix
89.10 + val binding: morphism -> binding -> binding
89.11 val typ: morphism -> typ -> typ
89.12 val term: morphism -> term -> term
89.13 val fact: morphism -> thm list -> thm list
89.14 val thm: morphism -> thm -> thm
89.15 val cterm: morphism -> cterm -> cterm
89.16 val morphism:
89.17 - {binding: Binding.T -> Binding.T,
89.18 - var: Binding.T * mixfix -> Binding.T * mixfix,
89.19 + {binding: binding -> binding,
89.20 + var: binding * mixfix -> binding * mixfix,
89.21 typ: typ -> typ,
89.22 term: term -> term,
89.23 fact: thm list -> thm list} -> morphism
89.24 - val binding_morphism: (Binding.T -> Binding.T) -> morphism
89.25 - val var_morphism: (Binding.T * mixfix -> Binding.T * mixfix) -> morphism
89.26 + val binding_morphism: (binding -> binding) -> morphism
89.27 + val var_morphism: (binding * mixfix -> binding * mixfix) -> morphism
89.28 val typ_morphism: (typ -> typ) -> morphism
89.29 val term_morphism: (term -> term) -> morphism
89.30 val fact_morphism: (thm list -> thm list) -> morphism
89.31 @@ -45,8 +45,8 @@
89.32 struct
89.33
89.34 datatype morphism = Morphism of
89.35 - {binding: Binding.T -> Binding.T,
89.36 - var: Binding.T * mixfix -> Binding.T * mixfix,
89.37 + {binding: binding -> binding,
89.38 + var: binding * mixfix -> binding * mixfix,
89.39 typ: typ -> typ,
89.40 term: term -> term,
89.41 fact: thm list -> thm list};
90.1 --- a/src/Pure/primitive_defs.ML Wed Jan 21 15:26:02 2009 +0100
90.2 +++ b/src/Pure/primitive_defs.ML Wed Jan 21 20:05:31 2009 +0100
90.3 @@ -1,5 +1,4 @@
90.4 (* Title: Pure/primitive_defs.ML
90.5 - ID: $Id$
90.6 Author: Makarius
90.7
90.8 Primitive definition forms.
91.1 --- a/src/Pure/pure_thy.ML Wed Jan 21 15:26:02 2009 +0100
91.2 +++ b/src/Pure/pure_thy.ML Wed Jan 21 20:05:31 2009 +0100
91.3 @@ -24,27 +24,27 @@
91.4 val name_thm: bool -> bool -> Position.T -> string -> thm -> thm
91.5 val name_thms: bool -> bool -> Position.T -> string -> thm list -> thm list
91.6 val name_thmss: bool -> Position.T -> string -> (thm list * 'a) list -> (thm list * 'a) list
91.7 - val store_thms: bstring * thm list -> theory -> thm list * theory
91.8 - val store_thm: bstring * thm -> theory -> thm * theory
91.9 - val store_thm_open: bstring * thm -> theory -> thm * theory
91.10 - val add_thms: ((bstring * thm) * attribute list) list -> theory -> thm list * theory
91.11 - val add_thm: (bstring * thm) * attribute list -> theory -> thm * theory
91.12 - val add_thmss: ((bstring * thm list) * attribute list) list -> theory -> thm list list * theory
91.13 - val add_thms_dynamic: bstring * (Context.generic -> thm list) -> theory -> theory
91.14 - val note_thmss: string -> ((Binding.T * attribute list) *
91.15 + val store_thms: binding * thm list -> theory -> thm list * theory
91.16 + val store_thm: binding * thm -> theory -> thm * theory
91.17 + val store_thm_open: binding * thm -> theory -> thm * theory
91.18 + val add_thms: ((binding * thm) * attribute list) list -> theory -> thm list * theory
91.19 + val add_thm: (binding * thm) * attribute list -> theory -> thm * theory
91.20 + val add_thmss: ((binding * thm list) * attribute list) list -> theory -> thm list list * theory
91.21 + val add_thms_dynamic: binding * (Context.generic -> thm list) -> theory -> theory
91.22 + val note_thmss: string -> ((binding * attribute list) *
91.23 (thm list * attribute list) list) list -> theory -> (string * thm list) list * theory
91.24 - val note_thmss_grouped: string -> string -> ((Binding.T * attribute list) *
91.25 + val note_thmss_grouped: string -> string -> ((binding * attribute list) *
91.26 (thm list * attribute list) list) list -> theory -> (string * thm list) list * theory
91.27 - val add_axioms: ((bstring * term) * attribute list) list -> theory -> thm list * theory
91.28 + val add_axioms: ((binding * term) * attribute list) list -> theory -> thm list * theory
91.29 val add_axioms_cmd: ((bstring * string) * attribute list) list -> theory -> thm list * theory
91.30 - val add_defs: bool -> ((bstring * term) * attribute list) list ->
91.31 + val add_defs: bool -> ((binding * term) * attribute list) list ->
91.32 theory -> thm list * theory
91.33 - val add_defs_unchecked: bool -> ((bstring * term) * attribute list) list ->
91.34 + val add_defs_unchecked: bool -> ((binding * term) * attribute list) list ->
91.35 + theory -> thm list * theory
91.36 + val add_defs_cmd: bool -> ((bstring * string) * attribute list) list ->
91.37 theory -> thm list * theory
91.38 val add_defs_unchecked_cmd: bool -> ((bstring * string) * attribute list) list ->
91.39 theory -> thm list * theory
91.40 - val add_defs_cmd: bool -> ((bstring * string) * attribute list) list ->
91.41 - theory -> thm list * theory
91.42 val old_appl_syntax: theory -> bool
91.43 val old_appl_syntax_setup: theory -> theory
91.44 end;
91.45 @@ -163,21 +163,21 @@
91.46
91.47 (* store_thm(s) *)
91.48
91.49 -fun store_thms (bname, thms) = enter_thms (name_thms true true Position.none)
91.50 - (name_thms false true Position.none) I (Binding.name bname, thms);
91.51 +fun store_thms (b, thms) = enter_thms (name_thms true true Position.none)
91.52 + (name_thms false true Position.none) I (b, thms);
91.53
91.54 -fun store_thm (bname, th) = store_thms (bname, [th]) #>> the_single;
91.55 +fun store_thm (b, th) = store_thms (b, [th]) #>> the_single;
91.56
91.57 -fun store_thm_open (bname, th) =
91.58 +fun store_thm_open (b, th) =
91.59 enter_thms (name_thms true false Position.none) (name_thms false false Position.none) I
91.60 - (Binding.name bname, [th]) #>> the_single;
91.61 + (b, [th]) #>> the_single;
91.62
91.63
91.64 (* add_thms(s) *)
91.65
91.66 -fun add_thms_atts pre_name ((bname, thms), atts) =
91.67 +fun add_thms_atts pre_name ((b, thms), atts) =
91.68 enter_thms pre_name (name_thms false true Position.none)
91.69 - (foldl_map (Thm.theory_attributes atts)) (Binding.name bname, thms);
91.70 + (foldl_map (Thm.theory_attributes atts)) (b, thms);
91.71
91.72 fun gen_add_thmss pre_name =
91.73 fold_map (add_thms_atts pre_name);
91.74 @@ -192,9 +192,9 @@
91.75
91.76 (* add_thms_dynamic *)
91.77
91.78 -fun add_thms_dynamic (bname, f) thy = thy
91.79 +fun add_thms_dynamic (b, f) thy = thy
91.80 |> (FactsData.map o apfst)
91.81 - (Facts.add_dynamic (Sign.naming_of thy) (Binding.name bname, f) #> snd);
91.82 + (Facts.add_dynamic (Sign.naming_of thy) (b, f) #> snd);
91.83
91.84
91.85 (* note_thmss *)
91.86 @@ -224,21 +224,21 @@
91.87 (* store axioms as theorems *)
91.88
91.89 local
91.90 - fun get_ax thy (name, _) = Thm.axiom thy (Sign.full_bname thy name);
91.91 + fun get_ax thy (b, _) = Thm.axiom thy (Sign.full_name thy b);
91.92 fun get_axs thy named_axs = map (Thm.forall_elim_vars 0 o get_ax thy) named_axs;
91.93 - fun add_axm add = fold_map (fn ((name, ax), atts) => fn thy =>
91.94 + fun add_axm prep_b add = fold_map (fn ((b, ax), atts) => fn thy =>
91.95 let
91.96 - val named_ax = [(name, ax)];
91.97 + val named_ax = [(b, ax)];
91.98 val thy' = add named_ax thy;
91.99 - val thm = hd (get_axs thy' named_ax);
91.100 - in apfst hd (gen_add_thms (K I) [((name, thm), atts)] thy') end);
91.101 + val thm = hd (get_axs thy' ((map o apfst) prep_b named_ax));
91.102 + in apfst hd (gen_add_thms (K I) [((prep_b b, thm), atts)] thy') end);
91.103 in
91.104 - val add_defs = add_axm o Theory.add_defs_i false;
91.105 - val add_defs_unchecked = add_axm o Theory.add_defs_i true;
91.106 - val add_axioms = add_axm Theory.add_axioms_i;
91.107 - val add_defs_cmd = add_axm o Theory.add_defs false;
91.108 - val add_defs_unchecked_cmd = add_axm o Theory.add_defs true;
91.109 - val add_axioms_cmd = add_axm Theory.add_axioms;
91.110 + val add_defs = add_axm I o Theory.add_defs_i false;
91.111 + val add_defs_unchecked = add_axm I o Theory.add_defs_i true;
91.112 + val add_axioms = add_axm I Theory.add_axioms_i;
91.113 + val add_defs_cmd = add_axm Binding.name o Theory.add_defs false;
91.114 + val add_defs_unchecked_cmd = add_axm Binding.name o Theory.add_defs true;
91.115 + val add_axioms_cmd = add_axm Binding.name Theory.add_axioms;
91.116 end;
91.117
91.118
91.119 @@ -378,16 +378,16 @@
91.120 ("sort_constraint", typ "'a itself => prop", NoSyn),
91.121 ("conjunction", typ "prop => prop => prop", NoSyn)]
91.122 #> (add_defs false o map Thm.no_attributes)
91.123 - [("prop_def", prop "(CONST prop :: prop => prop) (A::prop) == A::prop"),
91.124 - ("term_def", prop "(CONST Pure.term :: 'a => prop) (x::'a) == (!!A::prop. A ==> A)"),
91.125 - ("sort_constraint_def",
91.126 + [(Binding.name "prop_def", prop "(CONST prop :: prop => prop) (A::prop) == A::prop"),
91.127 + (Binding.name "term_def", prop "(CONST Pure.term :: 'a => prop) (x::'a) == (!!A::prop. A ==> A)"),
91.128 + (Binding.name "sort_constraint_def",
91.129 prop "(CONST Pure.sort_constraint :: 'a itself => prop) (CONST TYPE :: 'a itself) ==\
91.130 \ (CONST Pure.term :: 'a itself => prop) (CONST TYPE :: 'a itself)"),
91.131 - ("conjunction_def", prop "(A &&& B) == (!!C::prop. (A ==> B ==> C) ==> C)")] #> snd
91.132 + (Binding.name "conjunction_def", prop "(A &&& B) == (!!C::prop. (A ==> B ==> C) ==> C)")] #> snd
91.133 #> Sign.hide_const false "Pure.term"
91.134 #> Sign.hide_const false "Pure.sort_constraint"
91.135 #> Sign.hide_const false "Pure.conjunction"
91.136 - #> add_thmss [(("nothing", []), [])] #> snd
91.137 - #> Theory.add_axioms_i Proofterm.equality_axms));
91.138 + #> add_thmss [((Binding.name "nothing", []), [])] #> snd
91.139 + #> Theory.add_axioms_i ((map o apfst) Binding.name Proofterm.equality_axms)));
91.140
91.141 end;
92.1 --- a/src/Pure/sign.ML Wed Jan 21 15:26:02 2009 +0100
92.2 +++ b/src/Pure/sign.ML Wed Jan 21 20:05:31 2009 +0100
92.3 @@ -14,7 +14,7 @@
92.4 tsig: Type.tsig,
92.5 consts: Consts.T}
92.6 val naming_of: theory -> NameSpace.naming
92.7 - val full_name: theory -> Binding.T -> string
92.8 + val full_name: theory -> binding -> string
92.9 val base_name: string -> bstring
92.10 val full_bname: theory -> bstring -> string
92.11 val full_bname_path: theory -> string -> bstring -> string
92.12 @@ -91,10 +91,10 @@
92.13 val del_modesyntax: Syntax.mode -> (bstring * string * mixfix) list -> theory -> theory
92.14 val del_modesyntax_i: Syntax.mode -> (bstring * typ * mixfix) list -> theory -> theory
92.15 val notation: bool -> Syntax.mode -> (term * mixfix) list -> theory -> theory
92.16 - val declare_const: Properties.T -> (Binding.T * typ) * mixfix -> theory -> term * theory
92.17 + val declare_const: Properties.T -> (binding * typ) * mixfix -> theory -> term * theory
92.18 val add_consts: (bstring * string * mixfix) list -> theory -> theory
92.19 val add_consts_i: (bstring * typ * mixfix) list -> theory -> theory
92.20 - val add_abbrev: string -> Properties.T -> Binding.T * term -> theory -> (term * term) * theory
92.21 + val add_abbrev: string -> Properties.T -> binding * term -> theory -> (term * term) * theory
92.22 val revert_abbrev: string -> string -> theory -> theory
92.23 val add_const_constraint: string * typ option -> theory -> theory
92.24 val primitive_class: string * class list -> theory -> theory
93.1 --- a/src/Pure/theory.ML Wed Jan 21 15:26:02 2009 +0100
93.2 +++ b/src/Pure/theory.ML Wed Jan 21 20:05:31 2009 +0100
93.3 @@ -29,14 +29,14 @@
93.4 val at_end: (theory -> theory option) -> theory -> theory
93.5 val begin_theory: string -> theory list -> theory
93.6 val end_theory: theory -> theory
93.7 + val add_axioms_i: (binding * term) list -> theory -> theory
93.8 val add_axioms: (bstring * string) list -> theory -> theory
93.9 - val add_axioms_i: (bstring * term) list -> theory -> theory
93.10 val add_deps: string -> string * typ -> (string * typ) list -> theory -> theory
93.11 + val add_defs_i: bool -> bool -> (binding * term) list -> theory -> theory
93.12 val add_defs: bool -> bool -> (bstring * string) list -> theory -> theory
93.13 - val add_defs_i: bool -> bool -> (bstring * term) list -> theory -> theory
93.14 + val add_finals_i: bool -> term list -> theory -> theory
93.15 val add_finals: bool -> string list -> theory -> theory
93.16 - val add_finals_i: bool -> term list -> theory -> theory
93.17 - val specify_const: Properties.T -> (Binding.T * typ) * mixfix -> theory -> term * theory
93.18 + val specify_const: Properties.T -> (binding * typ) * mixfix -> theory -> term * theory
93.19 end
93.20
93.21 structure Theory: THEORY =
93.22 @@ -157,19 +157,19 @@
93.23 fun err_in_axm msg name =
93.24 cat_error msg ("The error(s) above occurred in axiom " ^ quote name);
93.25
93.26 -fun cert_axm thy (name, raw_tm) =
93.27 +fun cert_axm thy (b, raw_tm) =
93.28 let
93.29 val (t, T, _) = Sign.certify_prop thy raw_tm
93.30 handle TYPE (msg, _, _) => error msg
93.31 | TERM (msg, _) => error msg;
93.32 in
93.33 Term.no_dummy_patterns t handle TERM (msg, _) => error msg;
93.34 - (name, Sign.no_vars (Syntax.pp_global thy) t)
93.35 + (b, Sign.no_vars (Syntax.pp_global thy) t)
93.36 end;
93.37
93.38 -fun read_axm thy (name, str) =
93.39 - cert_axm thy (name, Syntax.read_prop_global thy str)
93.40 - handle ERROR msg => err_in_axm msg name;
93.41 +fun read_axm thy (bname, str) =
93.42 + cert_axm thy (Binding.name bname, Syntax.read_prop_global thy str)
93.43 + handle ERROR msg => err_in_axm msg bname;
93.44
93.45
93.46 (* add_axioms(_i) *)
93.47 @@ -178,15 +178,15 @@
93.48
93.49 fun gen_add_axioms prep_axm raw_axms thy = thy |> map_axioms (fn axioms =>
93.50 let
93.51 - val axms = map (apfst Binding.name o apsnd Logic.varify o prep_axm thy) raw_axms;
93.52 + val axms = map (apsnd Logic.varify o prep_axm thy) raw_axms;
93.53 val axioms' = fold (snd oo NameSpace.bind (Sign.naming_of thy)) axms axioms
93.54 handle Symtab.DUP dup => err_dup_axm dup;
93.55 in axioms' end);
93.56
93.57 in
93.58
93.59 +val add_axioms_i = gen_add_axioms cert_axm;
93.60 val add_axioms = gen_add_axioms read_axm;
93.61 -val add_axioms_i = gen_add_axioms cert_axm;
93.62
93.63 end;
93.64
93.65 @@ -250,16 +250,16 @@
93.66
93.67 (* check_def *)
93.68
93.69 -fun check_def thy unchecked overloaded (bname, tm) defs =
93.70 +fun check_def thy unchecked overloaded (b, tm) defs =
93.71 let
93.72 val ctxt = ProofContext.init thy;
93.73 - val name = Sign.full_bname thy bname;
93.74 + val name = Sign.full_name thy b;
93.75 val (lhs_const, rhs) = Sign.cert_def ctxt tm;
93.76 val rhs_consts = fold_aterms (fn Const const => insert (op =) const | _ => I) rhs [];
93.77 val _ = check_overloading thy overloaded lhs_const;
93.78 in defs |> dependencies thy unchecked true name lhs_const rhs_consts end
93.79 handle ERROR msg => cat_error msg (Pretty.string_of (Pretty.block
93.80 - [Pretty.str ("The error(s) above occurred in definition " ^ quote bname ^ ":"),
93.81 + [Pretty.str ("The error(s) above occurred in definition " ^ quote (Binding.display b) ^ ":"),
93.82 Pretty.fbrk, Pretty.quote (Syntax.pretty_term_global thy tm)]));
93.83
93.84
93.85 @@ -298,8 +298,8 @@
93.86
93.87 in
93.88
93.89 +val add_finals_i = gen_add_finals (K I);
93.90 val add_finals = gen_add_finals Syntax.read_term_global;
93.91 -val add_finals_i = gen_add_finals (K I);
93.92
93.93 end;
93.94
94.1 --- a/src/Tools/induct.ML Wed Jan 21 15:26:02 2009 +0100
94.2 +++ b/src/Tools/induct.ML Wed Jan 21 20:05:31 2009 +0100
94.3 @@ -50,7 +50,7 @@
94.4 val setN: string
94.5 (*proof methods*)
94.6 val fix_tac: Proof.context -> int -> (string * typ) list -> int -> tactic
94.7 - val add_defs: (Binding.T option * term) option list -> Proof.context ->
94.8 + val add_defs: (binding option * term) option list -> Proof.context ->
94.9 (term option list * thm list) * Proof.context
94.10 val atomize_term: theory -> term -> term
94.11 val atomize_tac: int -> tactic
94.12 @@ -62,7 +62,7 @@
94.13 val cases_tac: Proof.context -> term option list list -> thm option ->
94.14 thm list -> int -> cases_tactic
94.15 val get_inductT: Proof.context -> term option list list -> thm list list
94.16 - val induct_tac: Proof.context -> (Binding.T option * term) option list list ->
94.17 + val induct_tac: Proof.context -> (binding option * term) option list list ->
94.18 (string * typ) list list -> term option list -> thm list option ->
94.19 thm list -> int -> cases_tactic
94.20 val coinduct_tac: Proof.context -> term option list -> term option list -> thm option ->
95.1 --- a/src/ZF/Inductive_ZF.thy Wed Jan 21 15:26:02 2009 +0100
95.2 +++ b/src/ZF/Inductive_ZF.thy Wed Jan 21 20:05:31 2009 +0100
95.3 @@ -1,5 +1,4 @@
95.4 (* Title: ZF/Inductive_ZF.thy
95.5 - ID: $Id$
95.6 Author: Lawrence C Paulson, Cambridge University Computer Laboratory
95.7 Copyright 1993 University of Cambridge
95.8
96.1 --- a/src/ZF/Main_ZF.thy Wed Jan 21 15:26:02 2009 +0100
96.2 +++ b/src/ZF/Main_ZF.thy Wed Jan 21 20:05:31 2009 +0100
96.3 @@ -1,5 +1,3 @@
96.4 -(*$Id$*)
96.5 -
96.6 header{*Theory Main: Everything Except AC*}
96.7
96.8 theory Main_ZF imports List_ZF IntDiv_ZF CardinalArith begin
97.1 --- a/src/ZF/Tools/datatype_package.ML Wed Jan 21 15:26:02 2009 +0100
97.2 +++ b/src/ZF/Tools/datatype_package.ML Wed Jan 21 20:05:31 2009 +0100
97.3 @@ -247,7 +247,7 @@
97.4 if need_recursor then
97.5 thy |> Sign.add_consts_i
97.6 [(recursor_base_name, recursor_typ, NoSyn)]
97.7 - |> (snd o PureThy.add_defs false [Thm.no_attributes recursor_def])
97.8 + |> (snd o PureThy.add_defs false [(Thm.no_attributes o apfst Binding.name) recursor_def])
97.9 else thy;
97.10
97.11 val (con_defs, thy0) = thy_path
97.12 @@ -255,7 +255,7 @@
97.13 ((case_base_name, case_typ, NoSyn) ::
97.14 map #1 (List.concat con_ty_lists))
97.15 |> PureThy.add_defs false
97.16 - (map Thm.no_attributes
97.17 + (map (Thm.no_attributes o apfst Binding.name)
97.18 (case_def ::
97.19 List.concat (ListPair.map mk_con_defs
97.20 (1 upto npart, con_ty_lists))))
97.21 @@ -383,13 +383,13 @@
97.22 (*Updating theory components: simprules and datatype info*)
97.23 (thy1 |> Sign.add_path big_rec_base_name
97.24 |> PureThy.add_thmss
97.25 - [(("simps", simps), [Simplifier.simp_add]),
97.26 - (("", intrs), [Classical.safe_intro NONE]),
97.27 - (("con_defs", con_defs), []),
97.28 - (("case_eqns", case_eqns), []),
97.29 - (("recursor_eqns", recursor_eqns), []),
97.30 - (("free_iffs", free_iffs), []),
97.31 - (("free_elims", free_SEs), [])] |> snd
97.32 + [((Binding.name "simps", simps), [Simplifier.simp_add]),
97.33 + ((Binding.empty , intrs), [Classical.safe_intro NONE]),
97.34 + ((Binding.name "con_defs", con_defs), []),
97.35 + ((Binding.name "case_eqns", case_eqns), []),
97.36 + ((Binding.name "recursor_eqns", recursor_eqns), []),
97.37 + ((Binding.name "free_iffs", free_iffs), []),
97.38 + ((Binding.name "free_elims", free_SEs), [])] |> snd
97.39 |> DatatypesData.map (Symtab.update (big_rec_name, dt_info))
97.40 |> ConstructorsData.map (fold Symtab.update con_pairs)
97.41 |> Sign.parent_path,
98.1 --- a/src/ZF/Tools/induct_tacs.ML Wed Jan 21 15:26:02 2009 +0100
98.2 +++ b/src/ZF/Tools/induct_tacs.ML Wed Jan 21 20:05:31 2009 +0100
98.3 @@ -158,7 +158,7 @@
98.4 in
98.5 thy
98.6 |> Sign.add_path (Sign.base_name big_rec_name)
98.7 - |> PureThy.add_thmss [(("simps", simps), [Simplifier.simp_add])] |> snd
98.8 + |> PureThy.add_thmss [((Binding.name "simps", simps), [Simplifier.simp_add])] |> snd
98.9 |> DatatypesData.put (Symtab.update (big_rec_name, dt_info) (DatatypesData.get thy))
98.10 |> ConstructorsData.put (fold_rev Symtab.update con_pairs (ConstructorsData.get thy))
98.11 |> Sign.parent_path
99.1 --- a/src/ZF/Tools/inductive_package.ML Wed Jan 21 15:26:02 2009 +0100
99.2 +++ b/src/ZF/Tools/inductive_package.ML Wed Jan 21 20:05:31 2009 +0100
99.3 @@ -27,10 +27,10 @@
99.4 (*Insert definitions for the recursive sets, which
99.5 must *already* be declared as constants in parent theory!*)
99.6 val add_inductive_i: bool -> term list * term ->
99.7 - ((Binding.T * term) * attribute list) list ->
99.8 + ((binding * term) * attribute list) list ->
99.9 thm list * thm list * thm list * thm list -> theory -> theory * inductive_result
99.10 val add_inductive: string list * string ->
99.11 - ((Binding.T * string) * Attrib.src list) list ->
99.12 + ((binding * string) * Attrib.src list) list ->
99.13 (Facts.ref * Attrib.src list) list * (Facts.ref * Attrib.src list) list *
99.14 (Facts.ref * Attrib.src list) list * (Facts.ref * Attrib.src list) list ->
99.15 theory -> theory * inductive_result
99.16 @@ -173,7 +173,7 @@
99.17 val (_, thy1) =
99.18 thy
99.19 |> Sign.add_path big_rec_base_name
99.20 - |> PureThy.add_defs false (map Thm.no_attributes axpairs);
99.21 + |> PureThy.add_defs false (map (Thm.no_attributes o apfst Binding.name) axpairs);
99.22
99.23 val ctxt1 = ProofContext.init thy1;
99.24
99.25 @@ -510,9 +510,9 @@
99.26
99.27 val ([induct', mutual_induct'], thy') =
99.28 thy
99.29 - |> PureThy.add_thms [((co_prefix ^ "induct", induct),
99.30 + |> PureThy.add_thms [((Binding.name (co_prefix ^ "induct"), induct),
99.31 [case_names, Induct.induct_pred big_rec_name]),
99.32 - (("mutual_induct", mutual_induct), [case_names])];
99.33 + ((Binding.name "mutual_induct", mutual_induct), [case_names])];
99.34 in ((thy', induct'), mutual_induct')
99.35 end; (*of induction_rules*)
99.36
99.37 @@ -522,7 +522,7 @@
99.38 if not coind then induction_rules raw_induct thy1
99.39 else
99.40 (thy1
99.41 - |> PureThy.add_thms [((co_prefix ^ "induct", raw_induct), [])]
99.42 + |> PureThy.add_thms [((Binding.name (co_prefix ^ "induct"), raw_induct), [])]
99.43 |> apfst hd |> Library.swap, TrueI)
99.44 and defs = big_rec_def :: part_rec_defs
99.45
99.46 @@ -531,15 +531,15 @@
99.47 thy2
99.48 |> IndCases.declare big_rec_name make_cases
99.49 |> PureThy.add_thms
99.50 - [(("bnd_mono", bnd_mono), []),
99.51 - (("dom_subset", dom_subset), []),
99.52 - (("cases", elim), [case_names, Induct.cases_pred big_rec_name])]
99.53 + [((Binding.name "bnd_mono", bnd_mono), []),
99.54 + ((Binding.name "dom_subset", dom_subset), []),
99.55 + ((Binding.name "cases", elim), [case_names, Induct.cases_pred big_rec_name])]
99.56 ||>> (PureThy.add_thmss o map Thm.no_attributes)
99.57 - [("defs", defs),
99.58 - ("intros", intrs)];
99.59 + [(Binding.name "defs", defs),
99.60 + (Binding.name "intros", intrs)];
99.61 val (intrs'', thy4) =
99.62 thy3
99.63 - |> PureThy.add_thms ((intr_names ~~ intrs') ~~ map #2 intr_specs)
99.64 + |> PureThy.add_thms ((map Binding.name intr_names ~~ intrs') ~~ map #2 intr_specs)
99.65 ||> Sign.parent_path;
99.66 in
99.67 (thy4,
100.1 --- a/src/ZF/Tools/primrec_package.ML Wed Jan 21 15:26:02 2009 +0100
100.2 +++ b/src/ZF/Tools/primrec_package.ML Wed Jan 21 20:05:31 2009 +0100
100.3 @@ -8,8 +8,8 @@
100.4
100.5 signature PRIMREC_PACKAGE =
100.6 sig
100.7 - val add_primrec: ((Binding.T * string) * Attrib.src list) list -> theory -> theory * thm list
100.8 - val add_primrec_i: ((Binding.T * term) * attribute list) list -> theory -> theory * thm list
100.9 + val add_primrec: ((binding * string) * Attrib.src list) list -> theory -> theory * thm list
100.10 + val add_primrec_i: ((binding * term) * attribute list) list -> theory -> theory * thm list
100.11 end;
100.12
100.13 structure PrimrecPackage : PRIMREC_PACKAGE =
100.14 @@ -169,7 +169,7 @@
100.15
100.16 val ([def_thm], thy1) = thy
100.17 |> Sign.add_path (Sign.base_name fname)
100.18 - |> (PureThy.add_defs false o map Thm.no_attributes) [def];
100.19 + |> PureThy.add_defs false [Thm.no_attributes (apfst Binding.name def)];
100.20
100.21 val rewrites = def_thm :: map mk_meta_eq (#rec_rewrites con_info)
100.22 val eqn_thms =
100.23 @@ -179,10 +179,10 @@
100.24
100.25 val (eqn_thms', thy2) =
100.26 thy1
100.27 - |> PureThy.add_thms ((map Binding.base_name eqn_names ~~ eqn_thms) ~~ eqn_atts);
100.28 + |> PureThy.add_thms ((eqn_names ~~ eqn_thms) ~~ eqn_atts);
100.29 val (_, thy3) =
100.30 thy2
100.31 - |> PureThy.add_thmss [(("simps", eqn_thms'), [Simplifier.simp_add])]
100.32 + |> PureThy.add_thmss [((Binding.name "simps", eqn_thms'), [Simplifier.simp_add])]
100.33 ||> Sign.parent_path;
100.34 in (thy3, eqn_thms') end;
100.35