abstract type Name_Space.table;
clarified pretty_locale_deps: sort strings;
clarified Proof_Context.update_cases: Name_Space.del_table hides name space entry as well;
--- a/src/HOL/Mutabelle/mutabelle.ML Mon Mar 10 10:13:47 2014 +0100
+++ b/src/HOL/Mutabelle/mutabelle.ML Mon Mar 10 13:55:03 2014 +0100
@@ -32,11 +32,11 @@
fun consts_of thy =
let
- val (namespace, const_table) = #constants (Consts.dest (Sign.consts_of thy))
- val consts = Symtab.dest const_table
+ val {const_space, constants, ...} = Consts.dest (Sign.consts_of thy)
+ val consts = Symtab.dest constants
in
map_filter (fn (s, (T, NONE)) => SOME (s, T) | _ => NONE)
- (filter_out (fn (s, _) => Name_Space.is_concealed namespace s) consts)
+ (filter_out (fn (s, _) => Name_Space.is_concealed const_space s) consts)
end;
--- a/src/HOL/Tools/inductive.ML Mon Mar 10 10:13:47 2014 +0100
+++ b/src/HOL/Tools/inductive.ML Mon Mar 10 13:55:03 2014 +0100
@@ -230,7 +230,7 @@
[Pretty.block
(Pretty.breaks
(Pretty.str "(co)inductives:" ::
- map (Pretty.mark_str o #1) (Name_Space.extern_table ctxt (space, infos)))),
+ map (Pretty.mark_str o #1) (Name_Space.extern_table' ctxt space infos))),
Pretty.big_list "monotonicity rules:" (map (Display.pretty_thm_item ctxt) monos)]
end |> Pretty.chunks |> Pretty.writeln;
--- a/src/Pure/General/name_space.ML Mon Mar 10 10:13:47 2014 +0100
+++ b/src/Pure/General/name_space.ML Mon Mar 10 13:55:03 2014 +0100
@@ -54,17 +54,26 @@
val naming_of: Context.generic -> naming
val map_naming: (naming -> naming) -> Context.generic -> Context.generic
val declare: Context.generic -> bool -> binding -> T -> string * T
- type 'a table = T * 'a Symtab.table
+ type 'a table
+ val space_of_table: 'a table -> T
val check_reports: Context.generic -> 'a table ->
xstring * Position.T list -> (string * Position.report list) * 'a
val check: Context.generic -> 'a table -> xstring * Position.T -> string * 'a
+ val lookup_key: 'a table -> string -> (string * 'a) option
val get: 'a table -> string -> 'a
val define: Context.generic -> bool -> binding * 'a -> 'a table -> string * 'a table
+ val alias_table: naming -> binding -> string -> 'a table -> 'a table
+ val hide_table: bool -> string -> 'a table -> 'a table
+ val del_table: string -> 'a table -> 'a table
+ val map_table_entry: string -> ('a -> 'a) -> 'a table -> 'a table
+ val fold_table: (string * 'a -> 'b -> 'b) -> 'a table -> 'b -> 'b
val empty_table: string -> 'a table
val merge_tables: 'a table * 'a table -> 'a table
val join_tables: (string -> 'a * 'a -> 'a) (*Symtab.SAME*) ->
'a table * 'a table -> 'a table
- val dest_table: Proof.context -> 'a table -> (string * 'a) list
+ val dest_table': Proof.context -> T -> 'a Symtab.table -> ((string * xstring) * 'a) list
+ val dest_table: Proof.context -> 'a table -> ((string * xstring) * 'a) list
+ val extern_table': Proof.context -> T -> 'a Symtab.table -> ((Markup.T * xstring) * 'a) list
val extern_table: Proof.context -> 'a table -> ((Markup.T * xstring) * 'a) list
end;
@@ -455,9 +464,11 @@
(* definition in symbol table *)
-type 'a table = T * 'a Symtab.table;
+datatype 'a table = Table of T * 'a Symtab.table;
-fun check_reports context (space, tab) (xname, ps) =
+fun space_of_table (Table (space, _)) = space;
+
+fun check_reports context (Table (space, tab)) (xname, ps) =
let val name = intern space xname in
(case Symtab.lookup tab name of
SOME x =>
@@ -481,31 +492,61 @@
val _ = Position.reports reports;
in (name, x) end;
-fun get (space, tab) name =
- (case Symtab.lookup tab name of
- SOME x => x
- | NONE => error (undefined (kind_of space) name));
+fun lookup_key (Table (_, tab)) name = Symtab.lookup_key tab name;
+
+fun get table name =
+ (case lookup_key table name of
+ SOME (_, x) => x
+ | NONE => error (undefined (kind_of (space_of_table table)) name));
-fun define context strict (binding, x) (space, tab) =
- let val (name, space') = declare context strict binding space
- in (name, (space', Symtab.update (name, x) tab)) end;
+fun define context strict (binding, x) (Table (space, tab)) =
+ let
+ val (name, space') = declare context strict binding space;
+ val tab' = Symtab.update (name, x) tab;
+ in (name, Table (space', tab')) end;
+
+
+(* derived table operations *)
+
+fun alias_table naming binding name (Table (space, tab)) =
+ Table (alias naming binding name space, tab);
+
+fun hide_table fully name (Table (space, tab)) =
+ Table (hide fully name space, tab);
-fun empty_table kind = (empty kind, Symtab.empty);
+fun del_table name (Table (space, tab)) =
+ let
+ val space' = hide true name space handle ERROR _ => space;
+ val tab' = Symtab.delete_safe name tab;
+ in Table (space', tab') end;
-fun merge_tables ((space1, tab1), (space2, tab2)) =
- (merge (space1, space2), Symtab.merge (K true) (tab1, tab2));
+fun map_table_entry name f (Table (space, tab)) =
+ Table (space, Symtab.map_entry name f tab);
+
+fun fold_table f (Table (_, tab)) = Symtab.fold f tab;
-fun join_tables f ((space1, tab1), (space2, tab2)) =
- (merge (space1, space2), Symtab.join f (tab1, tab2));
+fun empty_table kind = Table (empty kind, Symtab.empty);
+
+fun merge_tables (Table (space1, tab1), Table (space2, tab2)) =
+ Table (merge (space1, space2), Symtab.merge (K true) (tab1, tab2));
-fun ext_table ctxt (space, tab) =
+fun join_tables f (Table (space1, tab1), Table (space2, tab2)) =
+ Table (merge (space1, space2), Symtab.join f (tab1, tab2));
+
+
+(* present table content *)
+
+fun dest_table' ctxt space tab =
Symtab.fold (fn (name, x) => cons ((name, extern ctxt space name), x)) tab []
|> Library.sort_wrt (#2 o #1);
-fun dest_table ctxt table = map (apfst #1) (ext_table ctxt table);
+fun dest_table ctxt (Table (space, tab)) = dest_table' ctxt space tab;
-fun extern_table ctxt (space, tab) =
- map (fn ((name, xname), x) => ((markup space name, xname), x)) (ext_table ctxt (space, tab));
+fun extern_table' ctxt space tab =
+ dest_table' ctxt space tab
+ |> map (fn ((name, xname), x) => ((markup space name, xname), x));
+
+fun extern_table ctxt (Table (space, tab)) = extern_table' ctxt space tab;
end;
--- a/src/Pure/Isar/attrib.ML Mon Mar 10 10:13:47 2014 +0100
+++ b/src/Pure/Isar/attrib.ML Mon Mar 10 13:55:03 2014 +0100
@@ -129,7 +129,8 @@
(* pretty printing *)
-fun extern ctxt = Name_Space.extern ctxt (#1 (get_attributes (Context.Proof ctxt)));
+fun extern ctxt =
+ Name_Space.extern ctxt (Name_Space.space_of_table (get_attributes (Context.Proof ctxt)));
fun pretty_attribs _ [] = []
| pretty_attribs ctxt srcs =
@@ -139,12 +140,12 @@
(* get attributes *)
fun attribute_generic context =
- let val (_, tab) = get_attributes context in
+ let val table = get_attributes context in
fn src =>
let val ((name, _), pos) = Args.dest_src src in
- (case Symtab.lookup tab name of
+ (case Name_Space.lookup_key table name of
NONE => error ("Undefined attribute: " ^ quote name ^ Position.here pos)
- | SOME (att, _) => att src)
+ | SOME (_, (att, _)) => att src)
end
end;
@@ -349,8 +350,8 @@
Pretty.block [Pretty.mark_str name, Pretty.str (": " ^ Config.print_type value ^ " ="),
Pretty.brk 1, Pretty.str (Config.print_value value)]
end;
- val space = #1 (get_attributes (Context.Proof ctxt));
- val configs = Name_Space.extern_table ctxt (space, Configs.get (Proof_Context.theory_of ctxt));
+ val space = Name_Space.space_of_table (get_attributes (Context.Proof ctxt));
+ val configs = Name_Space.extern_table' ctxt space (Configs.get (Proof_Context.theory_of ctxt));
in Pretty.writeln (Pretty.big_list "configuration options" (map prt configs)) end;
--- a/src/Pure/Isar/bundle.ML Mon Mar 10 10:13:47 2014 +0100
+++ b/src/Pure/Isar/bundle.ML Mon Mar 10 13:55:03 2014 +0100
@@ -46,8 +46,8 @@
val get_bundles = Data.get o Context.Proof;
fun the_bundle ctxt name =
- (case Symtab.lookup (#2 (get_bundles ctxt)) name of
- SOME bundle => bundle
+ (case Name_Space.lookup_key (get_bundles ctxt) name of
+ SOME (_, bundle) => bundle
| NONE => error ("Unknown bundle " ^ quote name));
fun check ctxt = #1 o Name_Space.check (Context.Proof ctxt) (get_bundles ctxt);
--- a/src/Pure/Isar/locale.ML Mon Mar 10 10:13:47 2014 +0100
+++ b/src/Pure/Isar/locale.ML Mon Mar 10 13:55:03 2014 +0100
@@ -160,19 +160,20 @@
val merge = Name_Space.join_tables (K merge_locale);
);
-val intern = Name_Space.intern o #1 o Locales.get;
+val locale_space = Name_Space.space_of_table o Locales.get;
+val intern = Name_Space.intern o locale_space;
fun check thy = #1 o Name_Space.check (Context.Theory thy) (Locales.get thy);
-fun extern thy = Name_Space.extern (Proof_Context.init_global thy) (#1 (Locales.get thy));
+fun extern thy = Name_Space.extern (Proof_Context.init_global thy) (locale_space thy);
fun markup_extern ctxt =
- Name_Space.markup_extern ctxt (#1 (Locales.get (Proof_Context.theory_of ctxt)));
+ Name_Space.markup_extern ctxt (locale_space (Proof_Context.theory_of ctxt));
fun markup_name ctxt name = markup_extern ctxt name |-> Markup.markup;
fun pretty_name ctxt name = markup_extern ctxt name |> Pretty.mark_str;
-val get_locale = Symtab.lookup o #2 o Locales.get;
-val defined = Symtab.defined o #2 o Locales.get;
+val get_locale = Option.map #2 oo (Name_Space.lookup_key o Locales.get);
+val defined = is_some oo get_locale;
fun the_locale thy name =
(case get_locale thy name of
@@ -189,7 +190,7 @@
(* FIXME Morphism.identity *)
fun change_locale name =
- Locales.map o apsnd o Symtab.map_entry name o map_locale o apsnd;
+ Locales.map o Name_Space.map_table_entry name o map_locale o apsnd;
(** Primitive operations **)
@@ -680,6 +681,7 @@
{name = name,
parents = map (fst o fst) (dependencies_of thy name),
body = pretty_locale thy false name};
- in map make_node (Symtab.keys (#2 (Locales.get thy))) end;
+ val names = sort_strings (Name_Space.fold_table (cons o #1) (Locales.get thy) []);
+ in map make_node names end;
end;
--- a/src/Pure/Isar/method.ML Mon Mar 10 10:13:47 2014 +0100
+++ b/src/Pure/Isar/method.ML Mon Mar 10 13:55:03 2014 +0100
@@ -351,12 +351,12 @@
(* get methods *)
fun method ctxt =
- let val (_, tab) = get_methods ctxt in
+ let val table = get_methods ctxt in
fn src =>
let val ((name, _), pos) = Args.dest_src src in
- (case Symtab.lookup tab name of
+ (case Name_Space.lookup_key table name of
NONE => error ("Undefined method: " ^ quote name ^ Position.here pos)
- | SOME (meth, _) => meth src)
+ | SOME (_, (meth, _)) => meth src)
end
end;
--- a/src/Pure/Isar/proof_context.ML Mon Mar 10 10:13:47 2014 +0100
+++ b/src/Pure/Isar/proof_context.ML Mon Mar 10 13:55:03 2014 +0100
@@ -1152,16 +1152,14 @@
(** cases **)
fun dest_cases ctxt =
- Symtab.fold (fn (a, (c, i)) => cons (i, (a, c))) (#2 (cases_of ctxt)) []
+ Name_Space.fold_table (fn (a, (c, i)) => cons (i, (a, c))) (cases_of ctxt) []
|> sort (int_ord o pairself #1) |> map #2;
local
fun update_case _ _ ("", _) res = res
- | update_case _ _ (name, NONE) ((space, tab), index) =
- let
- val tab' = Symtab.delete_safe name tab;
- in ((space, tab'), index) end
+ | update_case _ _ (name, NONE) (cases, index) =
+ (Name_Space.del_table name cases, index)
| update_case context is_proper (name, SOME c) (cases, index) =
let
val (_, cases') = cases |> Name_Space.define context false
@@ -1179,7 +1177,7 @@
let
val context = Context.Proof ctxt |> Name_Space.map_naming (K Name_Space.default_naming);
val cases = cases_of ctxt;
- val index = Symtab.fold (fn _ => Integer.add 1) (#2 cases) 0;
+ val index = Name_Space.fold_table (fn _ => Integer.add 1) cases 0;
val (cases', _) = fold (update_case context is_proper) args (cases, index);
in map_cases (K cases') ctxt end;
@@ -1230,14 +1228,15 @@
fun pretty_abbrevs show_globals ctxt =
let
- val ((space, consts), (_, globals)) =
+ val space = const_space ctxt;
+ val (constants, globals) =
pairself (#constants o Consts.dest) (#consts (rep_data ctxt));
fun add_abbr (_, (_, NONE)) = I
| add_abbr (c, (T, SOME t)) =
if not show_globals andalso Symtab.defined globals c then I
else cons (c, Logic.mk_equals (Const (c, T), t));
val abbrevs =
- Name_Space.extern_table ctxt (space, Symtab.make (Symtab.fold add_abbr consts []));
+ Name_Space.extern_table' ctxt space (Symtab.make (Symtab.fold add_abbr constants []));
in
if null abbrevs then []
else [Pretty.big_list "abbreviations:" (map (pretty_term_abbrev ctxt o #2) abbrevs)]
--- a/src/Pure/Tools/find_consts.ML Mon Mar 10 10:13:47 2014 +0100
+++ b/src/Pure/Tools/find_consts.ML Mon Mar 10 13:55:03 2014 +0100
@@ -58,8 +58,8 @@
fun pretty_const ctxt (c, ty) =
let
val ty' = Logic.unvarifyT_global ty;
- val consts_space = Consts.space_of (Sign.consts_of (Proof_Context.theory_of ctxt));
- val markup = Name_Space.markup consts_space c;
+ val const_space = Consts.space_of (Sign.consts_of (Proof_Context.theory_of ctxt));
+ val markup = Name_Space.markup const_space c;
in
Pretty.block
[Pretty.mark markup (Pretty.str c), Pretty.str " ::", Pretty.brk 1,
@@ -103,13 +103,13 @@
val criteria = map make_criterion raw_criteria;
val consts = Sign.consts_of thy;
- val (_, consts_tab) = #constants (Consts.dest consts);
+ val {constants, ...} = Consts.dest consts;
fun eval_entry c =
fold (filter_const c) (user_visible consts :: criteria) (SOME low_ranking);
val matches =
Symtab.fold (fn c => (case eval_entry c of NONE => I | SOME rank => cons (rank, c)))
- consts_tab []
+ constants []
|> sort (prod_ord (rev_order o int_ord) (string_ord o pairself fst))
|> map (apsnd fst o snd);
in
--- a/src/Pure/consts.ML Mon Mar 10 10:13:47 2014 +0100
+++ b/src/Pure/consts.ML Mon Mar 10 13:55:03 2014 +0100
@@ -11,8 +11,9 @@
val eq_consts: T * T -> bool
val retrieve_abbrevs: T -> string list -> term -> (term * term) list
val dest: T ->
- {constants: (typ * term option) Name_Space.table,
- constraints: typ Name_Space.table}
+ {const_space: Name_Space.T,
+ constants: (typ * term option) Symtab.table,
+ constraints: typ Symtab.table}
val the_const: T -> string -> string * typ (*exception TYPE*)
val the_abbreviation: T -> string -> typ * term (*exception TYPE*)
val type_scheme: T -> string -> typ (*exception TYPE*)
@@ -80,17 +81,18 @@
(* dest consts *)
-fun dest (Consts {decls = (space, decls), constraints, ...}) =
- {constants = (space,
- Symtab.fold (fn (c, ({T, ...}, abbr)) =>
- Symtab.update (c, (T, Option.map #rhs abbr))) decls Symtab.empty),
- constraints = (space, constraints)};
+fun dest (Consts {decls, constraints, ...}) =
+ {const_space = Name_Space.space_of_table decls,
+ constants =
+ Name_Space.fold_table (fn (c, ({T, ...}, abbr)) =>
+ Symtab.update (c, (T, Option.map #rhs abbr))) decls Symtab.empty,
+ constraints = constraints};
(* lookup consts *)
-fun the_entry (Consts {decls = (_, tab), ...}) c =
- (case Symtab.lookup_key tab c of
+fun the_entry (Consts {decls, ...}) c =
+ (case Name_Space.lookup_key decls c of
SOME entry => entry
| NONE => raise TYPE ("Unknown constant: " ^ quote c, [], []));
@@ -118,10 +120,10 @@
(* name space and syntax *)
-fun space_of (Consts {decls = (space, _), ...}) = space;
+fun space_of (Consts {decls, ...}) = Name_Space.space_of_table decls;
-fun alias naming binding name = map_consts (fn ((space, decls), constraints, rev_abbrevs) =>
- ((Name_Space.alias naming binding name space, decls), constraints, rev_abbrevs));
+fun alias naming binding name = map_consts (fn (decls, constraints, rev_abbrevs) =>
+ ((Name_Space.alias_table naming binding name decls), constraints, rev_abbrevs));
val is_concealed = Name_Space.is_concealed o space_of;
@@ -219,7 +221,7 @@
(* name space *)
fun hide fully c = map_consts (fn (decls, constraints, rev_abbrevs) =>
- (apfst (Name_Space.hide fully c) decls, constraints, rev_abbrevs));
+ (Name_Space.hide_table fully c decls, constraints, rev_abbrevs));
(* declarations *)
--- a/src/Pure/display.ML Mon Mar 10 10:13:47 2014 +0100
+++ b/src/Pure/display.ML Mon Mar 10 13:55:03 2014 +0100
@@ -145,33 +145,34 @@
fun pretty_restrict (const, name) =
Pretty.block ([prt_const' const, Pretty.brk 2, Pretty.str ("(from " ^ quote name ^ ")")]);
- val axioms = (Theory.axiom_space thy, Theory.axiom_table thy);
val defs = Theory.defs_of thy;
val {restricts, reducts} = Defs.dest defs;
val tsig = Sign.tsig_of thy;
val consts = Sign.consts_of thy;
- val {constants, constraints} = Consts.dest consts;
- val extern_const = Name_Space.extern ctxt (#1 constants);
+ val {const_space, constants, constraints} = Consts.dest consts;
+ val extern_const = Name_Space.extern ctxt const_space;
val {classes, default, types, ...} = Type.rep_tsig tsig;
val (class_space, class_algebra) = classes;
val classes = Sorts.classes_of class_algebra;
val arities = Sorts.arities_of class_algebra;
val clsses =
- Name_Space.dest_table ctxt (class_space,
- Symtab.make (map (fn ((c, _), cs) => (c, Sign.minimize_sort thy cs)) (Graph.dest classes)));
- val tdecls = Name_Space.dest_table ctxt types;
- val arties = Name_Space.dest_table ctxt (Type.type_space tsig, arities);
+ Name_Space.dest_table' ctxt class_space
+ (Symtab.make (map (fn ((c, _), cs) => (c, Sign.minimize_sort thy cs)) (Graph.dest classes)))
+ |> map (apfst #1);
+ val tdecls = Name_Space.dest_table ctxt types |> map (apfst #1);
+ val arties = Name_Space.dest_table' ctxt (Type.type_space tsig) arities |> map (apfst #1);
fun prune_const c = not verbose andalso Consts.is_concealed consts c;
- val cnsts = Name_Space.extern_table ctxt (#1 constants,
- Symtab.make (filter_out (prune_const o fst) (Symtab.dest (#2 constants))));
+ val cnsts =
+ Name_Space.extern_table' ctxt const_space
+ (Symtab.make (filter_out (prune_const o fst) (Symtab.dest constants)));
val log_cnsts = map_filter (fn (c, (ty, NONE)) => SOME (c, ty) | _ => NONE) cnsts;
val abbrevs = map_filter (fn (c, (ty, SOME t)) => SOME (c, (ty, t)) | _ => NONE) cnsts;
- val cnstrs = Name_Space.extern_table ctxt constraints;
+ val cnstrs = Name_Space.extern_table' ctxt const_space constraints;
- val axms = Name_Space.extern_table ctxt axioms;
+ val axms = Name_Space.extern_table ctxt (Theory.axiom_table thy);
val (reds0, (reds1, reds2)) = filter_out (prune_const o fst o fst) reducts
|> map (fn (lhs, rhs) =>
--- a/src/Pure/facts.ML Mon Mar 10 10:13:47 2014 +0100
+++ b/src/Pure/facts.ML Mon Mar 10 13:55:03 2014 +0100
@@ -140,8 +140,7 @@
fun facts_of (Facts {facts, ...}) = facts;
-val space_of = #1 o facts_of;
-val table_of = #2 o facts_of;
+val space_of = Name_Space.space_of_table o facts_of;
val is_concealed = Name_Space.is_concealed o space_of;
@@ -157,16 +156,16 @@
val intern = Name_Space.intern o space_of;
fun extern ctxt = Name_Space.extern ctxt o space_of;
-val defined = Symtab.defined o table_of;
+val defined = is_some oo (Name_Space.lookup_key o facts_of);
fun lookup context facts name =
- (case Symtab.lookup (table_of facts) name of
+ (case Name_Space.lookup_key (facts_of facts) name of
NONE => NONE
- | SOME (Static ths) => SOME (true, ths)
- | SOME (Dynamic f) => SOME (false, f context));
+ | SOME (_, Static ths) => SOME (true, ths)
+ | SOME (_, Dynamic f) => SOME (false, f context));
fun fold_static f =
- Symtab.fold (fn (name, Static ths) => f (name, ths) | _ => I) o table_of;
+ Name_Space.fold_table (fn (name, Static ths) => f (name, ths) | _ => I) o facts_of;
(* content difference *)
@@ -221,13 +220,10 @@
(* remove entries *)
-fun del name (Facts {facts = (space, tab), props}) =
- let
- val space' = Name_Space.hide true name space handle ERROR _ => space;
- val tab' = Symtab.delete_safe name tab;
- in make_facts (space', tab') props end;
+fun del name (Facts {facts, props}) =
+ make_facts (Name_Space.del_table name facts) props;
-fun hide fully name (Facts {facts = (space, tab), props}) =
- make_facts (Name_Space.hide fully name space, tab) props;
+fun hide fully name (Facts {facts, props}) =
+ make_facts (Name_Space.hide_table fully name facts) props;
end;
--- a/src/Pure/sign.ML Mon Mar 10 10:13:47 2014 +0100
+++ b/src/Pure/sign.ML Mon Mar 10 13:55:03 2014 +0100
@@ -192,7 +192,7 @@
fun mk_const thy (c, Ts) = Const (c, const_instance thy (c, Ts));
-val declared_tyname = Symtab.defined o #2 o #types o Type.rep_tsig o tsig_of;
+val declared_tyname = is_some oo (Name_Space.lookup_key o #types o Type.rep_tsig o tsig_of);
val declared_const = can o the_const_constraint;
--- a/src/Pure/term_sharing.ML Mon Mar 10 10:13:47 2014 +0100
+++ b/src/Pure/term_sharing.ML Mon Mar 10 13:55:03 2014 +0100
@@ -19,10 +19,10 @@
fun init thy =
let
- val {classes = (_, algebra), types = (_, types), ...} = Type.rep_tsig (Sign.tsig_of thy);
+ val {classes = (_, algebra), types, ...} = Type.rep_tsig (Sign.tsig_of thy);
val class = perhaps (try (#1 o Graph.get_entry (Sorts.classes_of algebra)));
- val tycon = perhaps (Option.map #1 o Symtab.lookup_key types);
+ val tycon = perhaps (Option.map #1 o Name_Space.lookup_key types);
val const = perhaps (try (#1 o Consts.the_const (Sign.consts_of thy)));
val typs = Unsynchronized.ref (Typtab.empty: unit Typtab.table);
--- a/src/Pure/theory.ML Mon Mar 10 10:13:47 2014 +0100
+++ b/src/Pure/theory.ML Mon Mar 10 13:55:03 2014 +0100
@@ -17,8 +17,8 @@
val requires: theory -> string -> string -> unit
val setup: (theory -> theory) -> unit
val get_markup: theory -> Markup.T
+ val axiom_table: theory -> term Name_Space.table
val axiom_space: theory -> Name_Space.T
- val axiom_table: theory -> term Symtab.table
val axioms_of: theory -> (string * term) list
val all_axioms_of: theory -> (string * term) list
val defs_of: theory -> Defs.T
@@ -139,10 +139,10 @@
(* basic operations *)
-val axiom_space = #1 o #axioms o rep_theory;
-val axiom_table = #2 o #axioms o rep_theory;
+val axiom_table = #axioms o rep_theory;
+val axiom_space = Name_Space.space_of_table o axiom_table;
-val axioms_of = Symtab.dest o #2 o #axioms o rep_theory;
+fun axioms_of thy = rev (Name_Space.fold_table cons (axiom_table thy) []);
fun all_axioms_of thy = maps axioms_of (nodes_of thy);
val defs_of = #defs o rep_theory;
--- a/src/Pure/thm.ML Mon Mar 10 10:13:47 2014 +0100
+++ b/src/Pure/thm.ML Mon Mar 10 13:55:03 2014 +0100
@@ -584,8 +584,8 @@
fun axiom theory name =
let
fun get_ax thy =
- Symtab.lookup (Theory.axiom_table thy) name
- |> Option.map (fn prop =>
+ Name_Space.lookup_key (Theory.axiom_table thy) name
+ |> Option.map (fn (_, prop) =>
let
val der = deriv_rule0 (Proofterm.axm_proof name prop);
val maxidx = maxidx_of_term prop;
@@ -602,7 +602,7 @@
(*return additional axioms of this theory node*)
fun axioms_of thy =
- map (fn s => (s, axiom thy s)) (Symtab.keys (Theory.axiom_table thy));
+ map (fn (name, _) => (name, axiom thy name)) (Theory.axioms_of thy);
(* tags *)
--- a/src/Pure/type.ML Mon Mar 10 10:13:47 2014 +0100
+++ b/src/Pure/type.ML Mon Mar 10 13:55:03 2014 +0100
@@ -177,7 +177,7 @@
fun build_tsig (classes, default, types) =
let
val log_types =
- Symtab.fold (fn (c, LogicalType n) => cons (c, n) | _ => I) (snd types) []
+ Name_Space.fold_table (fn (c, LogicalType n) => cons (c, n) | _ => I) types []
|> Library.sort (int_ord o pairself snd) |> map fst;
in make_tsig (classes, default, types, log_types) end;
@@ -237,17 +237,17 @@
(* types *)
-val type_space = #1 o #types o rep_tsig;
+val type_space = Name_Space.space_of_table o #types o rep_tsig;
-fun type_alias naming binding name = map_tsig (fn (classes, default, (space, types)) =>
- (classes, default, (Name_Space.alias naming binding name space, types)));
+fun type_alias naming binding name = map_tsig (fn (classes, default, types) =>
+ (classes, default, (Name_Space.alias_table naming binding name types)));
val is_logtype = member (op =) o logical_types;
fun undecl_type c = "Undeclared type constructor: " ^ quote c;
-fun lookup_type (TSig {types = (_, types), ...}) = Symtab.lookup types;
+fun lookup_type (TSig {types, ...}) = Option.map #2 o Name_Space.lookup_key types;
fun check_decl context (TSig {types, ...}) (c, pos) =
Name_Space.check_reports context types (c, [pos]);
@@ -639,14 +639,15 @@
fun map_types f = map_tsig (fn (classes, default, types) =>
let
- val (space', tab') = f types;
- val _ = Name_Space.intern space' "dummy" = "dummy" orelse
- error "Illegal declaration of dummy type";
- in (classes, default, (space', tab')) end);
+ val types' = f types;
+ val _ =
+ Name_Space.intern (Name_Space.space_of_table types') "dummy" = "dummy" orelse
+ error "Illegal declaration of dummy type";
+ in (classes, default, types') end);
-fun syntactic types (Type (c, Ts)) =
- (case Symtab.lookup types c of SOME Nonterminal => true | _ => false)
- orelse exists (syntactic types) Ts
+fun syntactic tsig (Type (c, Ts)) =
+ (case lookup_type tsig c of SOME Nonterminal => true | _ => false)
+ orelse exists (syntactic tsig) Ts
| syntactic _ _ = false;
in
@@ -669,14 +670,14 @@
(case subtract (op =) vs (map #1 (Term.add_tfreesT rhs' [])) of
[] => []
| extras => err ("Extra variables on rhs: " ^ commas_quote extras));
- in types |> new_decl context (a, Abbreviation (vs, rhs', syntactic (#2 types) rhs')) end);
+ in types |> new_decl context (a, Abbreviation (vs, rhs', syntactic tsig rhs')) end);
fun add_nonterminal context = map_types o new_decl context o rpair Nonterminal;
end;
-fun hide_type fully c = map_tsig (fn (classes, default, (space, types)) =>
- (classes, default, (Name_Space.hide fully c space, types)));
+fun hide_type fully c = map_tsig (fn (classes, default, types) =>
+ (classes, default, Name_Space.hide_table fully c types));
(* merge type signatures *)
--- a/src/Pure/variable.ML Mon Mar 10 10:13:47 2014 +0100
+++ b/src/Pure/variable.ML Mon Mar 10 13:55:03 2014 +0100
@@ -175,7 +175,7 @@
val names_of = #names o rep_data;
val fixes_of = #fixes o rep_data;
-val fixes_space = #1 o fixes_of;
+val fixes_space = Name_Space.space_of_table o fixes_of;
val binds_of = #binds o rep_data;
val type_occs_of = #type_occs o rep_data;
val maxidx_of = #maxidx o rep_data;
@@ -342,8 +342,8 @@
in if is_fixed ctxt x' then SOME x' else NONE end;
fun revert_fixed ctxt x =
- (case Symtab.lookup (#2 (fixes_of ctxt)) x of
- SOME x' => if intern_fixed ctxt x' = x then x' else x
+ (case Name_Space.lookup_key (fixes_of ctxt) x of
+ SOME (_, x') => if intern_fixed ctxt x' = x then x' else x
| NONE => x);
fun markup_fixed ctxt x =
@@ -351,8 +351,8 @@
|> Markup.name (revert_fixed ctxt x);
fun dest_fixes ctxt =
- let val (space, tab) = fixes_of ctxt
- in sort (Name_Space.entry_ord space o pairself #2) (map swap (Symtab.dest tab)) end;
+ Name_Space.fold_table (fn (x, y) => cons (y, x)) (fixes_of ctxt) []
+ |> sort (Name_Space.entry_ord (fixes_space ctxt) o pairself #2);
(* collect variables *)
@@ -383,8 +383,8 @@
let val context = Context.Proof ctxt |> Name_Space.map_naming (K Name_Space.default_naming) in
ctxt
|> map_fixes
- (Name_Space.define context true (Binding.make (x', pos), x) #> snd #>>
- Name_Space.alias Name_Space.default_naming (Binding.make (x, pos)) x')
+ (Name_Space.define context true (Binding.make (x', pos), x) #> snd #>
+ Name_Space.alias_table Name_Space.default_naming (Binding.make (x, pos)) x')
|> declare_fixed x
|> declare_constraints (Syntax.free x')
end;
@@ -450,8 +450,8 @@
val still_fixed = not o newly_fixed inner outer;
val gen_fixes =
- Symtab.fold (fn (y, _) => not (is_fixed outer y) ? cons y)
- (#2 (fixes_of inner)) [];
+ Name_Space.fold_table (fn (y, _) => not (is_fixed outer y) ? cons y)
+ (fixes_of inner) [];
val type_occs_inner = type_occs_of inner;
fun gen_fixesT ts =
--- a/src/Tools/Code/code_thingol.ML Mon Mar 10 10:13:47 2014 +0100
+++ b/src/Tools/Code/code_thingol.ML Mon Mar 10 13:55:03 2014 +0100
@@ -877,7 +877,7 @@
let
val thy = Proof_Context.theory_of ctxt;
fun consts_of thy' = Symtab.fold (fn (c, (_, NONE)) => cons c | _ => I)
- ((snd o #constants o Consts.dest o Sign.consts_of) thy') [];
+ (#constants (Consts.dest (Sign.consts_of thy'))) [];
fun belongs_here thy' c = forall
(fn thy'' => not (Sign.declared_const thy'' c)) (Theory.parents_of thy');
fun consts_of_select thy' = filter (belongs_here thy') (consts_of thy');