merged
authorwenzelm
Wed Jan 21 20:05:31 2009 +0100 (2009-01-21)
changeset 296000182b65e4ad0
parent 29599 c369feeb6bbc
parent 29586 4f9803829625
child 29602 f1583c12b5d0
merged
src/HOL/ATP_Linkup.thy
src/Pure/Isar/old_locale.ML
src/Pure/Tools/invoke.ML
     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 +val refine_witness =
  62.112 +  Proof.refine (Method.Basic (K (Method.RAW_METHOD
  62.113 +    (K (ALLGOALS
  62.114 +      (CONJUNCTS (ALLGOALS
  62.115 +        (CONJUNCTS (TRYALL (Tactic.rtac Drule.protectI)))))))), Position.none));
  62.116  
  62.117 -fun conclude_witness (Witness (_, th)) =
  62.118 -  Thm.close_derivation (MetaSimplifier.norm_hhf_protect (Goal.conclude th));
  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