29 val untag: tag -> 'a attribute |
29 val untag: tag -> 'a attribute |
30 val lemma: tag |
30 val lemma: tag |
31 val assumption: tag |
31 val assumption: tag |
32 val tag_lemma: 'a attribute |
32 val tag_lemma: 'a attribute |
33 val tag_assumption: 'a attribute |
33 val tag_assumption: 'a attribute |
34 val setup: theory -> theory |
34 val setup: (theory -> theory) list |
35 val global_attr: theory -> (xstring * string list) -> theory attribute |
35 val global_attr: theory -> (xstring * string list) -> theory attribute |
36 val local_attr: theory -> (xstring * string list) -> local_theory attribute |
36 val local_attr: theory -> (xstring * string list) -> local_theory attribute |
37 val add_attrs: (bstring * ((string list -> theory attribute) * |
37 val add_attributes: (bstring * (string list -> theory attribute) * |
38 (string list -> local_theory attribute))) list -> theory -> theory |
38 (string list -> local_theory attribute) * string) list -> theory -> theory |
39 end; |
39 end; |
40 |
40 |
41 structure Attribute: ATTRIBUTE = |
41 structure Attribute: ATTRIBUTE = |
42 struct |
42 struct |
43 |
43 |
103 |
103 |
104 (** theory data **) |
104 (** theory data **) |
105 |
105 |
106 (* data kind 'attributes' *) |
106 (* data kind 'attributes' *) |
107 |
107 |
108 val attributesK = "Pure/attributes"; |
108 local |
|
109 val attributesK = Object.kind "Pure/attributes"; |
109 |
110 |
110 exception Attributes of |
111 exception Attributes of |
111 {space: NameSpace.T, |
112 {space: NameSpace.T, |
112 attrs: |
113 attrs: |
113 ((string list -> theory attribute) * |
114 ((((string list -> theory attribute) * (string list -> local_theory attribute)) |
114 (string list -> local_theory attribute)) Symtab.table}; |
115 * string) * stamp) Symtab.table}; |
115 |
|
116 fun print_attributes thy = Display.print_data thy attributesK; |
|
117 |
116 |
118 |
117 |
119 (* setup *) |
|
120 |
|
121 local |
|
122 val empty = Attributes {space = NameSpace.empty, attrs = Symtab.empty}; |
118 val empty = Attributes {space = NameSpace.empty, attrs = Symtab.empty}; |
123 |
119 |
124 fun prep_ext (x as Attributes _) = x; |
120 fun prep_ext (x as Attributes _) = x; |
125 |
121 |
126 fun merge (Attributes {space = space1, attrs = attrs1}, |
122 fun merge (Attributes {space = space1, attrs = attrs1}, |
127 Attributes {space = space2, attrs = attrs2}) = |
123 Attributes {space = space2, attrs = attrs2}) = |
128 Attributes { |
124 Attributes { |
129 space = NameSpace.merge (space1, space2), |
125 space = NameSpace.merge (space1, space2), |
130 attrs = Symtab.merge (K true) (attrs1, attrs2)}; |
126 attrs = Symtab.merge eq_snd (attrs1, attrs2) handle Symtab.DUPS dups => |
|
127 error ("Attempt to merge different versions of attributes " ^ commas_quote dups)}; |
|
128 |
|
129 fun pretty_attr (name, ((_, comment), _)) = Pretty.block |
|
130 [Pretty.str (name ^ ":"), Pretty.brk 2, Pretty.str comment]; |
131 |
131 |
132 fun print _ (Attributes {space, attrs}) = |
132 fun print _ (Attributes {space, attrs}) = |
133 (Pretty.writeln (Display.pretty_name_space ("attribute name space", space)); |
133 (Pretty.writeln (Display.pretty_name_space ("attribute name space", space)); |
134 Pretty.writeln (Pretty.strs ("attributes:" :: map fst (Symtab.dest attrs)))); |
134 Pretty.writeln (Pretty.big_list "attributes:" (map pretty_attr (Symtab.dest attrs)))); |
135 in |
135 in |
136 val setup = Theory.init_data [(attributesK, (empty, prep_ext, merge, print))]; |
136 val init_attributes = Theory.init_data attributesK (empty, prep_ext, merge, print); |
|
137 val print_attributes = Theory.print_data attributesK; |
|
138 val get_attributes = Theory.get_data attributesK (fn Attributes x => x); |
|
139 val put_attributes = Theory.put_data attributesK Attributes; |
137 end; |
140 end; |
138 |
|
139 |
|
140 (* get data record *) |
|
141 |
|
142 fun get_attributes_sg sg = |
|
143 (case Sign.get_data sg attributesK of |
|
144 Attributes x => x |
|
145 | _ => type_error attributesK); |
|
146 |
|
147 val get_attributes = get_attributes_sg o Theory.sign_of; |
|
148 |
141 |
149 |
142 |
150 (* get global / local attributes *) |
143 (* get global / local attributes *) |
151 |
144 |
152 fun gen_attr which thy = |
145 fun gen_attr which thy = |
155 val intern = NameSpace.intern space; |
148 val intern = NameSpace.intern space; |
156 |
149 |
157 fun attr (raw_name, args) x_th = |
150 fun attr (raw_name, args) x_th = |
158 (case Symtab.lookup (attrs, intern raw_name) of |
151 (case Symtab.lookup (attrs, intern raw_name) of |
159 None => raise FAIL (intern raw_name, "unknown attribute") |
152 None => raise FAIL (intern raw_name, "unknown attribute") |
160 | Some p => which p args x_th); |
153 | Some ((p, _), _) => which p args x_th); |
161 in attr end; |
154 in attr end; |
162 |
155 |
163 val global_attr = gen_attr fst; |
156 val global_attr = gen_attr fst; |
164 val local_attr = gen_attr snd; |
157 val local_attr = gen_attr snd; |
165 |
158 |
166 |
159 |
167 (* add_attrs *) |
160 (* add_attributes *) |
168 |
161 |
169 fun add_attrs raw_attrs thy = |
162 fun add_attributes raw_attrs thy = |
170 let |
163 let |
171 val full = Sign.full_name (Theory.sign_of thy); |
164 val full = Sign.full_name (Theory.sign_of thy); |
172 val new_attrs = map (apfst full) raw_attrs; |
165 val new_attrs = |
|
166 map (fn (name, f, g, comment) => (full name, (((f, g), comment), stamp ()))) raw_attrs; |
173 |
167 |
174 val {space, attrs} = get_attributes thy; |
168 val {space, attrs} = get_attributes thy; |
175 val space' = NameSpace.extend (space, map fst new_attrs); |
169 val space' = NameSpace.extend (space, map fst new_attrs); |
176 val attrs' = Symtab.extend (attrs, new_attrs) |
170 val attrs' = Symtab.extend (attrs, new_attrs) handle Symtab.DUPS dups => |
177 handle Symtab.DUPS dups => |
171 error ("Duplicate declaration of attributes(s) " ^ commas_quote dups); |
178 error ("Duplicate declaration of attributes(s) " ^ commas_quote dups); |
|
179 in |
172 in |
180 Theory.put_data (attributesK, Attributes {space = space', attrs = attrs'}) thy |
173 thy |> put_attributes {space = space', attrs = attrs'} |
181 end; |
174 end; |
|
175 |
|
176 |
|
177 (* setup *) (* FIXME add_attributes: lemma etc. *) |
|
178 |
|
179 val setup = |
|
180 [init_attributes]; |
182 |
181 |
183 |
182 |
184 end; |
183 end; |
185 |
184 |
186 |
185 |