108 end; |
108 end; |
109 |
109 |
110 |
110 |
111 (* defs *) |
111 (* defs *) |
112 |
112 |
|
113 infix also; |
|
114 fun eq1 also eq2 = |
|
115 eq2 COMP (eq1 COMP (Drule.incr_indexes2 eq1 eq2 transitive_thm)); |
|
116 |
113 local |
117 local |
|
118 |
|
119 fun expand_defs ctxt t = |
|
120 let |
|
121 val thy = ProofContext.theory_of ctxt; |
|
122 val thy_ctxt = ProofContext.init thy; |
|
123 val ct = Thm.cterm_of thy t; |
|
124 val (defs, ct') = LocalDefs.expand_defs ctxt thy_ctxt (Drule.mk_term ct) ||> Drule.dest_term; |
|
125 in (Thm.term_of ct', Tactic.rewrite true defs ct) end; |
114 |
126 |
115 fun add_def (name, prop) = |
127 fun add_def (name, prop) = |
116 Theory.add_defs_i false false [(name, prop)] #> |
128 Theory.add_defs_i false false [(name, prop)] #> |
117 (fn thy => (Drule.unvarify (Thm.get_axiom_i thy (Sign.full_name thy name)), thy)); |
129 (fn thy => (Drule.unvarify (Thm.get_axiom_i thy (Sign.full_name thy name)), thy)); |
118 |
130 |
119 fun expand_defs lthy = |
|
120 Drule.term_rule (ProofContext.theory_of lthy) |
|
121 (Assumption.export false lthy (LocalTheory.target_of lthy)); |
|
122 |
|
123 infix also; |
|
124 fun eq1 also eq2 = Thm.transitive eq1 eq2; |
|
125 |
|
126 in |
131 in |
127 |
132 |
128 fun defs kind args lthy = |
133 fun defs kind args lthy0 = |
129 let |
134 let |
130 fun def ((c, mx), ((name, atts), rhs)) lthy1 = |
135 fun def ((c, mx), ((name, atts), rhs)) lthy1 = |
131 let |
136 let |
|
137 val (rhs', rhs_conv) = expand_defs lthy0 rhs; |
|
138 val xs = Variable.add_fixed (LocalTheory.target_of lthy0) rhs' []; |
|
139 |
|
140 val ([(lhs, lhs_def)], lthy2) = lthy1 |
|
141 |> LocalTheory.consts (member (op =) xs) [((c, Term.fastype_of rhs), mx)]; |
|
142 val lhs' = #2 (Logic.dest_equals (Thm.prop_of lhs_def)); |
|
143 |
132 val name' = Thm.def_name_optional c name; |
144 val name' = Thm.def_name_optional c name; |
133 val T = Term.fastype_of rhs; |
145 val (def, lthy3) = lthy2 |
134 |
|
135 val rhs' = expand_defs lthy1 rhs; |
|
136 val depends = member (op =) (Term.add_frees rhs' []); |
|
137 val defined = filter_out depends (Term.add_frees rhs []); |
|
138 |
|
139 val ([(lhs, local_def)], lthy2) = lthy1 |
|
140 |> LocalTheory.consts depends [((c, T), mx)]; |
|
141 val lhs' = #2 (Logic.dest_equals (Thm.prop_of local_def)); |
|
142 |
|
143 val rhs_conv = rhs |
|
144 |> Thm.cterm_of (ProofContext.theory_of lthy1) |
|
145 |> Tactic.rewrite true (map_filter (LocalDefs.find_def lthy1 o #1) defined); |
|
146 |
|
147 val (global_def, lthy3) = lthy2 |
|
148 |> LocalTheory.theory_result (add_def (name', Logic.mk_equals (lhs', rhs'))); |
146 |> LocalTheory.theory_result (add_def (name', Logic.mk_equals (lhs', rhs'))); |
149 |
147 |
150 val eq = |
148 val eq = |
151 local_def (*c == loc.c xs*) |
149 (*c == loc.c xs*) lhs_def |
152 also global_def (*... == rhs'*) |
150 (*lhs' == rhs'*) also def |
153 also Thm.symmetric rhs_conv; (*... == rhs*) |
151 (*rhs' == rhs*) also Thm.symmetric rhs_conv; |
154 in ((lhs, ((name', atts), [([eq], [])])), lthy3) end; |
152 in ((lhs, ((name', atts), [([eq], [])])), lthy3) end; |
155 |
153 |
156 val ((lhss, facts), lthy') = lthy |> fold_map def args |>> split_list; |
154 val ((lhss, facts), lthy') = lthy0 |> fold_map def args |>> split_list; |
157 val (res, lthy'') = lthy' |> LocalTheory.notes kind facts; |
155 val (res, lthy'') = lthy' |> LocalTheory.notes kind facts; |
158 in (lhss ~~ map (apsnd the_single) res, lthy'') end; |
156 in (lhss ~~ map (apsnd the_single) res, lthy'') end; |
159 |
157 |
160 end; |
158 end; |
161 |
159 |