24 open FundefCommon |
24 open FundefCommon |
25 |
25 |
26 val True_implies = thm "True_implies" |
26 val True_implies = thm "True_implies" |
27 |
27 |
28 |
28 |
29 fun fundef_afterqed congs curry_info name data natts thmss thy = |
29 fun fundef_afterqed congs curry_info name data names atts thmss thy = |
30 let |
30 let |
31 val (complete_thm :: compat_thms) = map hd thmss |
31 val (complete_thm :: compat_thms) = map hd thmss |
32 val fundef_data = FundefProof.mk_partial_rules_curried thy congs curry_info data (freezeT complete_thm) (map freezeT compat_thms) |
32 val fundef_data = FundefProof.mk_partial_rules_curried thy congs curry_info data (freezeT complete_thm) (map freezeT compat_thms) |
33 val FundefResult {psimps, subset_pinduct, simple_pinduct, total_intro, dom_intros, ...} = fundef_data |
33 val FundefResult {psimps, subset_pinduct, simple_pinduct, total_intro, dom_intros, ...} = fundef_data |
34 |
34 |
35 val (names, attsrcs) = split_list natts |
|
36 val atts = map (map (Attrib.attribute thy)) attsrcs |
|
37 |
35 |
38 val Prep {names = Names {acc_R=accR, ...}, ...} = data |
36 val Prep {names = Names {acc_R=accR, ...}, ...} = data |
39 val dom_abbrev = Logic.mk_equals (Free (name ^ "_dom", fastype_of accR), accR) |
37 val dom_abbrev = Logic.mk_equals (Free (name ^ "_dom", fastype_of accR), accR) |
40 val (_, thy) = LocalTheory.mapping NONE (Specification.abbreviation_i ("", false) [(NONE, dom_abbrev)]) thy |
38 val (_, thy) = LocalTheory.mapping NONE (Specification.abbreviation_i ("", false) [(NONE, dom_abbrev)]) thy |
41 |
39 |
53 val thy = thy |> Theory.parent_path |
51 val thy = thy |> Theory.parent_path |
54 in |
52 in |
55 add_fundef_data name fundef_data thy |
53 add_fundef_data name fundef_data thy |
56 end |
54 end |
57 |
55 |
58 fun add_fundef eqns_atts thy = |
56 fun gen_add_fundef prep_att eqns_atts thy = |
59 let |
57 let |
60 val (natts, eqns) = split_list eqns_atts |
58 val (natts, eqns) = split_list eqns_atts |
|
59 val (names, raw_atts) = split_list natts |
|
60 |
|
61 val atts = map (map (prep_att thy)) raw_atts |
61 |
62 |
62 val congs = get_fundef_congs (Context.Theory thy) |
63 val congs = get_fundef_congs (Context.Theory thy) |
63 |
64 |
64 val (curry_info, name, (data, thy)) = FundefPrep.prepare_fundef_curried congs (map (Sign.read_prop thy) eqns) thy |
65 val t_eqns = map (Sign.read_prop thy) eqns |
|
66 |> map (term_of o cterm_of thy) (* HACK to prevent strange things from happening with abbreviations *) |
|
67 |
|
68 val (curry_info, name, (data, thy)) = FundefPrep.prepare_fundef_curried congs t_eqns thy |
65 val Prep {complete, compat, ...} = data |
69 val Prep {complete, compat, ...} = data |
66 |
70 |
67 val props = (complete :: compat) (*(complete :: fst (chop 110 compat))*) |
71 val props = (complete :: compat) (*(complete :: fst (chop 110 compat))*) |
68 in |
72 in |
69 thy |> ProofContext.init |
73 thy |> ProofContext.init |
70 |> Proof.theorem_i PureThy.internalK NONE (fundef_afterqed congs curry_info name data natts) NONE ("", []) |
74 |> Proof.theorem_i PureThy.internalK NONE (fundef_afterqed congs curry_info name data names atts) NONE ("", []) |
71 (map (fn t => (("", []), [(t, [])])) props) |
75 (map (fn t => (("", []), [(t, [])])) props) |
72 end |
76 end |
73 |
77 |
74 |
78 |
75 fun total_termination_afterqed name thmss thy = |
79 fun total_termination_afterqed name thmss thy = |
150 |> Proof.theorem_i PureThy.internalK NONE (K I) NONE ("", []) |
154 |> Proof.theorem_i PureThy.internalK NONE (K I) NONE ("", []) |
151 [(("", []), [(subs, []), (dcl, [])])] |
155 [(("", []), [(subs, []), (dcl, [])])] |
152 end |
156 end |
153 |
157 |
154 |
158 |
|
159 val add_fundef = gen_add_fundef Attrib.attribute |
|
160 |
155 |
161 |
156 |
162 |
157 (* congruence rules *) |
163 (* congruence rules *) |
158 |
164 |
159 val cong_add = Thm.declaration_attribute (map_fundef_congs o cons o safe_mk_meta_eq); |
165 val cong_add = Thm.declaration_attribute (map_fundef_congs o cons o safe_mk_meta_eq); |