11 (*constants*) |
11 (*constants*) |
12 val check_const: theory -> term -> string |
12 val check_const: theory -> term -> string |
13 val read_bare_const: theory -> string -> string * typ |
13 val read_bare_const: theory -> string -> string * typ |
14 val read_const: theory -> string -> string |
14 val read_const: theory -> string -> string |
15 val string_of_const: theory -> string -> string |
15 val string_of_const: theory -> string -> string |
16 val cert_signature: theory -> typ -> typ |
|
17 val read_signature: theory -> string -> typ |
|
18 val const_typ: theory -> string -> typ |
16 val const_typ: theory -> string -> typ |
19 val subst_signatures: theory -> term -> term |
|
20 val args_number: theory -> string -> int |
17 val args_number: theory -> string -> int |
21 |
18 |
22 (*constructor sets*) |
19 (*constructor sets*) |
23 val constrset_of_consts: theory -> (string * typ) list |
20 val constrset_of_consts: theory -> (string * typ) list |
24 -> string * ((string * sort) list * (string * ((string * sort) list * typ list)) list) |
21 -> string * ((string * sort) list * (string * ((string * sort) list * typ list)) list) |
39 * (((term * string option) list * (term * string option)) * (thm option * bool)) list |
36 * (((term * string option) list * (term * string option)) * (thm option * bool)) list |
40 val bare_thms_of_cert: theory -> cert -> thm list |
37 val bare_thms_of_cert: theory -> cert -> thm list |
41 val pretty_cert: theory -> cert -> Pretty.T list |
38 val pretty_cert: theory -> cert -> Pretty.T list |
42 |
39 |
43 (*executable code*) |
40 (*executable code*) |
44 val add_type: string -> theory -> theory |
|
45 val add_type_cmd: string -> theory -> theory |
|
46 val add_signature: string * typ -> theory -> theory |
|
47 val add_signature_cmd: string * string -> theory -> theory |
|
48 val add_datatype: (string * typ) list -> theory -> theory |
41 val add_datatype: (string * typ) list -> theory -> theory |
49 val add_datatype_cmd: string list -> theory -> theory |
42 val add_datatype_cmd: string list -> theory -> theory |
50 val datatype_interpretation: |
43 val datatype_interpretation: |
51 (string * ((string * sort) list * (string * ((string * sort) list * typ list)) list) |
44 (string * ((string * sort) list * (string * ((string * sort) list * typ list)) list) |
52 -> theory -> theory) -> theory -> theory |
45 -> theory -> theory) -> theory -> theory |
182 |
175 |
183 (* executable code data *) |
176 (* executable code data *) |
184 |
177 |
185 datatype spec = Spec of { |
178 datatype spec = Spec of { |
186 history_concluded: bool, |
179 history_concluded: bool, |
187 signatures: int Symtab.table * typ Symtab.table, |
|
188 functions: ((bool * fun_spec) * (serial * fun_spec) list) Symtab.table |
180 functions: ((bool * fun_spec) * (serial * fun_spec) list) Symtab.table |
189 (*with explicit history*), |
181 (*with explicit history*), |
190 types: ((serial * ((string * sort) list * typ_spec)) list) Symtab.table |
182 types: ((serial * ((string * sort) list * typ_spec)) list) Symtab.table |
191 (*with explicit history*), |
183 (*with explicit history*), |
192 cases: ((int * (int * string list)) * thm) Symtab.table * unit Symtab.table |
184 cases: ((int * (int * string list)) * thm) Symtab.table * unit Symtab.table |
193 }; |
185 }; |
194 |
186 |
195 fun make_spec (history_concluded, ((signatures, functions), (types, cases))) = |
187 fun make_spec (history_concluded, (functions, (types, cases))) = |
196 Spec { history_concluded = history_concluded, |
188 Spec { history_concluded = history_concluded, functions = functions, types = types, cases = cases }; |
197 signatures = signatures, functions = functions, types = types, cases = cases }; |
189 fun map_spec f (Spec { history_concluded = history_concluded, |
198 fun map_spec f (Spec { history_concluded = history_concluded, signatures = signatures, |
|
199 functions = functions, types = types, cases = cases }) = |
190 functions = functions, types = types, cases = cases }) = |
200 make_spec (f (history_concluded, ((signatures, functions), (types, cases)))); |
191 make_spec (f (history_concluded, (functions, (types, cases)))); |
201 fun merge_spec (Spec { history_concluded = _, signatures = (tycos1, sigs1), functions = functions1, |
192 fun merge_spec (Spec { history_concluded = _, functions = functions1, |
202 types = types1, cases = (cases1, undefs1) }, |
193 types = types1, cases = (cases1, undefs1) }, |
203 Spec { history_concluded = _, signatures = (tycos2, sigs2), functions = functions2, |
194 Spec { history_concluded = _, functions = functions2, |
204 types = types2, cases = (cases2, undefs2) }) = |
195 types = types2, cases = (cases2, undefs2) }) = |
205 let |
196 let |
206 val signatures = (Symtab.merge (op =) (tycos1, tycos2), |
|
207 Symtab.merge typ_equiv (sigs1, sigs2)); |
|
208 val types = Symtab.join (K (AList.merge (op =) (K true))) (types1, types2); |
197 val types = Symtab.join (K (AList.merge (op =) (K true))) (types1, types2); |
209 val case_consts_of' = (maps case_consts_of o map (snd o snd o hd o snd) o Symtab.dest); |
198 val case_consts_of' = (maps case_consts_of o map (snd o snd o hd o snd) o Symtab.dest); |
210 fun merge_functions ((_, history1), (_, history2)) = |
199 fun merge_functions ((_, history1), (_, history2)) = |
211 let |
200 let |
212 val raw_history = AList.merge (op = : serial * serial -> bool) |
201 val raw_history = AList.merge (op = : serial * serial -> bool) |
221 |> subtract (op =) (maps case_consts_of all_datatype_specs) |
210 |> subtract (op =) (maps case_consts_of all_datatype_specs) |
222 val functions = Symtab.join (K merge_functions) (functions1, functions2) |
211 val functions = Symtab.join (K merge_functions) (functions1, functions2) |
223 |> fold (fn c => Symtab.map_entry c (apfst (K (true, empty_fun_spec)))) all_constructors; |
212 |> fold (fn c => Symtab.map_entry c (apfst (K (true, empty_fun_spec)))) all_constructors; |
224 val cases = (Symtab.merge (K true) (cases1, cases2) |
213 val cases = (Symtab.merge (K true) (cases1, cases2) |
225 |> fold Symtab.delete invalidated_case_consts, Symtab.merge (K true) (undefs1, undefs2)); |
214 |> fold Symtab.delete invalidated_case_consts, Symtab.merge (K true) (undefs1, undefs2)); |
226 in make_spec (false, ((signatures, functions), (types, cases))) end; |
215 in make_spec (false, (functions, (types, cases))) end; |
227 |
216 |
228 fun history_concluded (Spec { history_concluded, ... }) = history_concluded; |
217 fun history_concluded (Spec { history_concluded, ... }) = history_concluded; |
229 fun the_signatures (Spec { signatures, ... }) = signatures; |
|
230 fun the_functions (Spec { functions, ... }) = functions; |
218 fun the_functions (Spec { functions, ... }) = functions; |
231 fun the_types (Spec { types, ... }) = types; |
219 fun the_types (Spec { types, ... }) = types; |
232 fun the_cases (Spec { cases, ... }) = cases; |
220 fun the_cases (Spec { cases, ... }) = cases; |
233 val map_history_concluded = map_spec o apfst; |
221 val map_history_concluded = map_spec o apfst; |
234 val map_signatures = map_spec o apsnd o apfst o apfst; |
222 val map_functions = map_spec o apsnd o apfst; |
235 val map_functions = map_spec o apsnd o apfst o apsnd; |
|
236 val map_typs = map_spec o apsnd o apsnd o apfst; |
223 val map_typs = map_spec o apsnd o apsnd o apfst; |
237 val map_cases = map_spec o apsnd o apsnd o apsnd; |
224 val map_cases = map_spec o apsnd o apsnd o apsnd; |
238 |
225 |
239 |
226 |
240 (* data slots dependent on executable code *) |
227 (* data slots dependent on executable code *) |
275 fun empty_dataref () = Synchronized.var "code data" (NONE : (data * theory_ref) option); |
262 fun empty_dataref () = Synchronized.var "code data" (NONE : (data * theory_ref) option); |
276 |
263 |
277 structure Code_Data = Theory_Data |
264 structure Code_Data = Theory_Data |
278 ( |
265 ( |
279 type T = spec * (data * theory_ref) option Synchronized.var; |
266 type T = spec * (data * theory_ref) option Synchronized.var; |
280 val empty = (make_spec (false, (((Symtab.empty, Symtab.empty), Symtab.empty), |
267 val empty = (make_spec (false, (Symtab.empty, |
281 (Symtab.empty, (Symtab.empty, Symtab.empty)))), empty_dataref ()); |
268 (Symtab.empty, (Symtab.empty, Symtab.empty)))), empty_dataref ()); |
282 val extend = I (* FIXME empty_dataref!?! *) |
269 val extend = I (* FIXME empty_dataref!?! *) |
283 fun merge ((spec1, _), (spec2, _)) = |
270 fun merge ((spec1, _), (spec2, _)) = |
284 (merge_spec (spec1, spec2), empty_dataref ()); |
271 (merge_spec (spec1, spec2), empty_dataref ()); |
285 ); |
272 ); |
342 |
329 |
343 (** foundation **) |
330 (** foundation **) |
344 |
331 |
345 (* constants *) |
332 (* constants *) |
346 |
333 |
347 fun arity_number thy tyco = case Symtab.lookup ((fst o the_signatures o the_exec) thy) tyco |
334 fun const_typ thy = Type.strip_sorts o Sign.the_const_type thy; |
348 of SOME n => n |
|
349 | NONE => Sign.arity_number thy tyco; |
|
350 |
|
351 fun build_tsig thy = |
|
352 let |
|
353 val ctxt = Syntax.init_pretty_global thy; |
|
354 val (tycos, _) = the_signatures (the_exec thy); |
|
355 val decls = #types (Type.rep_tsig (Sign.tsig_of thy)) |
|
356 |> snd |
|
357 |> Symtab.fold (fn (tyco, n) => |
|
358 Symtab.update (tyco, Type.LogicalType n)) tycos; |
|
359 in |
|
360 Type.empty_tsig |
|
361 |> Symtab.fold (fn (tyco, Type.LogicalType n) => Type.add_type ctxt Name_Space.default_naming |
|
362 (Binding.qualified_name tyco, n) | _ => I) decls |
|
363 end; |
|
364 |
|
365 fun cert_signature thy = |
|
366 Logic.varifyT_global o Type.cert_typ (build_tsig thy) o Type.no_tvars; |
|
367 |
|
368 fun read_signature thy = |
|
369 cert_signature thy o Type.strip_sorts o Syntax.parse_typ (Proof_Context.init_global thy); |
|
370 |
|
371 fun expand_signature thy = Type.cert_typ_mode Type.mode_syntax (Sign.tsig_of thy); |
|
372 |
|
373 fun lookup_typ thy = Symtab.lookup ((snd o the_signatures o the_exec) thy); |
|
374 |
|
375 fun const_typ thy c = case lookup_typ thy c |
|
376 of SOME ty => ty |
|
377 | NONE => (Type.strip_sorts o Sign.the_const_type thy) c; |
|
378 |
335 |
379 fun args_number thy = length o binder_types o const_typ thy; |
336 fun args_number thy = length o binder_types o const_typ thy; |
380 |
|
381 fun subst_signature thy c ty = |
|
382 let |
|
383 fun mk_subst (Type (_, tys1)) (Type (_, tys2)) = |
|
384 fold2 mk_subst tys1 tys2 |
|
385 | mk_subst ty (TVar (v, _)) = Vartab.update (v, ([], ty)) |
|
386 in case lookup_typ thy c |
|
387 of SOME ty' => Envir.subst_type (mk_subst ty (expand_signature thy ty') Vartab.empty) ty' |
|
388 | NONE => ty |
|
389 end; |
|
390 |
|
391 fun subst_signatures thy = map_aterms (fn Const (c, ty) => Const (c, subst_signature thy c ty) | t => t); |
|
392 |
337 |
393 fun logical_typscheme thy (c, ty) = |
338 fun logical_typscheme thy (c, ty) = |
394 (map dest_TFree (Sign.const_typargs thy (c, ty)), Type.strip_sorts ty); |
339 (map dest_TFree (Sign.const_typargs thy (c, ty)), Type.strip_sorts ty); |
395 |
340 |
396 fun typscheme thy (c, ty) = logical_typscheme thy (c, subst_signature thy c ty); |
341 fun typscheme thy (c, ty) = logical_typscheme thy (c, ty); |
397 |
342 |
398 |
343 |
399 (* datatypes *) |
344 (* datatypes *) |
400 |
345 |
401 fun no_constr thy s (c, ty) = error ("Not a datatype constructor:\n" ^ string_of_const thy c |
346 fun no_constr thy s (c, ty) = error ("Not a datatype constructor:\n" ^ string_of_const thy c |
402 ^ " :: " ^ string_of_typ thy ty ^ "\n" ^ enclose "(" ")" s); |
347 ^ " :: " ^ string_of_typ thy ty ^ "\n" ^ enclose "(" ")" s); |
403 |
348 |
404 fun analyze_constructor thy (c, raw_ty) = |
349 fun analyze_constructor thy (c, ty) = |
405 let |
350 let |
406 val _ = Thm.cterm_of thy (Const (c, raw_ty)); |
351 val _ = Thm.cterm_of thy (Const (c, ty)); |
407 val ty = subst_signature thy c raw_ty; |
|
408 val ty_decl = Logic.unvarifyT_global (const_typ thy c); |
352 val ty_decl = Logic.unvarifyT_global (const_typ thy c); |
409 fun last_typ c_ty ty = |
353 fun last_typ c_ty ty = |
410 let |
354 let |
411 val tfrees = Term.add_tfreesT ty []; |
355 val tfrees = Term.add_tfreesT ty []; |
412 val (tyco, vs) = (apsnd o map) dest_TFree (dest_Type (body_type ty)) |
356 val (tyco, vs) = (apsnd o map) dest_TFree (dest_Type (body_type ty)) |
535 | check _ (Var _) = bad "Variable with application on left hand side of equation" |
479 | check _ (Var _) = bad "Variable with application on left hand side of equation" |
536 | check n (t1 $ t2) = (check (n+1) t1; check 0 t2) |
480 | check n (t1 $ t2) = (check (n+1) t1; check 0 t2) |
537 | check n (Const (c_ty as (c, ty))) = |
481 | check n (Const (c_ty as (c, ty))) = |
538 if allow_pats then let |
482 if allow_pats then let |
539 val c' = AxClass.unoverload_const thy c_ty |
483 val c' = AxClass.unoverload_const thy c_ty |
540 in if n = (length o binder_types o subst_signature thy c') ty |
484 in if n = (length o binder_types) ty |
541 then if allow_consts orelse is_constr thy c' |
485 then if allow_consts orelse is_constr thy c' |
542 then () |
486 then () |
543 else bad (quote c ^ " is not a constructor, on left hand side of equation") |
487 else bad (quote c ^ " is not a constructor, on left hand side of equation") |
544 else bad ("Partially applied constant " ^ quote c ^ " on left hand side of equation") |
488 else bad ("Partially applied constant " ^ quote c ^ " on left hand side of equation") |
545 end else bad ("Pattern not allowed here, but constant " ^ quote c ^ " encountered on left hand side") |
489 end else bad ("Pattern not allowed here, but constant " ^ quote c ^ " encountered on left hand side") |
745 val raw_concrete_thm = Drule.transitive_thm OF [Thm.symmetric cert, Thm.combination (Thm.reflexive abs) abs_thm]; |
689 val raw_concrete_thm = Drule.transitive_thm OF [Thm.symmetric cert, Thm.combination (Thm.reflexive abs) abs_thm]; |
746 in (c, (Thm.varifyT_global o zero_var_indexes) raw_concrete_thm) end; |
690 in (c, (Thm.varifyT_global o zero_var_indexes) raw_concrete_thm) end; |
747 |
691 |
748 fun add_rhss_of_eqn thy t = |
692 fun add_rhss_of_eqn thy t = |
749 let |
693 let |
750 val (args, rhs) = (apfst (snd o strip_comb) o Logic.dest_equals o subst_signatures thy) t; |
694 val (args, rhs) = (apfst (snd o strip_comb) o Logic.dest_equals) t; |
751 fun add_const (Const (c, ty)) = insert (op =) (c, Sign.const_typargs thy (c, ty)) |
695 fun add_const (Const (c, ty)) = insert (op =) (c, Sign.const_typargs thy (c, ty)) |
752 | add_const _ = I |
696 | add_const _ = I |
753 val add_consts = fold_aterms add_const |
697 val add_consts = fold_aterms add_const |
754 in add_consts rhs o fold add_consts args end; |
698 in add_consts rhs o fold add_consts args end; |
755 |
699 |
756 fun dest_eqn thy = |
700 fun dest_eqn thy = |
757 apfst (snd o strip_comb) o Logic.dest_equals o subst_signatures thy o Logic.unvarify_global; |
701 apfst (snd o strip_comb) o Logic.dest_equals o Logic.unvarify_global; |
758 |
702 |
759 abstype cert = Equations of thm * bool list |
703 abstype cert = Equations of thm * bool list |
760 | Projection of term * string |
704 | Projection of term * string |
761 | Abstract of thm * string |
705 | Abstract of thm * string |
762 with |
706 with |
1042 end; |
986 end; |
1043 |
987 |
1044 |
988 |
1045 (** declaring executable ingredients **) |
989 (** declaring executable ingredients **) |
1046 |
990 |
1047 (* constant signatures *) |
|
1048 |
|
1049 fun add_type tyco thy = |
|
1050 case Symtab.lookup ((snd o #types o Type.rep_tsig o Sign.tsig_of) thy) tyco |
|
1051 of SOME (Type.Abbreviation (vs, _, _)) => |
|
1052 (map_exec_purge o map_signatures o apfst) |
|
1053 (Symtab.update (tyco, length vs)) thy |
|
1054 | _ => error ("No such type abbreviation: " ^ quote tyco); |
|
1055 |
|
1056 fun add_type_cmd s thy = add_type (Sign.intern_type thy s) thy; |
|
1057 |
|
1058 fun gen_add_signature prep_const prep_signature (raw_c, raw_ty) thy = |
|
1059 let |
|
1060 val c = prep_const thy raw_c; |
|
1061 val ty = prep_signature thy raw_ty; |
|
1062 val ty' = expand_signature thy ty; |
|
1063 val ty'' = Sign.the_const_type thy c; |
|
1064 val _ = if typ_equiv (ty', ty'') then () else |
|
1065 error ("Illegal constant signature: " ^ Syntax.string_of_typ_global thy ty); |
|
1066 in |
|
1067 thy |
|
1068 |> (map_exec_purge o map_signatures o apsnd) (Symtab.update (c, ty)) |
|
1069 end; |
|
1070 |
|
1071 val add_signature = gen_add_signature (K I) cert_signature; |
|
1072 val add_signature_cmd = gen_add_signature read_const read_signature; |
|
1073 |
|
1074 |
|
1075 (* code equations *) |
991 (* code equations *) |
1076 |
992 |
1077 fun gen_add_eqn default (raw_thm, proper) thy = |
993 fun gen_add_eqn default (raw_thm, proper) thy = |
1078 let |
994 let |
1079 val thm = Thm.close_derivation raw_thm; |
995 val thm = Thm.close_derivation raw_thm; |