20 val add_typedef_i: bool -> string option -> bstring * string list * mixfix -> |
20 val add_typedef_i: bool -> string option -> bstring * string list * mixfix -> |
21 term -> (bstring * bstring) option -> tactic -> theory -> theory * |
21 term -> (bstring * bstring) option -> tactic -> theory -> theory * |
22 {type_definition: thm, set_def: thm option, Rep: thm, Rep_inverse: thm, |
22 {type_definition: thm, set_def: thm option, Rep: thm, Rep_inverse: thm, |
23 Abs_inverse: thm, Rep_inject: thm, Abs_inject: thm, Rep_cases: thm, Abs_cases: thm, |
23 Abs_inverse: thm, Rep_inject: thm, Abs_inject: thm, Rep_cases: thm, Abs_cases: thm, |
24 Rep_induct: thm, Abs_induct: thm} |
24 Rep_induct: thm, Abs_induct: thm} |
25 val typedef_proof: string * (bstring * string list * mixfix) * string * (string * string) option |
25 val typedef_proof: (bool * string) * (bstring * string list * mixfix) * string |
26 -> bool -> theory -> ProofHistory.T |
26 * (string * string) option -> bool -> theory -> ProofHistory.T |
27 val typedef_proof_i: string * (bstring * string list * mixfix) * term * (string * string) option |
27 val typedef_proof_i: (bool * string) * (bstring * string list * mixfix) * term |
28 -> bool -> theory -> ProofHistory.T |
28 * (string * string) option -> bool -> theory -> ProofHistory.T |
29 end; |
29 end; |
30 |
30 |
31 structure TypedefPackage: TYPEDEF_PACKAGE = |
31 structure TypedefPackage: TYPEDEF_PACKAGE = |
32 struct |
32 struct |
33 |
33 |
236 val add_typedef_i = sane_typedef cert_term; |
236 val add_typedef_i = sane_typedef cert_term; |
237 |
237 |
238 |
238 |
239 (* typedef_proof interface *) |
239 (* typedef_proof interface *) |
240 |
240 |
241 fun gen_typedef_proof prep_term (name, typ, set, opt_morphs) int thy = |
241 fun gen_typedef_proof prep_term ((def, name), typ, set, opt_morphs) int thy = |
242 let |
242 let |
243 val (_, goal, goal_pat, att_result) = |
243 val (_, goal, goal_pat, att_result) = |
244 prepare_typedef prep_term true name typ set opt_morphs thy; |
244 prepare_typedef prep_term def name typ set opt_morphs thy; |
245 val att = #1 o att_result; |
245 val att = #1 o att_result; |
246 in thy |> IsarThy.theorem_i Drule.internalK (("", [att]), (goal, ([goal_pat], []))) int end; |
246 in thy |> IsarThy.theorem_i Drule.internalK (("", [att]), (goal, ([goal_pat], []))) int end; |
247 |
247 |
248 val typedef_proof = gen_typedef_proof read_term; |
248 val typedef_proof = gen_typedef_proof read_term; |
249 val typedef_proof_i = gen_typedef_proof cert_term; |
249 val typedef_proof_i = gen_typedef_proof cert_term; |
259 (P.type_args -- P.name -- P.opt_infix >> (fn ((vs, t), mx) => |
259 (P.type_args -- P.name -- P.opt_infix >> (fn ((vs, t), mx) => |
260 Toplevel.theory (add_typedecls [(t, vs, mx)]))); |
260 Toplevel.theory (add_typedecls [(t, vs, mx)]))); |
261 |
261 |
262 |
262 |
263 val typedef_proof_decl = |
263 val typedef_proof_decl = |
264 Scan.option (P.$$$ "(" |-- P.name --| P.$$$ ")") -- |
264 Scan.optional (P.$$$ "(" |-- P.!!! |
|
265 (((P.$$$ "open" >> K false) -- Scan.option P.name || P.name >> (fn s => (true, Some s))) |
|
266 --| P.$$$ ")")) (true, None) -- |
265 (P.type_args -- P.name) -- P.opt_infix -- (P.$$$ "=" |-- P.term) -- |
267 (P.type_args -- P.name) -- P.opt_infix -- (P.$$$ "=" |-- P.term) -- |
266 Scan.option (P.$$$ "morphisms" |-- P.!!! (P.name -- P.name)); |
268 Scan.option (P.$$$ "morphisms" |-- P.!!! (P.name -- P.name)); |
267 |
269 |
268 fun mk_typedef_proof ((((opt_name, (vs, t)), mx), A), morphs) = |
270 fun mk_typedef_proof ((((((def, opt_name), (vs, t)), mx), A), morphs)) = |
269 typedef_proof (if_none opt_name (Syntax.type_name t mx), (t, vs, mx), A, morphs); |
271 typedef_proof ((def, if_none opt_name (Syntax.type_name t mx)), (t, vs, mx), A, morphs); |
270 |
272 |
271 val typedefP = |
273 val typedefP = |
272 OuterSyntax.command "typedef" "HOL type definition (requires non-emptiness proof)" K.thy_goal |
274 OuterSyntax.command "typedef" "HOL type definition (requires non-emptiness proof)" K.thy_goal |
273 (typedef_proof_decl >> (Toplevel.print oo (Toplevel.theory_to_proof o mk_typedef_proof))); |
275 (typedef_proof_decl >> (Toplevel.print oo (Toplevel.theory_to_proof o mk_typedef_proof))); |
274 |
276 |