47 val merge_refs: theory_ref * theory_ref -> theory_ref (*exception TERM*) |
47 val merge_refs: theory_ref * theory_ref -> theory_ref (*exception TERM*) |
48 val requires: theory -> string -> string -> unit |
48 val requires: theory -> string -> string -> unit |
49 val assert_super: theory -> theory -> theory |
49 val assert_super: theory -> theory -> theory |
50 val add_axioms: (bstring * string) list -> theory -> theory |
50 val add_axioms: (bstring * string) list -> theory -> theory |
51 val add_axioms_i: (bstring * term) list -> theory -> theory |
51 val add_axioms_i: (bstring * term) list -> theory -> theory |
|
52 val add_deps: string -> string * typ -> (string * typ) list -> theory -> theory |
52 val add_defs: bool -> bool -> (bstring * string) list -> theory -> theory |
53 val add_defs: bool -> bool -> (bstring * string) list -> theory -> theory |
53 val add_defs_i: bool -> bool -> (bstring * term) list -> theory -> theory |
54 val add_defs_i: bool -> bool -> (bstring * term) list -> theory -> theory |
54 val add_finals: bool -> string list -> theory -> theory |
55 val add_finals: bool -> string list -> theory -> theory |
55 val add_finals_i: bool -> term list -> theory -> theory |
56 val add_finals_i: bool -> term list -> theory -> theory |
56 val add_oracle: bstring * (theory * Object.T -> term) -> theory -> theory |
57 val add_oracle: bstring * (theory * Object.T -> term) -> theory -> theory |
57 end |
58 end |
58 |
59 |
59 structure Theory: THEORY = |
60 structure Theory: THEORY = |
60 struct |
61 struct |
|
62 |
61 |
63 |
62 (** type theory **) |
64 (** type theory **) |
63 |
65 |
64 (* context operations *) |
66 (* context operations *) |
65 |
67 |
228 |
230 |
229 |
231 |
230 |
232 |
231 (** add constant definitions **) |
233 (** add constant definitions **) |
232 |
234 |
233 fun prep_const thy (c, T) = (c, Compress.typ thy (Type.varifyT T)); |
235 (* dependencies *) |
|
236 |
|
237 fun dependencies thy unchecked is_def name lhs rhs = |
|
238 let |
|
239 val pp = Sign.pp thy; |
|
240 val consts = Sign.consts_of thy; |
|
241 |
|
242 val lhs_vars = Term.add_tfreesT (#2 lhs) []; |
|
243 val rhs_extras = fold (#2 #> Term.fold_atyps (fn TFree v => |
|
244 if member (op =) lhs_vars v then I else insert (op =) v | _ => I)) rhs []; |
|
245 val _ = |
|
246 if null rhs_extras then () |
|
247 else error ("Specification depends on extra type variables: " ^ |
|
248 commas_quote (map (Pretty.string_of_typ pp o TFree) rhs_extras) ^ |
|
249 "\nThe error(s) above occurred in " ^ quote name); |
|
250 |
|
251 fun prep const = |
|
252 let val Const (c, T) = Sign.no_vars pp (Const const) |
|
253 in (c, Compress.typ thy (Type.varifyT T)) end; |
|
254 in |
|
255 Defs.define pp consts unchecked is_def (Context.theory_name thy) name (prep lhs) (map prep rhs) |
|
256 end; |
|
257 |
|
258 fun add_deps a raw_lhs raw_rhs thy = |
|
259 let |
|
260 val lhs :: rhs = map (dest_Const o Sign.cert_term thy o Const) (raw_lhs :: raw_rhs); |
|
261 val name = if a = "" then (#1 lhs ^ " axiom") else a; |
|
262 in thy |> map_defs (dependencies thy false false name lhs rhs) end; |
234 |
263 |
235 |
264 |
236 (* check_overloading *) |
265 (* check_overloading *) |
237 |
266 |
238 fun check_overloading thy overloaded (c, T) = |
267 fun check_overloading thy overloaded (c, T) = |
264 let |
293 let |
265 val name = Sign.full_name thy bname; |
294 val name = Sign.full_name thy bname; |
266 val (lhs_const, rhs) = Sign.cert_def (Sign.pp thy) tm; |
295 val (lhs_const, rhs) = Sign.cert_def (Sign.pp thy) tm; |
267 val rhs_consts = fold_aterms (fn Const const => insert (op =) const | _ => I) rhs []; |
296 val rhs_consts = fold_aterms (fn Const const => insert (op =) const | _ => I) rhs []; |
268 val _ = check_overloading thy overloaded lhs_const; |
297 val _ = check_overloading thy overloaded lhs_const; |
269 in |
298 in defs |> dependencies thy unchecked true name lhs_const rhs_consts end |
270 defs |> Defs.define (Sign.pp thy) (Sign.consts_of thy) unchecked true (Context.theory_name thy) |
|
271 name (prep_const thy lhs_const) (map (prep_const thy) rhs_consts) |
|
272 end |
|
273 handle ERROR msg => cat_error msg (Pretty.string_of (Pretty.block |
299 handle ERROR msg => cat_error msg (Pretty.string_of (Pretty.block |
274 [Pretty.str ("The error(s) above occurred in definition " ^ quote bname ^ ":"), |
300 [Pretty.str ("The error(s) above occurred in definition " ^ quote bname ^ ":"), |
275 Pretty.fbrk, Pretty.quote (Sign.pretty_term thy tm)])); |
301 Pretty.fbrk, Pretty.quote (Sign.pretty_term thy tm)])); |
276 |
302 |
277 |
303 |
301 fun gen_add_finals prep_term overloaded args thy = |
327 fun gen_add_finals prep_term overloaded args thy = |
302 let |
328 let |
303 fun const_of (Const const) = const |
329 fun const_of (Const const) = const |
304 | const_of (Free _) = error "Attempt to finalize variable (or undeclared constant)" |
330 | const_of (Free _) = error "Attempt to finalize variable (or undeclared constant)" |
305 | const_of _ = error "Attempt to finalize non-constant term"; |
331 | const_of _ = error "Attempt to finalize non-constant term"; |
306 fun specify (c, T) = Defs.define (Sign.pp thy) (Sign.consts_of thy) false false |
332 fun specify (c, T) = dependencies thy false false (c ^ " axiom") (c, T) []; |
307 (Context.theory_name thy) (c ^ " axiom") (prep_const thy (c, T)) []; |
333 val finalize = specify o check_overloading thy overloaded o const_of o prep_term thy; |
308 val finalize = specify o check_overloading thy overloaded o |
|
309 const_of o Sign.no_vars (Sign.pp thy) o prep_term thy; |
|
310 in thy |> map_defs (fold finalize args) end; |
334 in thy |> map_defs (fold finalize args) end; |
311 |
335 |
312 in |
336 in |
313 |
337 |
314 val add_finals = gen_add_finals Sign.read_term; |
338 val add_finals = gen_add_finals Sign.read_term; |